{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE OverloadedStrings #-}
-- |
-- License: GPL-3.0-or-later
-- Copyright: Oleg Grenrus
--
-- This is a demo application of how you can make Cabal-like
-- file formatter.
--
module CabalFmt (cabalFmt) where

import Control.Monad        (join)
import Control.Monad.Reader (asks, local)

import qualified Data.ByteString                              as BS
import qualified Distribution.CabalSpecVersion                as C
import qualified Distribution.FieldGrammar.Parsec             as C
import qualified Distribution.Fields                          as C
import qualified Distribution.Fields.ConfVar                  as C
import qualified Distribution.Fields.Pretty                   as C
import qualified Distribution.PackageDescription.FieldGrammar as C
import qualified Distribution.Parsec                          as C
import qualified Distribution.Pretty                          as C
import qualified Distribution.Types.Condition                 as C
import qualified Distribution.Types.ConfVar                   as C
import qualified Distribution.Types.GenericPackageDescription as C
import qualified Distribution.Types.PackageDescription        as C
import qualified Distribution.Types.VersionRange              as C
import qualified Distribution.Utils.Generic                   as C
import qualified Text.PrettyPrint                             as PP

import CabalFmt.Comments
import CabalFmt.Fields
import CabalFmt.Fields.BuildDepends
import CabalFmt.Fields.Extensions
import CabalFmt.FreeText
import CabalFmt.Fields.Modules
import CabalFmt.Fields.SourceFiles
import CabalFmt.Fields.TestedWith
import CabalFmt.Monad
import CabalFmt.Options
import CabalFmt.Parser
import CabalFmt.Pragma
import CabalFmt.Prelude
import CabalFmt.Refactoring

-------------------------------------------------------------------------------
-- Main
-------------------------------------------------------------------------------

cabalFmt :: MonadCabalFmt r m => FilePath -> BS.ByteString -> m String
cabalFmt filepath contents = do
    -- determine cabal-version
    cabalFile <- asks (optCabalFile . view options)
    csv <- case cabalFile of
        False -> return C.cabalSpecLatest
        True  -> do
            gpd <- parseGpd filepath contents
            return $ C.specVersion
              $ C.packageDescription gpd

    inputFields' <- parseFields contents
    let (inputFieldsC, endComments) = attachComments contents inputFields'

    -- parse pragmas
    let parse (pos, c) = case parsePragmas c of (ws, ps) -> traverse_ displayWarning ws *> return (pos, c, ps)
    inputFieldsP' <- traverse (traverse parse) inputFieldsC
    endCommentsPragmas <- case parsePragmas endComments of
        (ws, ps) -> traverse_ displayWarning ws *> return ps

    -- apply refactorings
    let inputFieldsP :: [C.Field CommentsPragmas]
        inputFieldsP = map (fmap (fmap (snd . partitionPragmas))) inputFieldsP'

    inputFieldsR  <- refactor inputFieldsP

    -- options morphisms
    let pragmas :: [GlobalPragma]
        pragmas = fst $ partitionPragmas $
            foldMap (foldMap trdOf3) inputFieldsP' <> endCommentsPragmas

        optsEndo :: OptionsMorphism
        optsEndo = foldMap pragmaToOM pragmas

    local (over options $ \o -> runOptionsMorphism optsEndo $ o { optSpecVersion = csv }) $ do
        indentWith <- asks (optIndent . view options)
        let inputFields = inputFieldsR

        outputPrettyFields <- genericFromParsecFields
            (\n ann -> prettyFieldLines n (fstOf3 ann))
            prettySectionArgs
            inputFields

        return $ C.showFields' (fromComments . sndOf3) (const id) indentWith outputPrettyFields
            & if nullComments endComments then id else
                (++ unlines ("" : [ C.fromUTF8BS c | c <- unComments endComments ]))

fromComments :: Comments -> C.CommentPosition
fromComments (Comments [])  = C.NoComment
fromComments (Comments bss) = C.CommentBefore (map C.fromUTF8BS bss)

genericFromParsecFields
    :: Applicative f
    => (C.FieldName -> ann -> [C.FieldLine ann] -> f PP.Doc)     -- ^ transform field contents
    -> (C.FieldName -> [C.SectionArg ann] -> f [PP.Doc])  -- ^ transform section arguments
    -> [C.Field ann]
    -> f [C.PrettyField ann]
genericFromParsecFields f g = goMany where
    goMany = traverse go

    go (C.Field (C.Name ann name) fls)          = C.PrettyField ann name <$> f name ann fls
    go (C.Section (C.Name ann name) secargs fs) = C.PrettySection ann name <$> g name secargs <*> goMany fs

-------------------------------------------------------------------------------
-- Field prettyfying
-------------------------------------------------------------------------------

prettyFieldLines :: MonadCabalFmt r m => C.FieldName -> C.Position -> [C.FieldLine CommentsPragmas] -> m PP.Doc
prettyFieldLines fn pos fls =
    fromMaybe (C.prettyFieldLines fn fls) <$> knownField fn pos fls

knownField :: MonadCabalFmt r m => C.FieldName -> C.Position -> [C.FieldLine CommentsPragmas] -> m (Maybe PP.Doc)
knownField fn pos fls = do
    opts <- asks (view options)
    let v   = optSpecVersion opts
    let ft  = fieldlinesToFreeText v pos (fmap (fmap fstOf3) fls)
    let ft' = showFreeText v ft

    return $ join $ fieldDescrLookup (fieldDescrs opts) fn (Just ft') $ \p pp ->
        case C.runParsecParser' v p "<input>" (C.fieldLinesToStream fls) of
            Right x -> Just (pp x)
            Left _  -> Nothing

fieldDescrs :: Options -> FieldDescrs () ()
fieldDescrs opts
    =  buildDependsF opts
    <> buildToolDependsF opts
    <> setupDependsF opts
    <> defaultExtensionsF
    <> otherExtensionsF
    <> exposedModulesF
    <> otherModulesF
    <> testedWithF opts
    <> mconcat sourceFilesF
    <> coerceFieldDescrs C.packageDescriptionFieldGrammar
    <> coerceFieldDescrs C.buildInfoFieldGrammar

-------------------------------------------------------------------------------
-- Sections
-------------------------------------------------------------------------------

prettySectionArgs :: MonadCabalFmt r m => C.FieldName -> [C.SectionArg ann] -> m [PP.Doc]
prettySectionArgs x args =
    prettySectionArgs' x args `catchError` \_ ->
        return (C.prettySectionArgs x args)

prettySectionArgs' :: MonadCabalFmt r m => a -> [C.SectionArg ann] -> m [PP.Doc]
prettySectionArgs' _ args = do
    c <- runParseResult "<args>" "" $ C.parseConditionConfVar (map (C.zeroPos <$) args)
    return [ppCondition c]

-------------------------------------------------------------------------------
-- PrettyPrint condition
-------------------------------------------------------------------------------

-- This is originally from Cabal

ppCondition :: C.Condition C.ConfVar -> PP.Doc
ppCondition (C.Var x)      = ppConfVar x
ppCondition (C.Lit b)      = PP.text (show b)
ppCondition (C.CNot c)     = PP.char '!' PP.<> ppCondition c
ppCondition (C.COr c1 c2)  = PP.parens (PP.hsep [ppCondition c1, PP.text "||", ppCondition c2])
ppCondition (C.CAnd c1 c2) = PP.parens (PP.hsep [ppCondition c1, PP.text "&&", ppCondition c2])

ppConfVar :: C.ConfVar -> PP.Doc
ppConfVar (C.OS os)            = PP.text "os"   PP.<> PP.parens (C.pretty os)
ppConfVar (C.Arch arch)        = PP.text "arch" PP.<> PP.parens (C.pretty arch)
ppConfVar (C.PackageFlag name) = PP.text "flag" PP.<> PP.parens (C.pretty name)
ppConfVar (C.Impl c v)
    | v == C.anyVersion        = PP.text "impl" PP.<> PP.parens (C.pretty c)
    | otherwise                = PP.text "impl" PP.<> PP.parens (C.pretty c PP.<+> C.pretty v)

-------------------------------------------------------------------------------
-- Pragma to OM
-------------------------------------------------------------------------------

partitionPragmas :: [Pragma] -> ([GlobalPragma], [FieldPragma])
partitionPragmas = partitionEithers . map p where
    p (GlobalPragma x) = Left x
    p (FieldPragma x)  = Right x

pragmaToOM :: GlobalPragma -> OptionsMorphism
pragmaToOM (PragmaOptIndent n)    = mkOptionsMorphism $ \opts -> opts { optIndent = n }
pragmaToOM (PragmaOptTabular b)   = mkOptionsMorphism $ \opts -> opts { optTabular = b }