{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}

-- |
-- Copyright:   (c) 2023 Bodigrim
-- License:     BSD-3-Clause
module Distribution.Client.Rename (
  parseCabalFile,
  resolveComponent,
  CommonStanza (..),
  validateDependency,
  RenameConfig (..),
  executeRenameConfig,
  validateChanges,
  TargetField (..),
) where

import Data.ByteString (ByteString)
import Data.ByteString.Char8 qualified as B
import Data.Char (isPunctuation, isSpace)
import Data.Foldable (fold)
import Data.List qualified as L
import Distribution.Client.Add (
  TargetField (..),
  parseCabalFile,
  resolveComponent,
  validateChanges,
  validateDependency,
 )
import Distribution.Client.Common (CommonStanza (..), getTargetName, isComponent, splitAtPosition)
import Distribution.Fields (
  Field (..),
  FieldLine (..),
  Name (..),
  SectionArg (..),
 )
import Distribution.PackageDescription (
  ComponentName (..),
 )
import Distribution.Parsec (
  Position (..),
 )

-- | An input for 'executeRenameConfig'.
data RenameConfig = RenameConfig
  { RenameConfig -> ByteString
cnfOrigContents :: !ByteString
  -- ^ Original Cabal file (with quirks patched,
  -- see "Distribution.PackageDescription.Quirks"),
  -- must be in sync with 'cnfFields'.
  , RenameConfig -> [Field Position]
cnfFields :: ![Field Position]
  -- ^ Parsed (by 'Distribution.Fields.readFields' or, more specifically, by 'parseCabalFile')
  -- representation of the Cabal file,
  -- must be in sync with 'cnfOrigContents'.
  , RenameConfig -> Either CommonStanza ComponentName
cnfComponent :: !(Either CommonStanza ComponentName)
  -- ^ Which component to update?
  -- Usually constructed by 'resolveComponent'.
  , RenameConfig -> TargetField
cnfTargetField :: !TargetField
  -- ^ In which field to rename the provided content?
  , RenameConfig -> ByteString
cnfRenameFrom :: !ByteString
  -- ^ Rename what?
  , RenameConfig -> ByteString
cnfRenameTo :: !ByteString
  -- ^ Rename to what?
  }
  deriving (RenameConfig -> RenameConfig -> Bool
(RenameConfig -> RenameConfig -> Bool)
-> (RenameConfig -> RenameConfig -> Bool) -> Eq RenameConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RenameConfig -> RenameConfig -> Bool
== :: RenameConfig -> RenameConfig -> Bool
$c/= :: RenameConfig -> RenameConfig -> Bool
/= :: RenameConfig -> RenameConfig -> Bool
Eq, Int -> RenameConfig -> ShowS
[RenameConfig] -> ShowS
RenameConfig -> String
(Int -> RenameConfig -> ShowS)
-> (RenameConfig -> String)
-> ([RenameConfig] -> ShowS)
-> Show RenameConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RenameConfig -> ShowS
showsPrec :: Int -> RenameConfig -> ShowS
$cshow :: RenameConfig -> String
show :: RenameConfig -> String
$cshowList :: [RenameConfig] -> ShowS
showList :: [RenameConfig] -> ShowS
Show)

-- | The main workhorse, renaming fields in a specified component
-- in the Cabal file.
executeRenameConfig
  :: (Either CommonStanza ComponentName -> ByteString -> Bool)
  -- ^ How to validate results? See 'validateChanges'.
  -> RenameConfig
  -- ^ Input arguments.
  -> Maybe ByteString
  -- ^ Updated contents, if validated successfully.
executeRenameConfig :: (Either CommonStanza ComponentName -> ByteString -> Bool)
-> RenameConfig -> Maybe ByteString
executeRenameConfig !Either CommonStanza ComponentName -> ByteString -> Bool
_ RenameConfig {ByteString
cnfRenameFrom :: RenameConfig -> ByteString
cnfRenameFrom :: ByteString
cnfRenameFrom}
  | ByteString -> Bool
B.null ByteString
cnfRenameFrom = Maybe ByteString
forall a. Maybe a
Nothing
executeRenameConfig Either CommonStanza ComponentName -> ByteString -> Bool
validator RenameConfig {[Field Position]
cnfFields :: RenameConfig -> [Field Position]
cnfFields :: [Field Position]
cnfFields, Either CommonStanza ComponentName
cnfComponent :: RenameConfig -> Either CommonStanza ComponentName
cnfComponent :: Either CommonStanza ComponentName
cnfComponent, ByteString
cnfOrigContents :: RenameConfig -> ByteString
cnfOrigContents :: ByteString
cnfOrigContents, ByteString
cnfRenameFrom :: RenameConfig -> ByteString
cnfRenameFrom :: ByteString
cnfRenameFrom, ByteString
cnfRenameTo :: RenameConfig -> ByteString
cnfRenameTo :: ByteString
cnfRenameTo, TargetField
cnfTargetField :: RenameConfig -> TargetField
cnfTargetField :: TargetField
cnfTargetField} = do
  let fieldsWithSource :: [Field ByteString]
fieldsWithSource = ByteString -> [Field Position] -> [Field ByteString]
annotateFieldsWithSource ByteString
cnfOrigContents [Field Position]
cnfFields
      fieldsWithSource' :: [Field ByteString]
fieldsWithSource' = (Field ByteString -> Field ByteString)
-> [Field ByteString] -> [Field ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Field ByteString -> Field ByteString
replaceInSection [Field ByteString]
fieldsWithSource
      newContents :: ByteString
newContents = (Field ByteString -> ByteString)
-> [Field ByteString] -> ByteString
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Field ByteString -> ByteString
forall m. Monoid m => Field m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [Field ByteString]
fieldsWithSource'
  if Either CommonStanza ComponentName -> ByteString -> Bool
validator Either CommonStanza ComponentName
cnfComponent ByteString
newContents then ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
newContents else Maybe ByteString
forall a. Maybe a
Nothing
  where
    replaceInBS :: ByteString -> ByteString
    replaceInBS :: ByteString -> ByteString
replaceInBS ByteString
hay
      | ByteString -> Bool
B.null ByteString
rest =
          ByteString
hay
      | Bool -> Bool
not Bool
startsWithBoundary Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
endsWithBoundary =
          ByteString
pref ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
cnfRenameFrom ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
replaceInBS ByteString
suff
      | Bool
otherwise =
          ByteString
pref ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
cnfRenameTo ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
replaceInBS ByteString
suff
      where
        (ByteString
pref, ByteString
rest) = ByteString -> ByteString -> (ByteString, ByteString)
B.breakSubstring ByteString
cnfRenameFrom ByteString
hay
        suff :: ByteString
suff = Int -> ByteString -> ByteString
B.drop (ByteString -> Int
B.length ByteString
cnfRenameFrom) ByteString
rest
        isTokenBoundary :: Char -> Bool
isTokenBoundary Char
c = (Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
|| Char -> Bool
isPunctuation Char
c Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"^>=<") Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.'
        startsWithBoundary :: Bool
startsWithBoundary = Bool
-> ((ByteString, Char) -> Bool) -> Maybe (ByteString, Char) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Char -> Bool
isTokenBoundary (Char -> Bool)
-> ((ByteString, Char) -> Char) -> (ByteString, Char) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, Char) -> Char
forall a b. (a, b) -> b
snd) (ByteString -> Maybe (ByteString, Char)
B.unsnoc ByteString
pref)
        endsWithBoundary :: Bool
endsWithBoundary = Bool
-> ((Char, ByteString) -> Bool) -> Maybe (Char, ByteString) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Char -> Bool
isTokenBoundary (Char -> Bool)
-> ((Char, ByteString) -> Char) -> (Char, ByteString) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char, ByteString) -> Char
forall a b. (a, b) -> a
fst) (ByteString -> Maybe (Char, ByteString)
B.uncons ByteString
suff)

    replaceInFieldLine :: FieldLine ByteString -> FieldLine ByteString
    replaceInFieldLine :: FieldLine ByteString -> FieldLine ByteString
replaceInFieldLine (FieldLine ByteString
ann ByteString
cnt) = ByteString -> ByteString -> FieldLine ByteString
forall ann. ann -> ByteString -> FieldLine ann
FieldLine (ByteString -> ByteString
replaceInBS ByteString
ann) (ByteString -> ByteString
replaceInBS ByteString
cnt)

    replaceInField :: Field ByteString -> Field ByteString
    replaceInField :: Field ByteString -> Field ByteString
replaceInField = \case
      Field name :: Name ByteString
name@(Name ByteString
_ann ByteString
fieldName) [FieldLine ByteString]
fls
        | ByteString
fieldName ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== TargetField -> ByteString
getTargetName TargetField
cnfTargetField ->
            Name ByteString -> [FieldLine ByteString] -> Field ByteString
forall ann. Name ann -> [FieldLine ann] -> Field ann
Field Name ByteString
name ((FieldLine ByteString -> FieldLine ByteString)
-> [FieldLine ByteString] -> [FieldLine ByteString]
forall a b. (a -> b) -> [a] -> [b]
map FieldLine ByteString -> FieldLine ByteString
replaceInFieldLine [FieldLine ByteString]
fls)
      fld :: Field ByteString
fld@Field {} -> Field ByteString
fld
      Section Name ByteString
name [SectionArg ByteString]
args [Field ByteString]
subFields -> Name ByteString
-> [SectionArg ByteString]
-> [Field ByteString]
-> Field ByteString
forall ann.
Name ann -> [SectionArg ann] -> [Field ann] -> Field ann
Section Name ByteString
name [SectionArg ByteString]
args ((Field ByteString -> Field ByteString)
-> [Field ByteString] -> [Field ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Field ByteString -> Field ByteString
replaceInField [Field ByteString]
subFields)

    replaceInSection :: Field ByteString -> Field ByteString
    replaceInSection :: Field ByteString -> Field ByteString
replaceInSection = \case
      sct :: Field ByteString
sct@(Section Name ByteString
name [SectionArg ByteString]
args [Field ByteString]
subFields) -> Name ByteString
-> [SectionArg ByteString]
-> [Field ByteString]
-> Field ByteString
forall ann.
Name ann -> [SectionArg ann] -> [Field ann] -> Field ann
Section Name ByteString
name [SectionArg ByteString]
args ((Field ByteString -> Field ByteString)
-> [Field ByteString] -> [Field ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Field ByteString -> Field ByteString
func [Field ByteString]
subFields)
        where
          func :: Field ByteString -> Field ByteString
func = case Either CommonStanza ComponentName
-> Field ByteString -> Maybe [Field ByteString]
forall a.
Either CommonStanza ComponentName -> Field a -> Maybe [Field a]
isComponent Either CommonStanza ComponentName
cnfComponent Field ByteString
sct of
            Maybe [Field ByteString]
Nothing -> Field ByteString -> Field ByteString
replaceInSection
            Just {} -> Field ByteString -> Field ByteString
replaceInField
      fld :: Field ByteString
fld@Field {} -> Field ByteString
fld

annotateFieldsWithSource :: ByteString -> [Field Position] -> [Field ByteString]
annotateFieldsWithSource :: ByteString -> [Field Position] -> [Field ByteString]
annotateFieldsWithSource ByteString
bs = (Position, [Field ByteString]) -> [Field ByteString]
forall a b. (a, b) -> b
snd ((Position, [Field ByteString]) -> [Field ByteString])
-> ([Field Position] -> (Position, [Field ByteString]))
-> [Field Position]
-> [Field ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position -> Field Position -> (Position, Field ByteString))
-> Position -> [Field Position] -> (Position, [Field ByteString])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
L.mapAccumR Position -> Field Position -> (Position, Field ByteString)
annotateField Position
maxBoundPos
  where
    annotateField :: Position -> Field Position -> (Position, Field ByteString)
    annotateField :: Position -> Field Position -> (Position, Field ByteString)
annotateField Position
finishPos = \case
      Field (Name Position
pos ByteString
name) [FieldLine Position]
fls -> (Position
pos, Name ByteString -> [FieldLine ByteString] -> Field ByteString
forall ann. Name ann -> [FieldLine ann] -> Field ann
Field (ByteString -> ByteString -> Name ByteString
forall ann. ann -> ByteString -> Name ann
Name (Position -> Position -> ByteString
getSrcBetween Position
pos Position
finishPos') ByteString
name) [FieldLine ByteString]
fls')
        where
          (Position
finishPos', [FieldLine ByteString]
fls') = (Position
 -> FieldLine Position -> (Position, FieldLine ByteString))
-> Position
-> [FieldLine Position]
-> (Position, [FieldLine ByteString])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
L.mapAccumR Position -> FieldLine Position -> (Position, FieldLine ByteString)
annotateFieldLine Position
finishPos [FieldLine Position]
fls
      Section (Name Position
pos ByteString
name) [SectionArg Position]
args [Field Position]
fs -> (Position
pos, Name ByteString
-> [SectionArg ByteString]
-> [Field ByteString]
-> Field ByteString
forall ann.
Name ann -> [SectionArg ann] -> [Field ann] -> Field ann
Section (ByteString -> ByteString -> Name ByteString
forall ann. ann -> ByteString -> Name ann
Name (Position -> Position -> ByteString
getSrcBetween Position
pos Position
finishPos'') ByteString
name) [SectionArg ByteString]
args' [Field ByteString]
fs')
        where
          (Position
finishPos', [Field ByteString]
fs') = (Position -> Field Position -> (Position, Field ByteString))
-> Position -> [Field Position] -> (Position, [Field ByteString])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
L.mapAccumR Position -> Field Position -> (Position, Field ByteString)
annotateField Position
finishPos [Field Position]
fs
          (Position
finishPos'', [SectionArg ByteString]
args') = (Position
 -> SectionArg Position -> (Position, SectionArg ByteString))
-> Position
-> [SectionArg Position]
-> (Position, [SectionArg ByteString])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
L.mapAccumR Position
-> SectionArg Position -> (Position, SectionArg ByteString)
annotateSectionArg Position
finishPos' [SectionArg Position]
args

    annotateFieldLine :: Position -> FieldLine Position -> (Position, FieldLine ByteString)
    annotateFieldLine :: Position -> FieldLine Position -> (Position, FieldLine ByteString)
annotateFieldLine Position
finishPos (FieldLine Position
pos ByteString
xs) = (Position
pos, ByteString -> ByteString -> FieldLine ByteString
forall ann. ann -> ByteString -> FieldLine ann
FieldLine (Position -> Position -> ByteString
getSrcBetween Position
pos Position
finishPos) ByteString
xs)

    annotateSectionArg :: Position -> SectionArg Position -> (Position, SectionArg ByteString)
    annotateSectionArg :: Position
-> SectionArg Position -> (Position, SectionArg ByteString)
annotateSectionArg Position
finishPos = \case
      SecArgName Position
pos ByteString
xs -> (Position
pos, ByteString -> ByteString -> SectionArg ByteString
forall ann. ann -> ByteString -> SectionArg ann
SecArgName (Position -> Position -> ByteString
getSrcBetween Position
pos Position
finishPos) ByteString
xs)
      SecArgStr Position
pos ByteString
xs -> (Position
pos, ByteString -> ByteString -> SectionArg ByteString
forall ann. ann -> ByteString -> SectionArg ann
SecArgStr (Position -> Position -> ByteString
getSrcBetween Position
pos Position
finishPos) ByteString
xs)
      SecArgOther Position
pos ByteString
xs -> (Position
pos, ByteString -> ByteString -> SectionArg ByteString
forall ann. ann -> ByteString -> SectionArg ann
SecArgOther (Position -> Position -> ByteString
getSrcBetween Position
pos Position
finishPos) ByteString
xs)

    getSrcBetween :: Position -> Position -> ByteString
    getSrcBetween :: Position -> Position -> ByteString
getSrcBetween Position
from Position
to = (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> b
snd ((ByteString, ByteString) -> ByteString)
-> (ByteString, ByteString) -> ByteString
forall a b. (a -> b) -> a -> b
$ Position -> ByteString -> (ByteString, ByteString)
splitAtPosition Position
from (ByteString -> (ByteString, ByteString))
-> ByteString -> (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst ((ByteString, ByteString) -> ByteString)
-> (ByteString, ByteString) -> ByteString
forall a b. (a -> b) -> a -> b
$ Position -> ByteString -> (ByteString, ByteString)
splitAtPosition Position
to ByteString
bs

    maxBoundPos :: Position
    maxBoundPos :: Position
maxBoundPos = Int -> Int -> Position
Position Int
forall a. Bounded a => a
maxBound Int
forall a. Bounded a => a
maxBound