-- |
-- 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 = do
    mp <- parse (getPragmas field)
    case mp of
        Nothing -> pure Nothing
        Just p  -> readFileBS p >>= \mcontents -> case mcontents of
            NoIO -> pure Nothing
            IOError err -> do
                displayWarning $ "Fragment " ++ p ++ " failed to read: " ++ show err
                pure Nothing
            Contents c  -> do
                fields <- parseFields c
                case (field, fields) of
                    (_, []) -> do
                        displayWarning $ "Fragment " ++ p ++ " is empty."
                        pure Nothing

                    (C.Field (C.Name _ n) _, C.Section name@(C.Name _ _) arg _ : _) -> do
                        displayWarning $ "Fragment " ++ p ++ " contains a section " ++ showSection name arg ++ ", expecting field " ++ show n ++ "."
                        pure Nothing
                    (C.Section name@(C.Name _ _) arg _, C.Field (C.Name _ n') _ : _) -> do
                        displayWarning $ "Fragment " ++ p ++ " contains a field " ++ show n' ++ ", expection section " ++ showSection name arg ++ "."
                        pure Nothing

                    (C.Field name@(C.Name _ n) _, C.Field (C.Name _ n') fls' : rest) -> do
                        unless (null rest) $
                            displayWarning $ "Fragment " ++ p ++ " contains multiple fields or sections, using only the first."
                        if n == n'
                        then do
                            -- everything is fine, replace
                            pure (Just (C.Field name (noCommentsPragmas fls')))
                        else do
                            displayWarning $ "Fragment " ++ p ++ " contains field " ++ show n' ++ ", expecting field " ++ show n ++ "."
                            pure Nothing

                    (C.Section name@(C.Name _ _) arg _, C.Section name'@(C.Name _ _) arg' fs' : rest) -> do
                        unless (null rest) $
                            displayWarning $ "Fragment " ++ p ++ " contains multiple fields or sections, using only the first."

                        if (void name == void name' && map void arg == map void arg')
                        then do
                            pure (Just (C.Section name arg (noCommentsPragmas fs')))
                        else do
                            displayWarning $ "Fragment " ++ p ++ " contains a section " ++ showSection name arg ++ ", expection section " ++ showSection name' arg' ++ "."
                            pure Nothing
  where
    noCommentsPragmas :: Functor f => [f ann] -> [f CommentsPragmas]
    noCommentsPragmas = map ((Comments [], []) <$)

    getPragmas :: C.Field CommentsPragmas -> [FieldPragma]
    getPragmas = snd . C.fieldAnn

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

    parse :: MonadCabalFmt r m => [FieldPragma] -> m (Maybe FilePath)
    parse = fmap asum . traverse go where
        go (PragmaFragment f) = return (Just f)
        go _                  = return Nothing