-- |
-- 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
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 (NonEmpty Comments -> Comments
Comments -> Comments -> 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 :: forall b. Integral b => 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
[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
Monoid)

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

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

    endComments :: Comments
    endComments :: Comments
endComments = forall a. Monoid a => [a] -> a
mconcat
        [ Comments
cs
        | (Int
l, Comments
cs) <- [(Int, Comments)]
comments
        , forall a. Maybe a -> Bool
isNothing (forall a.
(a -> Position) -> Int -> [(FieldPath, a)] -> Maybe FieldPath
findPath 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 = forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty (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 :: forall a b. (FieldPath -> a -> b) -> [Field a] -> [Field b]
overAnn FieldPath -> a -> b
f = (FieldPath -> FieldPath) -> [Field a] -> [Field b]
go' 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) =
        forall ann. Name ann -> [FieldLine ann] -> Field ann
C.Field (forall ann. ann -> ByteString -> Name ann
C.Name b
b ByteString
name) (b
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) =
        forall ann.
Name ann -> [SectionArg ann] -> [Field ann] -> Field ann
C.Section (forall ann. ann -> ByteString -> Name ann
C.Name b
b ByteString
name) (b
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 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 = 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 <$$ :: forall (f :: * -> *) (g :: * -> *) x y.
(Functor f, Functor g) =>
x -> f (g y) -> f (g x)
<$$ f (g y)
y = (x
x forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ((Word8 -> Bool) -> ByteString -> ByteString
BS.dropWhile forall {a}. (Eq a, Num a) => a -> Bool
isSpace8) 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 forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((ByteString -> Bool
isComment forall {t}. (t -> Bool) -> (t -> Bool) -> t -> Bool
.|| ByteString -> Bool
BS.null) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Int, ByteString)]
rest of
            ([(Int, ByteString)]
h,[(Int, ByteString)]
t) -> (Int
n, [ByteString] -> Comments
Comments forall a b. (a -> b) -> a -> b
$ ByteString
bs forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Int, ByteString)]
h) 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 forall a. Eq a => a -> a -> Bool
== a
9 Bool -> Bool -> Bool
|| a
w 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
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
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
Ord, Int -> FieldPath -> ShowS
[FieldPath] -> ShowS
FieldPath -> String
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 = 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 (forall a. Enum a => a -> a
succ t
acc) FieldPath
fp

fieldUniverseN :: [C.Field ann] -> [(FieldPath, C.Field ann)]
fieldUniverseN :: forall ann. [Field ann] -> [(FieldPath, Field ann)]
fieldUniverseN = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith 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'') <- forall ann. Field ann -> [(FieldPath, Field ann)]
fieldUniverse Field ann
f' ]

fieldUniverse :: C.Field ann -> [(FieldPath, C.Field ann)]
fieldUniverse :: forall ann. Field ann -> [(FieldPath, Field ann)]
fieldUniverse f :: Field ann
f@(C.Section Name ann
_ [SectionArg ann]
_ [Field ann]
fs) = (FieldPath
End,Field ann
f) forall a. a -> [a] -> [a]
: forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith 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'') <- 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 :: forall a.
(a -> Position) -> Int -> [(FieldPath, a)] -> Maybe FieldPath
findPath a -> Position
_ Int
_ [] = 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 forall a. Ord a => a -> a -> Bool
< Int
k then forall a. a -> Maybe a
Just FieldPath
p else 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 forall a. Ord a => a -> a -> Bool
< Int
l Bool -> Bool -> Bool
&& Int
l forall a. Ord a => a -> a -> Bool
< Int
k'
        then forall a. a -> Maybe a
Just FieldPath
p
        else forall a.
(a -> Position) -> Int -> [(FieldPath, a)] -> Maybe FieldPath
findPath a -> Position
f Int
l [(FieldPath, a)]
rest