Version.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}

module HWM.Core.Version
  ( Version,
    Bump (..),
    askVersion,
    nextVersion,
    dropPatch,
    parseGHCVersion,
    VersionChange (..),
    formatNixGhc,
    selectEra,
    Era (..),
    detectResolver,
    fromCabalVersion,
    toCabalVersion,
    latestGHCVersion,
  )
where

import Data.Aeson
  ( FromJSON (..),
    ToJSON (..),
    Value (..),
  )
import qualified Data.List.NonEmpty as NE
import qualified Data.Text as T
import qualified Distribution.Simple as Cabal
import GHC.Show (Show (..))
import HWM.Core.Formatting (Format (..), formatList)
import HWM.Core.Has (Has (obtain))
import HWM.Core.Parsing (Parse (..), fromToString, sepBy)
import Relude hiding (show)

data Version = Version
  { major :: Int,
    minor :: Int,
    revision :: [Int]
  }
  deriving
    ( Generic,
      Eq
    )

fromCabalVersion :: Cabal.Version -> Version
fromCabalVersion v = case fromSeries $ Cabal.versionNumbers v of
  Left err -> error $ "Invalid Cabal version: " <> err
  Right version -> version

toCabalVersion :: Version -> Cabal.Version
toCabalVersion version = Cabal.mkVersion (toSeries version)

formatNixGhc :: Version -> Text
formatNixGhc Version {..} = "ghc" <> T.concat (map (T.pack . show) [major, minor])

askVersion :: (MonadReader env m, Has env Version) => m Version
askVersion = asks obtain

getNumber :: [Int] -> Int
getNumber (n : _) = n
getNumber [] = 0

nextVersion :: Bump -> Version -> Version
nextVersion Major Version {..} = Version {major = major + 1, minor = 0, revision = [0], ..}
nextVersion Minor Version {..} = Version {minor = minor + 1, revision = [0], ..}
nextVersion Patch Version {..} = Version {revision = [getNumber revision + 1], ..}

dropPatch :: Version -> Version
dropPatch Version {..} = Version {revision = [0], ..}

compareSeries :: (Ord a) => [a] -> [a] -> Ordering
compareSeries [] _ = EQ
compareSeries _ [] = EQ
compareSeries (x : xs) (y : ys)
  | x == y = compareSeries xs ys
  | otherwise = compare x y

instance Format Version where
  format = formatList "." . toSeries

instance Parse Version where
  parse s = either tofail pure (sepBy "." vNumbers >>= fromSeries)
    where
      vNumbers = fromMaybe s (T.stripPrefix "v" s)
      tofail x = fail $ toString ("invalid version(" <> s <> ")" <> ": " <> x)

fromSeries :: (MonadFail m) => [Int] -> m Version
fromSeries [] = fail "version should have at least one number!"
fromSeries [major] = pure Version {major, minor = 0, revision = []}
fromSeries (major : (minor : revision)) = pure Version {..}

toSeries :: Version -> [Int]
toSeries Version {..} = [major, minor] <> revision

instance ToString Version where
  toString = toString . format

instance Ord Version where
  compare a b = compareSeries (toSeries a) (toSeries b)

instance Show Version where
  show = toString

instance ToText Version where
  toText = fromToString

instance FromJSON Version where
  parseJSON (String s) = parse s
  parseJSON (Number n) = parse (fromToString $ show n)
  parseJSON v = fail $ "version should be either true or string" <> toString (format v)

instance ToJSON Version where
  toJSON = String . toText

data Bump
  = Major
  | Minor
  | Patch
  deriving
    ( Generic,
      Eq
    )

instance Parse Bump where
  parse "major" = pure Major
  parse "minor" = pure Minor
  parse "patch" = pure Patch
  parse v = fail $ "Invalid bump type: " <> toString (fromToString v)

instance ToString Bump where
  toString Major = "major"
  toString Minor = "minor"
  toString Patch = "patch"

instance Format Bump where
  format Major = "major"
  format Minor = "minor"
  format Patch = "patch"

instance Show Bump where
  show = toString

instance ToText Bump where
  toText = fromToString

instance FromJSON Bump where
  parseJSON (String s) = parse s
  parseJSON v = fail $ "Invalid bump type: " <> show v

instance ToJSON Bump where
  toJSON = String . toText

parseGHCVersion :: (MonadFail m) => Text -> m Version
parseGHCVersion text = parse (fromMaybe text (T.stripPrefix "ghc-" text))

data VersionChange = FixedVersion Version | BumpVersion Bump deriving (Show)

isBump :: Text -> Bool
isBump = (`elem` ["major", "minor", "patch"])

instance Parse VersionChange where
  parse x
    | isBump x = BumpVersion <$> parse x
    | otherwise = FixedVersion <$> parse x

data Era = Era
  { eraVersion :: Version,
    eraStackageResolverName :: Text,
    eraNixpkgs :: Text
  }
  deriving (Show, Eq)

historicalEras :: NonEmpty Era
historicalEras =
  Era (Version 9 10 []) "nightly" "nixos-unstable"
    :| [ Era (Version 9 8 []) "lts-23.0" "nixos-24.05",
         Era (Version 9 6 []) "lts-22.43" "nixos-24.05",
         Era (Version 9 4 []) "lts-21.25" "nixos-23.11",
         Era (Version 9 2 []) "lts-20.26" "nixos-23.05",
         Era (Version 8 10 []) "lts-18.28" "nixos-22.05"
       ]

selectEra :: Version -> Era
selectEra version = fromMaybe (NE.last historicalEras) $ find (\era -> eraVersion era <= version) historicalEras

detectResolver :: Version -> Text
detectResolver version = eraStackageResolverName $ selectEra version

latestGHCVersion :: Version
latestGHCVersion = eraVersion $ head historicalEras