-- |
-- 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 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 :: Field CommentsPragmas -> m (Maybe (Field CommentsPragmas))
refactoringFragments Field CommentsPragmas
field = do
    Maybe FilePath
mp <- [FieldPragma] -> m (Maybe FilePath)
forall r (m :: * -> *).
MonadCabalFmt r m =>
[FieldPragma] -> m (Maybe FilePath)
parse (Field CommentsPragmas -> [FieldPragma]
getPragmas Field CommentsPragmas
field)
    case Maybe FilePath
mp of
        Maybe FilePath
Nothing -> Maybe (Field CommentsPragmas) -> m (Maybe (Field CommentsPragmas))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Field CommentsPragmas)
forall a. Maybe a
Nothing
        Just FilePath
p  -> FilePath -> m Contents
forall r (m :: * -> *). MonadCabalFmt r m => FilePath -> m Contents
readFileBS FilePath
p m Contents
-> (Contents -> m (Maybe (Field CommentsPragmas)))
-> m (Maybe (Field CommentsPragmas))
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 (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Field CommentsPragmas)
forall a. Maybe a
Nothing
            IOError FilePath
err -> do
                FilePath -> m ()
forall r (m :: * -> *). MonadCabalFmt r m => FilePath -> m ()
displayWarning (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Fragment " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
p FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" failed to read: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
err
                Maybe (Field CommentsPragmas) -> m (Maybe (Field CommentsPragmas))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Field CommentsPragmas)
forall a. Maybe a
Nothing
            Contents ByteString
c  -> do
                [Field Position]
fields <- ByteString -> m [Field Position]
forall r (m :: * -> *).
MonadCabalFmt r m =>
ByteString -> m [Field Position]
parseFields ByteString
c
                case (Field CommentsPragmas
field, [Field Position]
fields) of
                    (Field CommentsPragmas
_, []) -> do
                        FilePath -> m ()
forall r (m :: * -> *). MonadCabalFmt r m => FilePath -> m ()
displayWarning (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Fragment " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
p FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" is empty."
                        Maybe (Field CommentsPragmas) -> m (Maybe (Field CommentsPragmas))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Field CommentsPragmas)
forall a. Maybe a
Nothing

                    (C.Field (C.Name CommentsPragmas
_ ByteString
n) [FieldLine CommentsPragmas]
_, C.Section name :: Name Position
name@(C.Name Position
_ ByteString
_) [SectionArg Position]
arg [Field Position]
_ : [Field Position]
_) -> do
                        FilePath -> m ()
forall r (m :: * -> *). MonadCabalFmt r m => FilePath -> m ()
displayWarning (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Fragment " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
p FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" contains a section " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Name Position -> [SectionArg Position] -> FilePath
forall ann. Name ann -> [SectionArg ann] -> FilePath
showSection Name Position
name [SectionArg Position]
arg FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
", expecting field " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ByteString -> FilePath
forall a. Show a => a -> FilePath
show ByteString
n FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"."
                        Maybe (Field CommentsPragmas) -> m (Maybe (Field CommentsPragmas))
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
_ ByteString
_) [SectionArg CommentsPragmas]
arg [Field CommentsPragmas]
_, C.Field (C.Name Position
_ ByteString
n') [FieldLine Position]
_ : [Field Position]
_) -> do
                        FilePath -> m ()
forall r (m :: * -> *). MonadCabalFmt r m => FilePath -> m ()
displayWarning (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Fragment " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
p FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" contains a field " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ByteString -> FilePath
forall a. Show a => a -> FilePath
show ByteString
n' FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
", expection section " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Name CommentsPragmas -> [SectionArg CommentsPragmas] -> FilePath
forall ann. Name ann -> [SectionArg ann] -> FilePath
showSection Name CommentsPragmas
name [SectionArg CommentsPragmas]
arg FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"."
                        Maybe (Field CommentsPragmas) -> m (Maybe (Field CommentsPragmas))
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
_ ByteString
n) [FieldLine CommentsPragmas]
_, C.Field (C.Name Position
_ ByteString
n') [FieldLine Position]
fls' : [Field Position]
rest) -> do
                        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Field Position] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Field Position]
rest) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
                            FilePath -> m ()
forall r (m :: * -> *). MonadCabalFmt r m => FilePath -> m ()
displayWarning (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Fragment " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
p FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" contains multiple fields or sections, using only the first."
                        if ByteString
n ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
n'
                        then do
                            -- everything is fine, replace
                            Maybe (Field CommentsPragmas) -> m (Maybe (Field CommentsPragmas))
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
                            FilePath -> m ()
forall r (m :: * -> *). MonadCabalFmt r m => FilePath -> m ()
displayWarning (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Fragment " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
p FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" contains field " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ByteString -> FilePath
forall a. Show a => a -> FilePath
show ByteString
n' FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
", expecting field " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ByteString -> FilePath
forall a. Show a => a -> FilePath
show ByteString
n FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"."
                            Maybe (Field CommentsPragmas) -> m (Maybe (Field CommentsPragmas))
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
_ ByteString
_) [SectionArg CommentsPragmas]
arg [Field CommentsPragmas]
_, C.Section name' :: Name Position
name'@(C.Name Position
_ ByteString
_) [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 (t :: * -> *) a. Foldable t => t a -> Bool
null [Field Position]
rest) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
                            FilePath -> m ()
forall r (m :: * -> *). MonadCabalFmt r m => FilePath -> m ()
displayWarning (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Fragment " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
p FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" 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 (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
                            FilePath -> m ()
forall r (m :: * -> *). MonadCabalFmt r m => FilePath -> m ()
displayWarning (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Fragment " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
p FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" contains a section " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Name CommentsPragmas -> [SectionArg CommentsPragmas] -> FilePath
forall ann. Name ann -> [SectionArg ann] -> FilePath
showSection Name CommentsPragmas
name [SectionArg CommentsPragmas]
arg FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
", expection section " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Name Position -> [SectionArg Position] -> FilePath
forall ann. Name ann -> [SectionArg ann] -> FilePath
showSection Name Position
name' [SectionArg Position]
arg' FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"."
                            Maybe (Field CommentsPragmas) -> m (Maybe (Field CommentsPragmas))
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 :: [f ann] -> [f CommentsPragmas]
noCommentsPragmas = (f ann -> f CommentsPragmas) -> [f ann] -> [f CommentsPragmas]
forall a b. (a -> b) -> [a] -> [b]
map (([ByteString] -> Comments
Comments [], []) CommentsPragmas -> f ann -> f CommentsPragmas
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. (a, b) -> b
snd (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 :: Name ann -> [SectionArg ann] -> FilePath
showSection (C.Name ann
_ ByteString
n) []   = ByteString -> FilePath
forall a. Show a => a -> FilePath
show ByteString
n
    showSection (C.Name ann
_ ByteString
n) [SectionArg ann]
args = FilePath -> FilePath
forall a. Show a => a -> FilePath
show (ByteString -> FilePath
fromUTF8BS ByteString
n FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Doc -> FilePath
render ([Doc] -> Doc
hsep (ByteString -> [SectionArg ann] -> [Doc]
forall ann. ByteString -> [SectionArg ann] -> [Doc]
C.prettySectionArgs ByteString
n [SectionArg ann]
args)))

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