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

module Main (main) where

import Control.Arrow (first, second, (&&&))
import Control.Monad.Writer

import qualified Data.Map.Lazy as M
import qualified Data.Map.Strict as MS
import qualified Data.Text as T
import qualified Data.Text.IO as TIO

import Data.Char (isAlpha)
import Data.Functor (($>))
import Data.List (find, nub, sortOn)
import Data.Map.Lazy (Map)
import Data.Maybe (catMaybes, maybeToList)
import Data.Ord (Down (Down))
import Data.Text.Read (decimal)

import System.Environment (getArgs)
import System.Exit (exitFailure)
import System.IO (stderr)
import Text.Printf (hPrintf, printf)

type Str = T.Text
type Data = Map Str [Package]
type Version = [Int]
type Err a = Either Str a

data Package = Package
    { name :: Str
    , version :: Version
    , filename, sha256 :: Str
    , size :: Int
    , depends :: [Dependency]
    }
    deriving (Show, Eq)

data Dependency = Dependency
    { pkgName :: Str
    , pkgVersion :: Maybe (Ordering', Version)
    }
    deriving (Show, Eq)

data Kit = Kit
    { kitMajorVersion, kitFullVersion :: Version
    , kitPackages :: [Package]
    }
    deriving (Show, Eq)

-- Standard Ordering cannot represent GE or LE, we have to cook our own
data Ordering' = GT' | LT' | EQ' | GE' | LE' deriving (Show, Eq)

-- PARSING

parse :: Str -> Err Data
parse =
    fmap (M.map (sortOn (Down . version)) . M.fromListWith (++) . fmap (second pure))
        . mapM parsePackage
        . ( init
                . fmap
                    ( M.fromList
                        . ( fmap (second (T.strip . T.drop 1) . T.breakOn ":")
                                . T.lines
                                . T.strip
                          )
                    )
                . T.splitOn "\n\n"
          )

parseDependency :: Str -> Err Dependency
parseDependency t = case (T.breakOn "(" t) of
    (a, "") -> Right $ Dependency (T.strip a) Nothing
    (a, b) -> do
        let (o, v) = T.span (`elem` ("<=>" :: String)) $ T.tail b
        o' <- toOrd' o
        v' <- parseVersion . T.strip $ T.dropEnd 1 v
        return . Dependency (T.strip a) $ Just (o', v')
  where
    toOrd' :: Str -> Err Ordering'
    toOrd' ">>" = Right GT'
    toOrd' "<<" = Right LT'
    toOrd' "=" = Right EQ'
    toOrd' ">=" = Right GE'
    toOrd' "<=" = Right LE'
    toOrd' r = Left $ T.unwords ["could not parse dependency", quote t, "(unknown constraint type", quote r <> ")"]

dropEmpty :: [Str] -> [Str]
dropEmpty = filter (not . T.null)

tshow :: (Show a) => a -> Str
tshow = T.pack . show

quote :: Str -> Str
quote = ("\"" <>) . (<> "\"")

parseVersion :: Str -> Err Version
parseVersion = (>>= validateVersion) . mapM (unwrapDecimal . decimal) . dropEmpty . T.split (`elem` ("-._~" :: String))
  where
    unwrapDecimal (Left err) = Left . T.pack $ "version parsing failed with error: " <> err
    unwrapDecimal (Right (a, "")) = Right a
    unwrapDecimal (Right (a, b)) =
        Left $ T.unwords ["version parsing failed, parsed", quote $ tshow a, "(leftover:", quote b <> ")"]

    validateVersion [] = Left "version is empty"
    validateVersion v = Right v

parsePackage :: Map Str Str -> Err (Str, Package)
parsePackage d =
    (,)
        <$> package
        <*> ( Package
                <$> package
                <*> (d !? "Version" >>= parseVersion)
                <*> (d !? "Filename")
                <*> (d !? "SHA256")
                <*> (read . T.unpack <$> (d !? "Installed-Size"))
                <*> (mapM parseDependency . dropEmpty . (>>= T.splitOn ",") . maybeToList $ d M.!? "Depends")
            )
  where
    package = d !? "Package"

(!?) :: (Show a) => Map Str a -> Str -> Err a
m !? k = maybeToEither ("missing key " <> quote k <> " in:\n" <> tshow m) $ m M.!? k

maybeToEither :: a -> Maybe b -> Either a b
maybeToEither _ (Just b) = Right b
maybeToEither a Nothing = Left a

-- DEPENDENCY SOLVER

-- Compare versions in debian control file syntax
-- See: https://www.debian.org/doc/debian-policy/ch-relationships.html#syntax-of-relationship-fields
--
-- NOTE: this is not a proper version comparison
--
-- A proper version solver, should aggregate dependencies with the same name
-- and compute the constraint (e.g. a (>= 2) a (<< 5) -> 2 <= a << 5)
--
-- But in the intel repo, there are no such "duplicated" dependencies to specify
-- upper limits, which leads to issues when intel-hpckit-2021 depends on things
-- like intel-basekit >= 2021.1.0-2403 and we end up installing the newest
-- basekit instead of the one from 2021.1
--
-- To mitigate this, >= is set to take the latest version with matching major
-- and minor (only revision and patch are allowed to change)

compareVersions :: Maybe (Ordering', Version) -> Version -> Bool
compareVersions Nothing _ = True
compareVersions (Just (kind, want)) got
    | null want = True
    | kind == GE' = and (take 2 $ zipWith (==) got want) && result
    | kind == EQ' = and $ zipWith (==) want got -- Only compare up to the smallest list
    | otherwise = result
  where
    result = matches (compare got want) kind

    matches :: Ordering -> Ordering' -> Bool
    matches EQ b = b `elem` [EQ', GE', LE']
    matches LT b = b `elem` [LT', LE']
    matches GT b = b `elem` [GT', GE']

findMatching :: Data -> Dependency -> Maybe Package
findMatching pkgList (Dependency n v) = pkgList M.!? n >>= find (compareVersions v . version)

findMatchingTraced :: Data -> Dependency -> Writer [Dependency] (Maybe Package)
findMatchingTraced l d = case findMatching l d of
    Nothing -> tell [d] $> Nothing
    Just a -> pure $ Just a

solveDeps :: Data -> Package -> ([Package], [Dependency])
solveDeps d p = first removeDupes $ runWriter $ go [] [p]
  where
    go :: [Package] -> [Package] -> Writer [Dependency] [Package]
    go done [] = pure done
    go done todo = do
        let done' = filter (not . isBlacklisted) . nub $ done ++ (filter (not . isMetaPackage) todo)
        todo' <- catMaybes <$> mapM (findMatchingTraced d) (todo >>= depends)
        go done' todo'

    isMetaPackage = ((== 0) . size) -- Meta Packages are only used to pull dependencies
    removeDupes :: [Package] -> [Package]
    removeDupes = fmap snd . MS.toList . MS.fromListWith getLatest . fmap (cleanName . name &&& id)

    getLatest a b
        | version a > version b = a
        | otherwise = b

-- Remove trailing version information from package name
cleanName :: Str -> Str
cleanName = T.dropWhileEnd (not . isAlpha)

isBlacklisted :: Package -> Bool
isBlacklisted = (`elem` blacklist) . cleanName . name
  where
    blacklist =
        [ "intel-basekit-env"
        , "intel-basekit-getting-started"
        , "intel-hpckit-env"
        , "intel-hpckit-getting-started"
        , "intel-oneapi-advisor"
        , "intel-oneapi-common-licensing"
        , "intel-oneapi-common-oneapi-vars"
        , "intel-oneapi-common-vars"
        , "intel-oneapi-compiler-cpp-eclipse-cfg"
        , "intel-oneapi-compiler-dpcpp-eclipse-cfg"
        , "intel-oneapi-condaindex"
        , "intel-oneapi-dev-utilities-eclipse-cfg"
        , "intel-oneapi-dpcpp-ct-eclipse-cfg"
        , "intel-oneapi-eclipse-ide"
        , "intel-oneapi-hpc-toolkit-getting-started"
        , "intel-oneapi-icc-eclipse-plugin-cpp"
        , "intel-oneapi-inspector"
        , "intel-oneapi-vtune"
        , "intel-oneapi-vtune-eclipse-plugin-vtune"
        ]

application :: [String] -> Str -> Err ([Dependency], [Kit])
application args contents = do
    v <- mapM (parseVersion . T.pack) $ case args of
        [] -> ["2025"]
        _ -> args

    d <- parse contents
    first concat . unzip <$> mapM (processKit d) v

processKit :: Data -> Version -> Err ([Dependency], Kit)
processKit d v = do
    kit <- findHpckit "intel-hpckit"
    let (deps, missing) = solveDeps d kit
    return $ (missing, Kit v (version kit) deps)
  where
    findHpckit pName =
        maybeToEither (T.unwords ["package not found:", pName, "=", showVer v]) $
            findMatching d (Dependency pName (Just (EQ', v)))

-- OUTPUT

showVer, showVerDash :: [Int] -> Str
showVer = T.dropEnd 1 . T.concat . zipWith (flip (<>)) ([".", ".", "-"] ++ repeat ".") . fmap tshow
showVerDash = T.intercalate "-" . fmap tshow

-- Reads Debian Package List from apt repo from stdin and outputs TOML with
-- hpckit versions passed as arguments
main :: IO ()
main =
    application <$> getArgs <*> TIO.getContents >>= \case
        Left err -> hPrintf stderr "[ERROR]: %s\n" err *> exitFailure
        Right (missing, kits) -> do
            mapM_ (hPrintf stderr "[WARN] missing dependency: %s\n" . show) $ nub missing
            mapM_ (TIO.putStrLn) $ kits >>= formatKit
  where
    formatKit (Kit majorVer fullVer pkgs) =
        T.pack
            <$> (printf "[meta.hpckit-%s]\nversion=%s\n" (showVerDash majorVer) (quote $ showVer fullVer))
                : ((formatPackage) <$> pkgs)
      where
        formatPackage (Package n v f h _ _) =
            printf "[[hpckit-%s]]\nname=%s\nversion=%s\nfile=%s\nsha256=%s\n" (showVerDash majorVer) (quote $ cleanName n) (quote $ showVer v) (quote f) (quote h)