-- |
-- 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 :: FieldRefactoring
refactoringFragments Field CommentsPragmas
field = do
    Maybe [Char]
mp <- 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        Just [Char]
p  -> forall r (m :: * -> *). MonadCabalFmt r m => [Char] -> m Contents
readFileBS [Char]
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Contents
mcontents -> case Contents
mcontents of
            Contents
NoIO -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            IOError [Char]
err -> do
                forall r (m :: * -> *). MonadCabalFmt r m => [Char] -> m ()
displayWarning forall a b. (a -> b) -> a -> b
$ [Char]
"Fragment " forall a. [a] -> [a] -> [a]
++ [Char]
p forall a. [a] -> [a] -> [a]
++ [Char]
" failed to read: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
err
                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            Contents FieldName
c  -> do
                [Field Position]
fields <- forall r (m :: * -> *).
MonadCabalFmt r m =>
FieldName -> m [Field Position]
parseFields FieldName
c
                case (Field CommentsPragmas
field, [Field Position]
fields) of
                    (Field CommentsPragmas
_, []) -> do
                        forall r (m :: * -> *). MonadCabalFmt r m => [Char] -> m ()
displayWarning forall a b. (a -> b) -> a -> b
$ [Char]
"Fragment " forall a. [a] -> [a] -> [a]
++ [Char]
p forall a. [a] -> [a] -> [a]
++ [Char]
" is empty."
                        forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
                        forall r (m :: * -> *). MonadCabalFmt r m => [Char] -> m ()
displayWarning forall a b. (a -> b) -> a -> b
$ [Char]
"Fragment " forall a. [a] -> [a] -> [a]
++ [Char]
p forall a. [a] -> [a] -> [a]
++ [Char]
" contains a section " forall a. [a] -> [a] -> [a]
++ forall ann. Name ann -> [SectionArg ann] -> [Char]
showSection Name Position
name [SectionArg Position]
arg forall a. [a] -> [a] -> [a]
++ [Char]
", expecting field " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show FieldName
n forall a. [a] -> [a] -> [a]
++ [Char]
"."
                        forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
                        forall r (m :: * -> *). MonadCabalFmt r m => [Char] -> m ()
displayWarning forall a b. (a -> b) -> a -> b
$ [Char]
"Fragment " forall a. [a] -> [a] -> [a]
++ [Char]
p forall a. [a] -> [a] -> [a]
++ [Char]
" contains a field " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show FieldName
n' forall a. [a] -> [a] -> [a]
++ [Char]
", expecting section " forall a. [a] -> [a] -> [a]
++ forall ann. Name ann -> [SectionArg ann] -> [Char]
showSection Name CommentsPragmas
name [SectionArg CommentsPragmas]
arg forall a. [a] -> [a] -> [a]
++ [Char]
"."
                        forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
                        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Field Position]
rest) forall a b. (a -> b) -> a -> b
$
                            forall r (m :: * -> *). MonadCabalFmt r m => [Char] -> m ()
displayWarning forall a b. (a -> b) -> a -> b
$ [Char]
"Fragment " forall a. [a] -> [a] -> [a]
++ [Char]
p forall a. [a] -> [a] -> [a]
++ [Char]
" contains multiple fields or sections, using only the first."
                        if FieldName
n forall a. Eq a => a -> a -> Bool
== FieldName
n'
                        then do
                            -- everything is fine, replace
                            forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (forall ann. Name ann -> [FieldLine ann] -> Field ann
C.Field Name CommentsPragmas
name (forall (f :: * -> *) ann.
Functor f =>
[f ann] -> [f CommentsPragmas]
noCommentsPragmas [FieldLine Position]
fls')))
                        else do
                            forall r (m :: * -> *). MonadCabalFmt r m => [Char] -> m ()
displayWarning forall a b. (a -> b) -> a -> b
$ [Char]
"Fragment " forall a. [a] -> [a] -> [a]
++ [Char]
p forall a. [a] -> [a] -> [a]
++ [Char]
" contains field " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show FieldName
n' forall a. [a] -> [a] -> [a]
++ [Char]
", expecting field " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show FieldName
n forall a. [a] -> [a] -> [a]
++ [Char]
"."
                            forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
                        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Field Position]
rest) forall a b. (a -> b) -> a -> b
$
                            forall r (m :: * -> *). MonadCabalFmt r m => [Char] -> m ()
displayWarning forall a b. (a -> b) -> a -> b
$ [Char]
"Fragment " forall a. [a] -> [a] -> [a]
++ [Char]
p forall a. [a] -> [a] -> [a]
++ [Char]
" contains multiple fields or sections, using only the first."

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

    getPragmas :: C.Field CommentsPragmas -> [FieldPragma]
    getPragmas :: Field CommentsPragmas -> [FieldPragma]
getPragmas = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) []   = forall a. Show a => a -> [Char]
show FieldName
n
    showSection (C.Name ann
_ FieldName
n) [SectionArg ann]
args = forall a. Show a => a -> [Char]
show (FieldName -> [Char]
fromUTF8BS FieldName
n forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ Doc -> [Char]
render ([Doc] -> Doc
hsep (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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {m :: * -> *}. Monad m => FieldPragma -> m (Maybe [Char])
go where
        go :: FieldPragma -> m (Maybe [Char])
go (PragmaFragment [Char]
f) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just [Char]
f)
        go FieldPragma
_                  = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing