stacker-0.0.1.0: src/Analysis.hs

{-# LANGUAGE OverloadedStrings #-}

module Analysis
  ( analyzeStackYaml
  , analyzeAllStackYamls
  , analyzeStackYamls
  , determineNewSnapshot
  ) where

import Prelude hiding (min, span)

import Control.Applicative ((<|>))
import Control.Monad (filterM)
import Data.Functor ((<&>))
import Data.List (maximumBy)
import Data.Map.Strict qualified as Map
import Data.Maybe (catMaybes, fromMaybe)
import Data.Ord (comparing)
import Data.Text (Text)
import Data.Text qualified as T
import System.Directory (doesFileExist)
import Text.Printf (printf)

import Types (Action(..), Bump(..), SnapshotDB(..), LTSVersion(..), NightlyVersion(..), GHCVersion(..), Snapshot(..))
import StackYaml (parseStackYaml, findStackYamlFiles, findStackYamlFilesRecursive, getSymlinkMap)

-- | Analyze a single stack.yaml file
analyzeStackYaml :: SnapshotDB -> Map.Map FilePath FilePath -> FilePath -> IO (Maybe Action)
analyzeStackYaml db symlinkMap file = do
  -- Check if this file is a symlink to another stack*.yaml file in our list
  let symlinkTarget = Map.lookup file symlinkMap

  parseStackYaml file <&> \case
    Nothing -> Nothing
    Just (oldSnap, isResolver, span) -> do
      let newSnap = determineNewSnapshot db oldSnap
      Just $ Action file oldSnap newSnap isResolver span symlinkTarget

-- | Analyze specific stack*.yaml files, or all if empty list
-- If recursive is True, search recursively in all subdirectories
analyzeStackYamls :: SnapshotDB -> [FilePath] -> Bool -> IO [Action]
analyzeStackYamls db files recursive = do
  -- Get files to analyze: either auto-discover or use provided list
  -- Non-existent files are silently filtered out
  filesToAnalyze <-
    if null files
      then if recursive
           then findStackYamlFilesRecursive
           else findStackYamlFiles
      else filterM doesFileExist files
  symlinkMap <- getSymlinkMap filesToAnalyze
  results <- mapM (analyzeStackYaml db symlinkMap) filesToAnalyze
  return $ catMaybes results

-- | Analyze all stack*.yaml files in the current directory
analyzeAllStackYamls :: SnapshotDB -> IO [Action]
analyzeAllStackYamls db = analyzeStackYamls db [] False

-- | Determine the new snapshot for a given old snapshot
determineNewSnapshot :: SnapshotDB -> Text -> Bump
determineNewSnapshot db oldSnap
  | T.isPrefixOf "lts-" oldSnap = fromMaybe Unknown $ determineLTSBump db oldSnap
  | T.isPrefixOf "nightly-" oldSnap = fromMaybe Unknown $ determineNightlyBump db oldSnap
  | otherwise = Unknown

-- | Compare the latest known snapshot with the old one.
-- If the old snapshot is newer than anything we know of,
-- our database is outdated and we cannot give advice.
compareWithLatest :: Ord a => a -> a -> Snapshot -> Bump
compareWithLatest old latest snap = case compare latest old of
  GT -> BumpTo (formatSnapshot snap)
  EQ -> UpToDate
  LT -> Unknown

-- | Determine bump for LTS snapshot
determineLTSBump :: SnapshotDB -> Text -> Maybe Bump
determineLTSBump db oldSnap = do
  oldVersion <- parseLTSSnapshot oldSnap
  -- Find the latest LTS with the same major version
  let sameMajor = filter (\(LTSVersion maj _, _) -> maj == ltsMajor oldVersion) $ Map.toList (dbLTS db)
  if null sameMajor
    then Nothing
    else do
      let (latestVersion, _) = maximumBy (comparing fst) sameMajor
      return $ compareWithLatest oldVersion latestVersion (LTS latestVersion)

-- | Determine bump for nightly snapshot
determineNightlyBump :: SnapshotDB -> Text -> Maybe Bump
determineNightlyBump db oldSnap = do
  oldVersion <- parseNightlySnapshot oldSnap
  -- The exact nightly may be missing from the database
  -- (e.g. a date for which no nightly was published);
  -- then take the GHC version of the closest known neighbour.
  (_, oldGHC) <- Map.lookupLE oldVersion (dbNightly db) <|> Map.lookupGE oldVersion (dbNightly db)
  -- Get GHC major version (e.g., (9,6) from GHCVersion 9 6 1)
  let ghcMajor = getGHCMajor oldGHC
  -- Find if there's an LTS for this GHC major version
  let ltsForGHC = filter (\(_, ghc) -> getGHCMajor ghc == ghcMajor) $ Map.toList (dbLTS db)
  if not (null ltsForGHC)
    then do
      -- Bump to latest LTS for this GHC major
      let (latestLTS, _) = maximumBy (comparing fst) ltsForGHC
      return $ BumpTo $ formatSnapshot (LTS latestLTS)
    else do
      -- Bump to latest nightly for this GHC major
      let nightliesForGHC = filter (\(_, ghc) -> getGHCMajor ghc == ghcMajor) $ Map.toList (dbNightly db)
      if null nightliesForGHC
        then Nothing
        else do
          let (latestNightly, _) = maximumBy (comparing fst) nightliesForGHC
          return $ compareWithLatest oldVersion latestNightly (Nightly latestNightly)

-- | Get GHC major version from full version (e.g., (9,6) from GHCVersion 9 6 1)
getGHCMajor :: GHCVersion -> (Int, Int)
getGHCMajor (GHCVersion maj1 maj2 _) = (maj1, maj2)

-- | Parse LTS snapshot string
parseLTSSnapshot :: Text -> Maybe LTSVersion
parseLTSSnapshot snap =
  case T.splitOn "." (T.drop 4 snap) of  -- Remove "lts-"
    [majStr, minStr] ->
      case (reads $ T.unpack majStr, reads $ T.unpack minStr) of
        ([(maj, "")], [(min, "")]) -> Just $ LTSVersion maj min
        _ -> Nothing
    _ -> Nothing

-- | Parse nightly snapshot string
parseNightlySnapshot :: Text -> Maybe NightlyVersion
parseNightlySnapshot snap =
  case T.splitOn "-" (T.drop 8 snap) of  -- Remove "nightly-"
    [yearStr, monthStr, dayStr] ->
      case (reads $ T.unpack yearStr, reads $ T.unpack monthStr, reads $ T.unpack dayStr) of
        ([(year, "")], [(month, "")], [(day, "")]) -> Just $ NightlyVersion year month day
        _ -> Nothing
    _ -> Nothing

-- | Format a snapshot as a string
formatSnapshot :: Snapshot -> Text
formatSnapshot (LTS (LTSVersion maj min)) =
  "lts-" <> T.pack (show maj) <> "." <> T.pack (show min)
formatSnapshot (Nightly (NightlyVersion year month day)) =
  T.pack $ "nightly-" ++ printf "%d-%02d-%02d" year month day