{-# 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
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
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