{-# LANGUAGE OverloadedStrings #-}

module StackYaml
  ( findStackYamlFiles
  , parseStackYaml
  , applyAction
  , isStackYaml
  , getSymlinkMap
  ) where

import Control.Monad (filterM, when)
import Data.List (isPrefixOf, isSuffixOf, sort)
import Data.Map.Strict qualified as Map
import Data.Maybe (catMaybes)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.IO qualified as TIO
import System.Directory (listDirectory, doesFileExist, pathIsSymbolicLink, getSymbolicLinkTarget)
import System.FilePath (takeFileName, normalise, makeRelative)
import Types (Action(..))

-- | Check if a filename is a stack*.yaml file
isStackYaml :: FilePath -> Bool
isStackYaml :: FilePath -> Bool
isStackYaml FilePath
name =
  let fname :: FilePath
fname = FilePath -> FilePath
takeFileName FilePath
name
  in FilePath
"stack" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
fname Bool -> Bool -> Bool
&& FilePath
".yaml" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` FilePath
fname

-- | Find all stack*.yaml files in the current directory
findStackYamlFiles :: IO [FilePath]
findStackYamlFiles :: IO [FilePath]
findStackYamlFiles = do
  files <- FilePath -> IO [FilePath]
listDirectory FilePath
"."
  let candidates = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
isStackYaml [FilePath]
files
  sort <$> filterM doesFileExist candidates

-- | Get a map of symlinks to their targets (only for symlinks pointing to other stack*.yaml files in the list)
getSymlinkMap :: [FilePath] -> IO (Map.Map FilePath FilePath)
getSymlinkMap :: [FilePath] -> IO (Map FilePath FilePath)
getSymlinkMap [FilePath]
files = do
  -- Find symlinks in the list
  symlinks <- (FilePath -> IO Bool) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM FilePath -> IO Bool
pathIsSymbolicLink [FilePath]
files

  -- For each symlink, check if it points to another file in the list
  results <- mapM checkSymlink symlinks

  return $ Map.fromList $ catMaybes results
  where
    checkSymlink :: FilePath -> IO (Maybe (FilePath, FilePath))
    checkSymlink :: FilePath -> IO (Maybe (FilePath, FilePath))
checkSymlink FilePath
link = do
      target <- FilePath -> IO FilePath
getSymbolicLinkTarget FilePath
link
      -- Normalize the target path to handle relative paths
      let normalizedTarget = FilePath -> FilePath
normalise FilePath
target
      let relativeTarget = FilePath -> FilePath -> FilePath
makeRelative FilePath
"." FilePath
normalizedTarget
      -- Check if the target is in our file list
      if relativeTarget `elem` files
        then return $ Just (link, relativeTarget)
        else return Nothing

-- | Parse a stack.yaml file to extract the snapshot field
parseStackYaml :: FilePath -> IO (Maybe (Text, Bool, (Int, Int)))
parseStackYaml :: FilePath -> IO (Maybe (Text, Bool, (Int, Int)))
parseStackYaml FilePath
file = do
  content <- FilePath -> IO Text
TIO.readFile FilePath
file
  return $ findSnapshot (T.unpack content) 0
  where
    findSnapshot :: FilePath -> Int -> Maybe (Text, Bool, (Int, Int))
findSnapshot FilePath
s Int
pos =
      case FilePath -> FilePath -> Int -> Maybe (FilePath, Int, Int)
findField FilePath
"snapshot:" FilePath
s Int
pos of
        Just (FilePath
value, Int
start, Int
end) -> (Text, Bool, (Int, Int)) -> Maybe (Text, Bool, (Int, Int))
forall a. a -> Maybe a
Just (FilePath -> Text
T.pack FilePath
value, Bool
False, (Int
start, Int
end))
        Maybe (FilePath, Int, Int)
Nothing ->
          case FilePath -> FilePath -> Int -> Maybe (FilePath, Int, Int)
findField FilePath
"resolver:" FilePath
s Int
pos of
            Just (FilePath
value, Int
start, Int
end) -> (Text, Bool, (Int, Int)) -> Maybe (Text, Bool, (Int, Int))
forall a. a -> Maybe a
Just (FilePath -> Text
T.pack FilePath
value, Bool
True, (Int
start, Int
end))
            Maybe (FilePath, Int, Int)
Nothing -> Maybe (Text, Bool, (Int, Int))
forall a. Maybe a
Nothing

    findField :: String -> String -> Int -> Maybe (String, Int, Int)
    findField :: FilePath -> FilePath -> Int -> Maybe (FilePath, Int, Int)
findField FilePath
field FilePath
s Int
pos =
      FilePath
-> FilePath -> Int -> FilePath -> Maybe (FilePath, Int, Int)
findFieldHelper FilePath
field FilePath
s Int
pos FilePath
s

    findFieldHelper :: String -> String -> Int -> String -> Maybe (String, Int, Int)
    findFieldHelper :: FilePath
-> FilePath -> Int -> FilePath -> Maybe (FilePath, Int, Int)
findFieldHelper FilePath
_field FilePath
_orig Int
_pos [] = Maybe (FilePath, Int, Int)
forall a. Maybe a
Nothing
    findFieldHelper FilePath
field FilePath
orig Int
pos s :: FilePath
s@(Char
_:FilePath
cs)
      | FilePath
field FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
s =
          let afterField :: FilePath
afterField = Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop (FilePath -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
field) FilePath
s
              trimmed :: FilePath
trimmed = (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (\Char
c -> Char
c Char -> FilePath -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (FilePath
" \t" :: String)) FilePath
afterField
              value :: FilePath
value = (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> FilePath -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (FilePath
"\n\r" :: String)) FilePath
trimmed
              valueStart :: Int
valueStart = Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (FilePath -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
orig Int -> Int -> Int
forall a. Num a => a -> a -> a
- FilePath -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
s) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ FilePath -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
field Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (FilePath -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
afterField Int -> Int -> Int
forall a. Num a => a -> a -> a
- FilePath -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
trimmed)
              valueEnd :: Int
valueEnd = Int
valueStart Int -> Int -> Int
forall a. Num a => a -> a -> a
+ FilePath -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
value
          in if FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
value
               then Maybe (FilePath, Int, Int)
forall a. Maybe a
Nothing
               else (FilePath, Int, Int) -> Maybe (FilePath, Int, Int)
forall a. a -> Maybe a
Just (FilePath
value, Int
valueStart, Int
valueEnd)
      | Bool
otherwise = FilePath
-> FilePath -> Int -> FilePath -> Maybe (FilePath, Int, Int)
findFieldHelper FilePath
field FilePath
orig Int
pos FilePath
cs

-- | Apply an action to update a stack.yaml file
applyAction :: Bool -> Action -> IO ()
applyAction :: Bool -> Action -> IO ()
applyAction Bool
verbose Action
action = do
  -- Skip symlinks that point to other stack*.yaml files in the list
  case Action -> Maybe FilePath
actionSymlinkTarget Action
action of
    Just FilePath
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- Skip symlinks
    Maybe FilePath
Nothing ->
      case Action -> Maybe Text
actionNewSnapshot Action
action of
        Maybe Text
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- No update needed
        Just Text
newSnap -> do
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Updating " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Action -> FilePath
actionFile Action
action
          content <- FilePath -> IO Text
TIO.readFile (Action -> FilePath
actionFile Action
action)
          let (before, after) = splitAtSpan (actionSpan action) content
          let updated = Text
before Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
newSnap Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
after
          TIO.writeFile (actionFile action) updated

-- | Split text at a character span
splitAtSpan :: (Int, Int) -> Text -> (Text, Text)
splitAtSpan :: (Int, Int) -> Text -> (Text, Text)
splitAtSpan (Int
start, Int
end) Text
text =
  let before :: Text
before = Int -> Text -> Text
T.take Int
start Text
text
      after :: Text
after = Int -> Text -> Text
T.drop Int
end Text
text
  in (Text
before, Text
after)