-- |
-- License: GPL-3.0-or-later
-- Copyright: Oleg Grenrus
{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE ScopedTypeVariables        #-}
module CabalFmt.Comments where

import qualified Data.ByteString           as BS
import qualified Data.ByteString.Char8     as BS8
import qualified Data.Map.Strict           as Map
import qualified Distribution.Fields       as C
import qualified Distribution.Fields.Field as C
import qualified Distribution.Parsec       as C

import CabalFmt.Prelude

-------------------------------------------------------------------------------
-- Comments wrapper
-------------------------------------------------------------------------------

newtype Comments = Comments [BS.ByteString]
  deriving stock Int -> Comments -> ShowS
[Comments] -> ShowS
Comments -> String
(Int -> Comments -> ShowS)
-> (Comments -> String) -> ([Comments] -> ShowS) -> Show Comments
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Comments] -> ShowS
$cshowList :: [Comments] -> ShowS
show :: Comments -> String
$cshow :: Comments -> String
showsPrec :: Int -> Comments -> ShowS
$cshowsPrec :: Int -> Comments -> ShowS
Show
  deriving newtype (b -> Comments -> Comments
NonEmpty Comments -> Comments
Comments -> Comments -> Comments
(Comments -> Comments -> Comments)
-> (NonEmpty Comments -> Comments)
-> (forall b. Integral b => b -> Comments -> Comments)
-> Semigroup Comments
forall b. Integral b => b -> Comments -> Comments
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> Comments -> Comments
$cstimes :: forall b. Integral b => b -> Comments -> Comments
sconcat :: NonEmpty Comments -> Comments
$csconcat :: NonEmpty Comments -> Comments
<> :: Comments -> Comments -> Comments
$c<> :: Comments -> Comments -> Comments
Semigroup, Semigroup Comments
Comments
Semigroup Comments
-> Comments
-> (Comments -> Comments -> Comments)
-> ([Comments] -> Comments)
-> Monoid Comments
[Comments] -> Comments
Comments -> Comments -> Comments
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Comments] -> Comments
$cmconcat :: [Comments] -> Comments
mappend :: Comments -> Comments -> Comments
$cmappend :: Comments -> Comments -> Comments
mempty :: Comments
$cmempty :: Comments
$cp1Monoid :: Semigroup Comments
Monoid)

unComments :: Comments -> [BS.ByteString]
unComments :: Comments -> [ByteString]
unComments (Comments [ByteString]
cs) = [ByteString]
cs

nullComments :: Comments -> Bool
nullComments :: Comments -> Bool
nullComments (Comments [ByteString]
cs) = [ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
cs

-------------------------------------------------------------------------------
-- Attach comments
-------------------------------------------------------------------------------

-- | Returns a 'C.Field' forest with comments attached.
--
-- * Comments are attached to the field after it.
-- * A glitch: comments "inside" the field are attached to the field after it.
-- * End-of-file comments are returned separately.
--
attachComments
    :: BS.ByteString        -- ^ source with comments
    -> [C.Field C.Position] -- ^ parsed source fields
    -> ([C.Field Comments], Comments)
attachComments :: ByteString -> [Field Position] -> ([Field Comments], Comments)
attachComments ByteString
input [Field Position]
inputFields =
    ((FieldPath -> Position -> Comments)
-> [Field Position] -> [Field Comments]
forall a b. (FieldPath -> a -> b) -> [Field a] -> [Field b]
overAnn FieldPath -> Position -> Comments
attach [Field Position]
inputFields, Comments
endComments)
  where
    inputFieldsU :: [(FieldPath, C.Field C.Position)]
    inputFieldsU :: [(FieldPath, Field Position)]
inputFieldsU = [Field Position] -> [(FieldPath, Field Position)]
forall ann. [Field ann] -> [(FieldPath, Field ann)]
fieldUniverseN [Field Position]
inputFields

    comments :: [(Int, Comments)]
    comments :: [(Int, Comments)]
comments = ByteString -> [(Int, Comments)]
extractComments ByteString
input

    comments' :: Map.Map FieldPath Comments
    comments' :: Map FieldPath Comments
comments' = (Comments -> Comments -> Comments)
-> [(FieldPath, Comments)] -> Map FieldPath Comments
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith ((Comments -> Comments -> Comments)
-> Comments -> Comments -> Comments
forall a b c. (a -> b -> c) -> b -> a -> c
flip Comments -> Comments -> Comments
forall a. Semigroup a => a -> a -> a
(<>))
        [ (FieldPath
path, Comments
cs)
        | (Int
l, Comments
cs) <- [(Int, Comments)]
comments
        , FieldPath
path <- Maybe FieldPath -> [FieldPath]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ((Field Position -> Position)
-> Int -> [(FieldPath, Field Position)] -> Maybe FieldPath
forall a.
(a -> Position) -> Int -> [(FieldPath, a)] -> Maybe FieldPath
findPath Field Position -> Position
forall ann. Field ann -> ann
C.fieldAnn Int
l [(FieldPath, Field Position)]
inputFieldsU)
        ]

    endComments :: Comments
    endComments :: Comments
endComments = [Comments] -> Comments
forall a. Monoid a => [a] -> a
mconcat
        [ Comments
cs
        | (Int
l, Comments
cs) <- [(Int, Comments)]
comments
        , Maybe FieldPath -> Bool
forall a. Maybe a -> Bool
isNothing ((Field Position -> Position)
-> Int -> [(FieldPath, Field Position)] -> Maybe FieldPath
forall a.
(a -> Position) -> Int -> [(FieldPath, a)] -> Maybe FieldPath
findPath Field Position -> Position
forall ann. Field ann -> ann
C.fieldAnn Int
l [(FieldPath, Field Position)]
inputFieldsU)
        ]

    attach :: FieldPath -> C.Position -> Comments
    attach :: FieldPath -> Position -> Comments
attach FieldPath
fp Position
_pos = Comments -> Maybe Comments -> Comments
forall a. a -> Maybe a -> a
fromMaybe Comments
forall a. Monoid a => a
mempty (FieldPath -> Map FieldPath Comments -> Maybe Comments
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FieldPath
fp Map FieldPath Comments
comments')

overAnn :: forall a b. (FieldPath -> a -> b) -> [C.Field a] -> [C.Field b]
overAnn :: (FieldPath -> a -> b) -> [Field a] -> [Field b]
overAnn FieldPath -> a -> b
f = (FieldPath -> FieldPath) -> [Field a] -> [Field b]
go' FieldPath -> FieldPath
forall a. a -> a
id where
    go :: (FieldPath -> FieldPath) -> Int -> C.Field a -> C.Field b
    go :: (FieldPath -> FieldPath) -> Int -> Field a -> Field b
go FieldPath -> FieldPath
g Int
i (C.Field (C.Name a
a ByteString
name) [FieldLine a]
fls) =
        Name b -> [FieldLine b] -> Field b
forall ann. Name ann -> [FieldLine ann] -> Field ann
C.Field (b -> ByteString -> Name b
forall ann. ann -> ByteString -> Name ann
C.Name b
b ByteString
name) (b
b b -> [FieldLine a] -> [FieldLine b]
forall (f :: * -> *) (g :: * -> *) x y.
(Functor f, Functor g) =>
x -> f (g y) -> f (g x)
<$$ [FieldLine a]
fls)
      where
        b :: b
b = FieldPath -> a -> b
f (FieldPath -> FieldPath
g (Int -> FieldPath -> FieldPath
Nth Int
i FieldPath
End)) a
a

    go FieldPath -> FieldPath
g Int
i (C.Section (C.Name a
a ByteString
name) [SectionArg a]
args [Field a]
fls) =
        Name b -> [SectionArg b] -> [Field b] -> Field b
forall ann.
Name ann -> [SectionArg ann] -> [Field ann] -> Field ann
C.Section (b -> ByteString -> Name b
forall ann. ann -> ByteString -> Name ann
C.Name b
b ByteString
name) (b
b b -> [SectionArg a] -> [SectionArg b]
forall (f :: * -> *) (g :: * -> *) x y.
(Functor f, Functor g) =>
x -> f (g y) -> f (g x)
<$$ [SectionArg a]
args) ((FieldPath -> FieldPath) -> [Field a] -> [Field b]
go' (FieldPath -> FieldPath
g (FieldPath -> FieldPath)
-> (FieldPath -> FieldPath) -> FieldPath -> FieldPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> FieldPath -> FieldPath
Nth Int
i) [Field a]
fls)
      where
        b :: b
b = FieldPath -> a -> b
f (FieldPath -> FieldPath
g (Int -> FieldPath -> FieldPath
Nth Int
i FieldPath
End)) a
a

    go' :: (FieldPath -> FieldPath) -> [C.Field a] -> [C.Field b]
    go' :: (FieldPath -> FieldPath) -> [Field a] -> [Field b]
go' FieldPath -> FieldPath
g [Field a]
xs = (Int -> Field a -> Field b) -> [Int] -> [Field a] -> [Field b]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((FieldPath -> FieldPath) -> Int -> Field a -> Field b
go FieldPath -> FieldPath
g) [Int
0..] [Field a]
xs

    (<$$) :: (Functor f, Functor g) => x -> f (g y) -> f (g x)
    x
x <$$ :: x -> f (g y) -> f (g x)
<$$ f (g y)
y = (x
x x -> g y -> g x
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) (g y -> g x) -> f (g y) -> f (g x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (g y)
y

-------------------------------------------------------------------------------
-- Find comments in the input
-------------------------------------------------------------------------------

extractComments :: BS.ByteString -> [(Int, Comments)]
extractComments :: ByteString -> [(Int, Comments)]
extractComments = [(Int, ByteString)] -> [(Int, Comments)]
go ([(Int, ByteString)] -> [(Int, Comments)])
-> (ByteString -> [(Int, ByteString)])
-> ByteString
-> [(Int, Comments)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [ByteString] -> [(Int, ByteString)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] ([ByteString] -> [(Int, ByteString)])
-> (ByteString -> [ByteString])
-> ByteString
-> [(Int, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map ((Word8 -> Bool) -> ByteString -> ByteString
BS.dropWhile Word8 -> Bool
forall a. (Eq a, Num a) => a -> Bool
isSpace8) ([ByteString] -> [ByteString])
-> (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
BS8.lines where
    go :: [(Int, BS.ByteString)] -> [(Int, Comments)]
    go :: [(Int, ByteString)] -> [(Int, Comments)]
go [] = []
    go ((Int
n, ByteString
bs) : [(Int, ByteString)]
rest)
        | ByteString -> Bool
isComment ByteString
bs = case ((Int, ByteString) -> Bool)
-> [(Int, ByteString)]
-> ([(Int, ByteString)], [(Int, ByteString)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((ByteString -> Bool
isComment (ByteString -> Bool) -> (ByteString -> Bool) -> ByteString -> Bool
forall t. (t -> Bool) -> (t -> Bool) -> t -> Bool
.|| ByteString -> Bool
BS.null) (ByteString -> Bool)
-> ((Int, ByteString) -> ByteString) -> (Int, ByteString) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, ByteString) -> ByteString
forall a b. (a, b) -> b
snd) [(Int, ByteString)]
rest of
            ([(Int, ByteString)]
h,[(Int, ByteString)]
t) -> (Int
n, [ByteString] -> Comments
Comments ([ByteString] -> Comments) -> [ByteString] -> Comments
forall a b. (a -> b) -> a -> b
$ ByteString
bs ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: ((Int, ByteString) -> ByteString)
-> [(Int, ByteString)] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (Int, ByteString) -> ByteString
forall a b. (a, b) -> b
snd [(Int, ByteString)]
h) (Int, Comments) -> [(Int, Comments)] -> [(Int, Comments)]
forall a. a -> [a] -> [a]
: [(Int, ByteString)] -> [(Int, Comments)]
go [(Int, ByteString)]
t
        | Bool
otherwise = [(Int, ByteString)] -> [(Int, Comments)]
go [(Int, ByteString)]
rest

    (t -> Bool
f .|| :: (t -> Bool) -> (t -> Bool) -> t -> Bool
.|| t -> Bool
g) t
x = t -> Bool
f t
x Bool -> Bool -> Bool
|| t -> Bool
g t
x

    isSpace8 :: a -> Bool
isSpace8 a
w = a
w a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
9 Bool -> Bool -> Bool
|| a
w a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
32

    isComment :: BS.ByteString -> Bool
    isComment :: ByteString -> Bool
isComment = ByteString -> ByteString -> Bool
BS.isPrefixOf ByteString
"--"

-------------------------------------------------------------------------------
-- FieldPath
-------------------------------------------------------------------------------

-- | Paths input paths. Essentially a list of offsets. Own type ofr safety.
data FieldPath
    = End
    | Nth Int FieldPath -- nth field
  deriving (FieldPath -> FieldPath -> Bool
(FieldPath -> FieldPath -> Bool)
-> (FieldPath -> FieldPath -> Bool) -> Eq FieldPath
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FieldPath -> FieldPath -> Bool
$c/= :: FieldPath -> FieldPath -> Bool
== :: FieldPath -> FieldPath -> Bool
$c== :: FieldPath -> FieldPath -> Bool
Eq, Eq FieldPath
Eq FieldPath
-> (FieldPath -> FieldPath -> Ordering)
-> (FieldPath -> FieldPath -> Bool)
-> (FieldPath -> FieldPath -> Bool)
-> (FieldPath -> FieldPath -> Bool)
-> (FieldPath -> FieldPath -> Bool)
-> (FieldPath -> FieldPath -> FieldPath)
-> (FieldPath -> FieldPath -> FieldPath)
-> Ord FieldPath
FieldPath -> FieldPath -> Bool
FieldPath -> FieldPath -> Ordering
FieldPath -> FieldPath -> FieldPath
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: FieldPath -> FieldPath -> FieldPath
$cmin :: FieldPath -> FieldPath -> FieldPath
max :: FieldPath -> FieldPath -> FieldPath
$cmax :: FieldPath -> FieldPath -> FieldPath
>= :: FieldPath -> FieldPath -> Bool
$c>= :: FieldPath -> FieldPath -> Bool
> :: FieldPath -> FieldPath -> Bool
$c> :: FieldPath -> FieldPath -> Bool
<= :: FieldPath -> FieldPath -> Bool
$c<= :: FieldPath -> FieldPath -> Bool
< :: FieldPath -> FieldPath -> Bool
$c< :: FieldPath -> FieldPath -> Bool
compare :: FieldPath -> FieldPath -> Ordering
$ccompare :: FieldPath -> FieldPath -> Ordering
$cp1Ord :: Eq FieldPath
Ord, Int -> FieldPath -> ShowS
[FieldPath] -> ShowS
FieldPath -> String
(Int -> FieldPath -> ShowS)
-> (FieldPath -> String)
-> ([FieldPath] -> ShowS)
-> Show FieldPath
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FieldPath] -> ShowS
$cshowList :: [FieldPath] -> ShowS
show :: FieldPath -> String
$cshow :: FieldPath -> String
showsPrec :: Int -> FieldPath -> ShowS
$cshowsPrec :: Int -> FieldPath -> ShowS
Show)

fieldPathSize :: FieldPath -> Int
fieldPathSize :: FieldPath -> Int
fieldPathSize = Int -> FieldPath -> Int
forall t. Enum t => t -> FieldPath -> t
go Int
0 where
    go :: t -> FieldPath -> t
go !t
acc FieldPath
End = t
acc
    go !t
acc (Nth Int
_ FieldPath
fp) = t -> FieldPath -> t
go (t -> t
forall a. Enum a => a -> a
succ t
acc) FieldPath
fp

fieldUniverseN :: [C.Field ann] -> [(FieldPath, C.Field ann)]
fieldUniverseN :: [Field ann] -> [(FieldPath, Field ann)]
fieldUniverseN = [[(FieldPath, Field ann)]] -> [(FieldPath, Field ann)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(FieldPath, Field ann)]] -> [(FieldPath, Field ann)])
-> ([Field ann] -> [[(FieldPath, Field ann)]])
-> [Field ann]
-> [(FieldPath, Field ann)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Field ann -> [(FieldPath, Field ann)])
-> [Int] -> [Field ann] -> [[(FieldPath, Field ann)]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Field ann -> [(FieldPath, Field ann)]
forall ann. Int -> Field ann -> [(FieldPath, Field ann)]
g [Int
0..] where
    g :: Int -> Field ann -> [(FieldPath, Field ann)]
g Int
n Field ann
f' = [ (Int -> FieldPath -> FieldPath
Nth Int
n FieldPath
p, Field ann
f'') | (FieldPath
p, Field ann
f'') <- Field ann -> [(FieldPath, Field ann)]
forall ann. Field ann -> [(FieldPath, Field ann)]
fieldUniverse Field ann
f' ]

fieldUniverse :: C.Field ann -> [(FieldPath, C.Field ann)]
fieldUniverse :: Field ann -> [(FieldPath, Field ann)]
fieldUniverse f :: Field ann
f@(C.Section Name ann
_ [SectionArg ann]
_ [Field ann]
fs) = (FieldPath
End,Field ann
f) (FieldPath, Field ann)
-> [(FieldPath, Field ann)] -> [(FieldPath, Field ann)]
forall a. a -> [a] -> [a]
: [[(FieldPath, Field ann)]] -> [(FieldPath, Field ann)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((Int -> Field ann -> [(FieldPath, Field ann)])
-> [Int] -> [Field ann] -> [[(FieldPath, Field ann)]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Field ann -> [(FieldPath, Field ann)]
forall ann. Int -> Field ann -> [(FieldPath, Field ann)]
g [Int
0..] [Field ann]
fs) where
    g :: Int -> Field ann -> [(FieldPath, Field ann)]
g Int
n Field ann
f' = [ (Int -> FieldPath -> FieldPath
Nth Int
n FieldPath
p, Field ann
f'') | (FieldPath
p, Field ann
f'') <- Field ann -> [(FieldPath, Field ann)]
forall ann. Field ann -> [(FieldPath, Field ann)]
fieldUniverse Field ann
f' ]
fieldUniverse f :: Field ann
f@(C.Field Name ann
_ [FieldLine ann]
_)      = [(FieldPath
End, Field ann
f)]

-- note: fieldUniverse* should produce 'FieldPath's in increasing order
-- that helps
findPath :: (a -> C.Position) -> Int -> [(FieldPath, a)] -> Maybe FieldPath
findPath :: (a -> Position) -> Int -> [(FieldPath, a)] -> Maybe FieldPath
findPath a -> Position
_ Int
_ [] = Maybe FieldPath
forall a. Maybe a
Nothing
findPath a -> Position
f Int
l [(FieldPath
p, a
x)]
    | C.Position Int
k Int
_ <- a -> Position
f a
x =
        if Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
k then FieldPath -> Maybe FieldPath
forall a. a -> Maybe a
Just FieldPath
p else Maybe FieldPath
forall a. Maybe a
Nothing
findPath a -> Position
f Int
l ((FieldPath
_, a
x) : rest :: [(FieldPath, a)]
rest@((FieldPath
p, a
x') : [(FieldPath, a)]
_))
    | C.Position Int
k  Int
_ <- a -> Position
f a
x
    , C.Position Int
k' Int
_ <- a -> Position
f a
x' =
        if Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
l Bool -> Bool -> Bool
&& Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
k'
        then FieldPath -> Maybe FieldPath
forall a. a -> Maybe a
Just FieldPath
p
        else (a -> Position) -> Int -> [(FieldPath, a)] -> Maybe FieldPath
forall a.
(a -> Position) -> Int -> [(FieldPath, a)] -> Maybe FieldPath
findPath a -> Position
f Int
l [(FieldPath, a)]
rest