-- |
-- License: GPL-3.0-or-later
-- Copyright: Oleg Grenrus
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes        #-}
module CabalFmt.Refactoring.Fragments (
    refactoringFragments,
    ) where

import Text.PrettyPrint (hsep, render)

import qualified Distribution.Fields        as C
import qualified Distribution.Fields.Field  as C
import qualified Distribution.Fields.Pretty as C
import qualified Distribution.Parsec        as C

import CabalFmt.Comments
import CabalFmt.Monad
import CabalFmt.Parser
import CabalFmt.Pragma
import CabalFmt.Prelude
import CabalFmt.Refactoring.Type

-- | Expand fragments.
--
-- Applies to all fields and sections
refactoringFragments :: FieldRefactoring
refactoringFragments :: FieldRefactoring
refactoringFragments Field CommentsPragmas
field = do
    Maybe [Char]
mp <- [FieldPragma] -> m (Maybe [Char])
forall r (m :: * -> *).
MonadCabalFmt r m =>
[FieldPragma] -> m (Maybe [Char])
parse (Field CommentsPragmas -> [FieldPragma]
getPragmas Field CommentsPragmas
field)
    case Maybe [Char]
mp of
        Maybe [Char]
Nothing -> Maybe (Field CommentsPragmas) -> m (Maybe (Field CommentsPragmas))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Field CommentsPragmas)
forall a. Maybe a
Nothing
        Just [Char]
p  -> [Char] -> m Contents
forall r (m :: * -> *). MonadCabalFmt r m => [Char] -> m Contents
readFileBS [Char]
p m Contents
-> (Contents -> m (Maybe (Field CommentsPragmas)))
-> m (Maybe (Field CommentsPragmas))
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Contents
mcontents -> case Contents
mcontents of
            Contents
NoIO -> Maybe (Field CommentsPragmas) -> m (Maybe (Field CommentsPragmas))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Field CommentsPragmas)
forall a. Maybe a
Nothing
            IOError [Char]
err -> do
                [Char] -> m ()
forall r (m :: * -> *). MonadCabalFmt r m => [Char] -> m ()
displayWarning ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Fragment " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
p [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" failed to read: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
err
                Maybe (Field CommentsPragmas) -> m (Maybe (Field CommentsPragmas))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Field CommentsPragmas)
forall a. Maybe a
Nothing
            Contents FieldName
c  -> do
                [Field Position]
fields <- FieldName -> m [Field Position]
forall r (m :: * -> *).
MonadCabalFmt r m =>
FieldName -> m [Field Position]
parseFields FieldName
c
                case (Field CommentsPragmas
field, [Field Position]
fields) of
                    (Field CommentsPragmas
_, []) -> do
                        [Char] -> m ()
forall r (m :: * -> *). MonadCabalFmt r m => [Char] -> m ()
displayWarning ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Fragment " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
p [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is empty."
                        Maybe (Field CommentsPragmas) -> m (Maybe (Field CommentsPragmas))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Field CommentsPragmas)
forall a. Maybe a
Nothing

                    (C.Field (C.Name CommentsPragmas
_ FieldName
n) [FieldLine CommentsPragmas]
_, C.Section name :: Name Position
name@(C.Name Position
_ FieldName
_) [SectionArg Position]
arg [Field Position]
_ : [Field Position]
_) -> do
                        [Char] -> m ()
forall r (m :: * -> *). MonadCabalFmt r m => [Char] -> m ()
displayWarning ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Fragment " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
p [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" contains a section " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name Position -> [SectionArg Position] -> [Char]
forall ann. Name ann -> [SectionArg ann] -> [Char]
showSection Name Position
name [SectionArg Position]
arg [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", expecting field " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ FieldName -> [Char]
forall a. Show a => a -> [Char]
show FieldName
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"."
                        Maybe (Field CommentsPragmas) -> m (Maybe (Field CommentsPragmas))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Field CommentsPragmas)
forall a. Maybe a
Nothing
                    (C.Section name :: Name CommentsPragmas
name@(C.Name CommentsPragmas
_ FieldName
_) [SectionArg CommentsPragmas]
arg [Field CommentsPragmas]
_, C.Field (C.Name Position
_ FieldName
n') [FieldLine Position]
_ : [Field Position]
_) -> do
                        [Char] -> m ()
forall r (m :: * -> *). MonadCabalFmt r m => [Char] -> m ()
displayWarning ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Fragment " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
p [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" contains a field " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ FieldName -> [Char]
forall a. Show a => a -> [Char]
show FieldName
n' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", expecting section " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name CommentsPragmas -> [SectionArg CommentsPragmas] -> [Char]
forall ann. Name ann -> [SectionArg ann] -> [Char]
showSection Name CommentsPragmas
name [SectionArg CommentsPragmas]
arg [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"."
                        Maybe (Field CommentsPragmas) -> m (Maybe (Field CommentsPragmas))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Field CommentsPragmas)
forall a. Maybe a
Nothing

                    (C.Field name :: Name CommentsPragmas
name@(C.Name CommentsPragmas
_ FieldName
n) [FieldLine CommentsPragmas]
_, C.Field (C.Name Position
_ FieldName
n') [FieldLine Position]
fls' : [Field Position]
rest) -> do
                        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Field Position] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Field Position]
rest) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
                            [Char] -> m ()
forall r (m :: * -> *). MonadCabalFmt r m => [Char] -> m ()
displayWarning ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Fragment " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
p [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" contains multiple fields or sections, using only the first."
                        if FieldName
n FieldName -> FieldName -> Bool
forall a. Eq a => a -> a -> Bool
== FieldName
n'
                        then do
                            -- everything is fine, replace
                            Maybe (Field CommentsPragmas) -> m (Maybe (Field CommentsPragmas))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Field CommentsPragmas -> Maybe (Field CommentsPragmas)
forall a. a -> Maybe a
Just (Name CommentsPragmas
-> [FieldLine CommentsPragmas] -> Field CommentsPragmas
forall ann. Name ann -> [FieldLine ann] -> Field ann
C.Field Name CommentsPragmas
name ([FieldLine Position] -> [FieldLine CommentsPragmas]
forall (f :: * -> *) ann.
Functor f =>
[f ann] -> [f CommentsPragmas]
noCommentsPragmas [FieldLine Position]
fls')))
                        else do
                            [Char] -> m ()
forall r (m :: * -> *). MonadCabalFmt r m => [Char] -> m ()
displayWarning ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Fragment " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
p [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" contains field " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ FieldName -> [Char]
forall a. Show a => a -> [Char]
show FieldName
n' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", expecting field " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ FieldName -> [Char]
forall a. Show a => a -> [Char]
show FieldName
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"."
                            Maybe (Field CommentsPragmas) -> m (Maybe (Field CommentsPragmas))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Field CommentsPragmas)
forall a. Maybe a
Nothing

                    (C.Section name :: Name CommentsPragmas
name@(C.Name CommentsPragmas
_ FieldName
_) [SectionArg CommentsPragmas]
arg [Field CommentsPragmas]
_, C.Section name' :: Name Position
name'@(C.Name Position
_ FieldName
_) [SectionArg Position]
arg' [Field Position]
fs' : [Field Position]
rest) -> do
                        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Field Position] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Field Position]
rest) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
                            [Char] -> m ()
forall r (m :: * -> *). MonadCabalFmt r m => [Char] -> m ()
displayWarning ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Fragment " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
p [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" contains multiple fields or sections, using only the first."

                        if (Name CommentsPragmas -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Name CommentsPragmas
name Name () -> Name () -> Bool
forall a. Eq a => a -> a -> Bool
== Name Position -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Name Position
name' Bool -> Bool -> Bool
&& (SectionArg CommentsPragmas -> SectionArg ())
-> [SectionArg CommentsPragmas] -> [SectionArg ()]
forall a b. (a -> b) -> [a] -> [b]
map SectionArg CommentsPragmas -> SectionArg ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void [SectionArg CommentsPragmas]
arg [SectionArg ()] -> [SectionArg ()] -> Bool
forall a. Eq a => a -> a -> Bool
== (SectionArg Position -> SectionArg ())
-> [SectionArg Position] -> [SectionArg ()]
forall a b. (a -> b) -> [a] -> [b]
map SectionArg Position -> SectionArg ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void [SectionArg Position]
arg')
                        then do
                            Maybe (Field CommentsPragmas) -> m (Maybe (Field CommentsPragmas))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Field CommentsPragmas -> Maybe (Field CommentsPragmas)
forall a. a -> Maybe a
Just (Name CommentsPragmas
-> [SectionArg CommentsPragmas]
-> [Field CommentsPragmas]
-> Field CommentsPragmas
forall ann.
Name ann -> [SectionArg ann] -> [Field ann] -> Field ann
C.Section Name CommentsPragmas
name [SectionArg CommentsPragmas]
arg ([Field Position] -> [Field CommentsPragmas]
forall (f :: * -> *) ann.
Functor f =>
[f ann] -> [f CommentsPragmas]
noCommentsPragmas [Field Position]
fs')))
                        else do
                            [Char] -> m ()
forall r (m :: * -> *). MonadCabalFmt r m => [Char] -> m ()
displayWarning ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Fragment " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
p [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" contains a section " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name CommentsPragmas -> [SectionArg CommentsPragmas] -> [Char]
forall ann. Name ann -> [SectionArg ann] -> [Char]
showSection Name CommentsPragmas
name [SectionArg CommentsPragmas]
arg [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", expecting section " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name Position -> [SectionArg Position] -> [Char]
forall ann. Name ann -> [SectionArg ann] -> [Char]
showSection Name Position
name' [SectionArg Position]
arg' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"."
                            Maybe (Field CommentsPragmas) -> m (Maybe (Field CommentsPragmas))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Field CommentsPragmas)
forall a. Maybe a
Nothing
  where
    noCommentsPragmas :: Functor f => [f ann] -> [f CommentsPragmas]
    noCommentsPragmas :: forall (f :: * -> *) ann.
Functor f =>
[f ann] -> [f CommentsPragmas]
noCommentsPragmas = (f ann -> f CommentsPragmas) -> [f ann] -> [f CommentsPragmas]
forall a b. (a -> b) -> [a] -> [b]
map ((Position
C.zeroPos, [FieldName] -> Comments
Comments [], []) CommentsPragmas -> f ann -> f CommentsPragmas
forall a b. a -> f b -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$)

    getPragmas :: C.Field CommentsPragmas -> [FieldPragma]
    getPragmas :: Field CommentsPragmas -> [FieldPragma]
getPragmas = CommentsPragmas -> [FieldPragma]
forall a b c. (a, b, c) -> c
trdOf3 (CommentsPragmas -> [FieldPragma])
-> (Field CommentsPragmas -> CommentsPragmas)
-> Field CommentsPragmas
-> [FieldPragma]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field CommentsPragmas -> CommentsPragmas
forall ann. Field ann -> ann
C.fieldAnn

    showSection :: C.Name ann -> [C.SectionArg ann] -> String
    showSection :: forall ann. Name ann -> [SectionArg ann] -> [Char]
showSection (C.Name ann
_ FieldName
n) []   = FieldName -> [Char]
forall a. Show a => a -> [Char]
show FieldName
n
    showSection (C.Name ann
_ FieldName
n) [SectionArg ann]
args = [Char] -> [Char]
forall a. Show a => a -> [Char]
show (FieldName -> [Char]
fromUTF8BS FieldName
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Doc -> [Char]
render ([Doc] -> Doc
hsep (FieldName -> [SectionArg ann] -> [Doc]
forall ann. FieldName -> [SectionArg ann] -> [Doc]
C.prettySectionArgs FieldName
n [SectionArg ann]
args)))

    parse :: MonadCabalFmt r m => [FieldPragma] -> m (Maybe FilePath)
    parse :: forall r (m :: * -> *).
MonadCabalFmt r m =>
[FieldPragma] -> m (Maybe [Char])
parse = ([Maybe [Char]] -> Maybe [Char])
-> m [Maybe [Char]] -> m (Maybe [Char])
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe [Char]] -> Maybe [Char]
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum (m [Maybe [Char]] -> m (Maybe [Char]))
-> ([FieldPragma] -> m [Maybe [Char]])
-> [FieldPragma]
-> m (Maybe [Char])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldPragma -> m (Maybe [Char]))
-> [FieldPragma] -> m [Maybe [Char]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse FieldPragma -> m (Maybe [Char])
forall {m :: * -> *}. Monad m => FieldPragma -> m (Maybe [Char])
go where
        go :: FieldPragma -> m (Maybe [Char])
go (PragmaFragment [Char]
f) = Maybe [Char] -> m (Maybe [Char])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
f)
        go FieldPragma
_                  = Maybe [Char] -> m (Maybe [Char])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Char]
forall a. Maybe a
Nothing