{-# LANGUAGE NamedFieldPuns #-}

module Proteome.Project.Resolve(
  resolveProject,
  resolveProjectFromConfig,
) where

import Control.Monad (foldM, join)
import Control.Monad.Reader ((<=<))
import Control.Monad.IO.Class (liftIO)
import Data.List (find)
import Data.List.Utils (uniq)
import Data.Maybe (fromMaybe)
import Data.Map.Strict ((!?), Map)
import System.Directory (doesDirectoryExist)
import System.FilePath (takeDirectory, (</>))
import Ribosome.File (canonicalPaths)
import Proteome.Config (ProjectConfig(ProjectConfig))
import Ribosome.Config.Setting (setting)
import Ribosome.Data.Maybe (orElse)
import Ribosome.Data.Ribo (Ribo)
import Proteome.Data.Project (
  Project(Project),
  ProjectName(..),
  ProjectRoot(..),
  ProjectType(..),
  ProjectLang(..),
  ProjectMetadata(DirProject, VirtualProject),
  )
import Proteome.Data.ProjectSpec (ProjectSpec(ProjectSpec))
import qualified Proteome.Data.ProjectSpec as PS (ProjectSpec(..))
import qualified Proteome.Settings as S

projectFromSegments :: ProjectType -> ProjectName -> ProjectRoot -> Project
projectFromSegments tpe name root =
  Project (DirProject name root (Just tpe)) [] (Just (ProjectLang (projectType tpe))) []

projectFromSpec :: ProjectSpec -> Project
projectFromSpec (ProjectSpec name root tpe types lang langs) =
  Project (DirProject name root tpe) types lang langs

hasProjectRoot :: ProjectRoot -> ProjectSpec -> Bool
hasProjectRoot root spec = root == PS.root spec

hasProjectTypeName :: ProjectType -> ProjectName -> ProjectSpec -> Bool
hasProjectTypeName tpe' name' (ProjectSpec name _ (Just tpe) _ _ _) =
  name' == name && tpe' == tpe
hasProjectTypeName _ _ _ = False

byProjectTypeName :: [ProjectSpec] -> ProjectName -> ProjectType -> Maybe ProjectSpec
byProjectTypeName specs name tpe = find (hasProjectTypeName tpe name) specs

matchProjectBases :: [FilePath] -> ProjectRoot -> Bool
matchProjectBases baseDirs (ProjectRoot root) = (takeDirectory . takeDirectory) root `elem` baseDirs

byProjectBaseSubpath :: ProjectName -> ProjectType -> FilePath -> IO (Maybe Project)
byProjectBaseSubpath n@(ProjectName name) t@(ProjectType tpe) base = do
  exists <- doesDirectoryExist root
  return $ if exists then Just $ projectFromSegments t n (ProjectRoot root) else Nothing
  where root = base </> tpe </> name

byProjectBasesSubpath :: [FilePath] -> ProjectName -> ProjectType -> IO (Maybe Project)
byProjectBasesSubpath baseDirs name tpe =
  foldM subpath Nothing baseDirs
  where
    subpath (Just p) _ = return (Just p)
    subpath Nothing a = byProjectBaseSubpath name tpe a

virtualProject :: ProjectName -> Project
virtualProject name = Project (VirtualProject name) [] Nothing []

resolveByTypeAndPath :: [FilePath] -> ProjectName -> ProjectType -> ProjectRoot -> Maybe Project
resolveByTypeAndPath baseDirs name tpe root =
  if matchProjectBases baseDirs root then Just (projectFromSegments tpe name root) else Nothing

resolveByType :: [FilePath] -> [ProjectSpec] -> Maybe ProjectRoot -> ProjectName -> ProjectType -> IO (Maybe Project)
resolveByType baseDirs explicit root name tpe = do
  byBaseSubpath <- byProjectBasesSubpath baseDirs name tpe
  return $ orElse (orElse byPath byBaseSubpath) (fmap projectFromSpec byTypeName)
  where
    byTypeName = byProjectTypeName explicit name tpe
    byPath = root >>= resolveByTypeAndPath baseDirs name tpe

resolveByRoot :: [ProjectSpec] -> ProjectRoot -> Maybe Project
resolveByRoot explicit root =
  fmap projectFromSpec byRoot
  where
    byRoot = find (hasProjectRoot root) explicit

augment :: Eq a => Map ProjectType [a] -> ProjectType -> [a] -> [a]
augment m tpe as =
  case m !? tpe of
    Just extra -> uniq $ as ++ extra
    Nothing -> as

augmentTypes :: ProjectConfig -> ProjectType -> [ProjectType] -> [ProjectType]
augmentTypes (ProjectConfig _ typeMap _) =
  augment typeMap

augmentLangs :: ProjectConfig -> ProjectType -> [ProjectLang] -> [ProjectLang]
augmentLangs (ProjectConfig _ _ langMap) =
  augment langMap

augmentFromConfig :: ProjectConfig -> Project -> Project
augmentFromConfig config (Project meta@(DirProject _ _ (Just tpe)) types lang langs) =
  Project meta (augmentTypes config tpe types) lang (augmentLangs config tpe langs)
augmentFromConfig _ project = project

resolveProject ::
  [FilePath] ->
  [ProjectSpec] ->
  ProjectConfig ->
  Maybe ProjectRoot ->
  ProjectName ->
  Maybe ProjectType ->
  IO Project
resolveProject baseDirs explicit config root name tpe = do
  byType <- traverse (resolveByType baseDirs explicit root name) tpe
  let byTypeOrVirtual = fromMaybe (virtualProject name) (join byType)
  let byRoot = root >>= resolveByRoot explicit
  let project = fromMaybe byTypeOrVirtual byRoot
  return $ augmentFromConfig config project

resolveProjectFromConfig :: Maybe ProjectRoot -> ProjectName -> Maybe ProjectType -> Ribo e Project
resolveProjectFromConfig root name tpe = do
  baseDirs <- (canonicalPaths <=< setting) S.projectBaseDirs
  -- typeDirs <- setting S.projectTypeDirs
  explicit <- setting S.projects
  config <- setting S.projectConfig
  liftIO $ resolveProject baseDirs explicit config root name tpe