-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.PackageDescription.PrettyPrint
-- Copyright   :  Jürgen Nicklisch-Franken 2010
-- License     :  BSD3
--
-- Maintainer  : cabal-devel@haskell.org
-- Stability   : provisional
-- Portability : portable
--
-- Pretty printing for cabal files
--
-----------------------------------------------------------------------------

module Distribution.PackageDescription.PrettyPrint (
    -- * Generic package descriptions
    writeGenericPackageDescription,
    showGenericPackageDescription,

    -- * Package descriptions
     writePackageDescription,
     showPackageDescription,

     -- ** Supplementary build information
     writeHookedBuildInfo,
     showHookedBuildInfo,
) where

import Prelude ()
import Distribution.Compat.Prelude

import Distribution.Types.Dependency
import Distribution.Types.ForeignLib
import Distribution.Types.UnqualComponentName
import Distribution.Types.CondTree

import Distribution.PackageDescription
import Distribution.Simple.Utils
import Distribution.ParseUtils
import Distribution.PackageDescription.Parse
import Distribution.Text
import Distribution.ModuleName

import Text.PrettyPrint
       (hsep, space, parens, char, nest, isEmpty, ($$), (<+>),
        colon, text, vcat, ($+$), Doc, render)

import qualified Data.ByteString.Lazy.Char8 as BS.Char8

-- | Recompile with false for regression testing
simplifiedPrinting :: Bool
simplifiedPrinting = False

-- | Writes a .cabal file from a generic package description
writeGenericPackageDescription :: FilePath -> GenericPackageDescription -> NoCallStackIO ()
writeGenericPackageDescription fpath pkg = writeUTF8File fpath (showGenericPackageDescription pkg)

-- | Writes a generic package description to a string
showGenericPackageDescription :: GenericPackageDescription -> String
showGenericPackageDescription            = render . ppGenericPackageDescription

ppGenericPackageDescription :: GenericPackageDescription -> Doc
ppGenericPackageDescription gpd          =
        ppPackageDescription (packageDescription gpd)
        $+$ ppGenPackageFlags (genPackageFlags gpd)
        $+$ ppCondLibrary (condLibrary gpd)
        $+$ ppCondSubLibraries (condSubLibraries gpd)
        $+$ ppCondExecutables (condExecutables gpd)
        $+$ ppCondTestSuites (condTestSuites gpd)
        $+$ ppCondBenchmarks (condBenchmarks gpd)

ppPackageDescription :: PackageDescription -> Doc
ppPackageDescription pd                  =      ppFields pkgDescrFieldDescrs pd
                                                $+$ ppCustomFields (customFieldsPD pd)
                                                $+$ ppSourceRepos (sourceRepos pd)

ppSourceRepos :: [SourceRepo] -> Doc
ppSourceRepos []                         = mempty
ppSourceRepos (hd:tl)                    = ppSourceRepo hd $+$ ppSourceRepos tl

ppSourceRepo :: SourceRepo -> Doc
ppSourceRepo repo                        =
    emptyLine $ text "source-repository" <+> disp (repoKind repo) $+$
        (nest indentWith (ppFields sourceRepoFieldDescrs' repo))
  where
    sourceRepoFieldDescrs' = [fd | fd <- sourceRepoFieldDescrs, fieldName fd /= "kind"]

-- TODO: this is a temporary hack. Ideally, fields containing default values
-- would be filtered out when the @FieldDescr a@ list is generated.
ppFieldsFiltered :: [(String, String)] -> [FieldDescr a] -> a -> Doc
ppFieldsFiltered removable fields x = ppFields (filter nondefault fields) x
  where
    nondefault (FieldDescr name getter _) =
        maybe True (render (getter x) /=) (lookup name removable)

binfoDefaults :: [(String, String)]
binfoDefaults = [("buildable", "True")]

libDefaults :: [(String, String)]
libDefaults = ("exposed", "True") : binfoDefaults

flagDefaults :: [(String, String)]
flagDefaults = [("default", "True"), ("manual", "False")]

ppDiffFields :: [FieldDescr a] -> a -> a -> Doc
ppDiffFields fields x y                  =
   vcat [ ppField name (getter x)
        | FieldDescr name getter _ <- fields
        , render (getter x) /= render (getter y)
        ]

ppCustomFields :: [(String,String)] -> Doc
ppCustomFields flds                      = vcat [ppCustomField f | f <- flds]

ppCustomField :: (String,String) -> Doc
ppCustomField (name,val)                 = text name <<>> colon <+> showFreeText val

ppGenPackageFlags :: [Flag] -> Doc
ppGenPackageFlags flds                   = vcat [ppFlag f | f <- flds]

ppFlag :: Flag -> Doc
ppFlag flag@(MkFlag name _ _ _)    =
    emptyLine $ text "flag" <+> ppFlagName name $+$ nest indentWith fields
  where
    fields = ppFieldsFiltered flagDefaults flagFieldDescrs flag

ppCondLibrary :: Maybe (CondTree ConfVar [Dependency] Library) -> Doc
ppCondLibrary Nothing = mempty
ppCondLibrary (Just condTree) =
    emptyLine $ text "library"
        $+$ nest indentWith (ppCondTree condTree Nothing ppLib) 
ppCondSubLibraries :: [(UnqualComponentName, CondTree ConfVar [Dependency] Library)] -> Doc
ppCondSubLibraries libs                           =
    vcat [emptyLine $ (text "library " <+> disp n)
              $+$ nest indentWith (ppCondTree condTree Nothing ppLib)| (n,condTree) <- libs]

ppLib :: Library -> Maybe Library -> Doc
ppLib lib Nothing     = ppFieldsFiltered libDefaults libFieldDescrs lib
                        $$  ppCustomFields (customFieldsBI (libBuildInfo lib))
ppLib lib (Just plib) = ppDiffFields libFieldDescrs lib plib
                        $$  ppCustomFields (customFieldsBI (libBuildInfo lib))

ppCondExecutables :: [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)] -> Doc
ppCondExecutables exes                       =
    vcat [emptyLine $ (text "executable " <+> disp n)
              $+$ nest indentWith (ppCondTree condTree Nothing ppExe)| (n,condTree) <- exes]
  where
    ppExe (Executable _ modulePath' buildInfo') Nothing =
        (if modulePath' == "" then mempty else text "main-is:" <+> text modulePath')
            $+$ ppFieldsFiltered binfoDefaults binfoFieldDescrs buildInfo'
            $+$  ppCustomFields (customFieldsBI buildInfo')
    ppExe (Executable _ modulePath' buildInfo')
            (Just (Executable _ modulePath2 buildInfo2)) =
            (if modulePath' == "" || modulePath' == modulePath2
                then mempty else text "main-is:" <+> text modulePath')
            $+$ ppDiffFields binfoFieldDescrs buildInfo' buildInfo2
            $+$ ppCustomFields (customFieldsBI buildInfo')

ppCondTestSuites :: [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)] -> Doc
ppCondTestSuites suites =
    emptyLine $ vcat [     (text "test-suite " <+> disp n)
                       $+$ nest indentWith (ppCondTree condTree Nothing ppTestSuite)
                     | (n,condTree) <- suites]
  where
    ppTestSuite testsuite Nothing =
                maybe mempty (\t -> text "type:"        <+> disp t)
                            maybeTestType
            $+$ maybe mempty (\f -> text "main-is:"     <+> text f)
                            (testSuiteMainIs testsuite)
            $+$ maybe mempty (\m -> text "test-module:" <+> disp m)
                            (testSuiteModule testsuite)
            $+$ ppFieldsFiltered binfoDefaults binfoFieldDescrs (testBuildInfo testsuite)
            $+$ ppCustomFields (customFieldsBI (testBuildInfo testsuite))
      where
        maybeTestType | testInterface testsuite == mempty = Nothing
                      | otherwise = Just (testType testsuite)

    ppTestSuite test' (Just test2) =
            ppDiffFields binfoFieldDescrs
                (testBuildInfo test') (testBuildInfo test2)
            $+$ ppCustomFields (customFieldsBI (testBuildInfo test'))

    testSuiteMainIs test = case testInterface test of
      TestSuiteExeV10 _ f -> Just f
      _                   -> Nothing

    testSuiteModule test = case testInterface test of
      TestSuiteLibV09 _ m -> Just m
      _                   -> Nothing

ppCondBenchmarks :: [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)] -> Doc
ppCondBenchmarks suites =
    emptyLine $ vcat [     (text "benchmark " <+> disp n)
                       $+$ nest indentWith (ppCondTree condTree Nothing ppBenchmark)
                     | (n,condTree) <- suites]
  where
    ppBenchmark benchmark Nothing =
                maybe mempty (\t -> text "type:"        <+> disp t)
                            maybeBenchmarkType
            $+$ maybe mempty (\f -> text "main-is:"     <+> text f)
                            (benchmarkMainIs benchmark)
            $+$ ppFieldsFiltered binfoDefaults binfoFieldDescrs (benchmarkBuildInfo benchmark)
            $+$ ppCustomFields (customFieldsBI (benchmarkBuildInfo benchmark))
      where
        maybeBenchmarkType | benchmarkInterface benchmark == mempty = Nothing
                           | otherwise = Just (benchmarkType benchmark)

    ppBenchmark bench' (Just bench2) =
            ppDiffFields binfoFieldDescrs
                (benchmarkBuildInfo bench') (benchmarkBuildInfo bench2)
            $+$ ppCustomFields (customFieldsBI (benchmarkBuildInfo bench'))

    benchmarkMainIs benchmark = case benchmarkInterface benchmark of
      BenchmarkExeV10 _ f -> Just f
      _                   -> Nothing

ppCondition :: Condition ConfVar -> Doc
ppCondition (Var x)                      = ppConfVar x
ppCondition (Lit b)                      = text (show b)
ppCondition (CNot c)                     = char '!' <<>> (ppCondition c)
ppCondition (COr c1 c2)                  = parens (hsep [ppCondition c1, text "||"
                                                         <+> ppCondition c2])
ppCondition (CAnd c1 c2)                 = parens (hsep [ppCondition c1, text "&&"
                                                         <+> ppCondition c2])
ppConfVar :: ConfVar -> Doc
ppConfVar (OS os)                        = text "os"   <<>> parens (disp os)
ppConfVar (Arch arch)                    = text "arch" <<>> parens (disp arch)
ppConfVar (Flag name)                    = text "flag" <<>> parens (ppFlagName name)
ppConfVar (Impl c v)                     = text "impl" <<>> parens (disp c <+> disp v)

ppFlagName :: FlagName -> Doc
ppFlagName                               = text . unFlagName

ppCondTree :: CondTree ConfVar [Dependency] a -> Maybe a -> (a -> Maybe a -> Doc) ->  Doc
ppCondTree ct@(CondNode it _ ifs) mbIt ppIt =
    let res = (vcat $ map ppIf ifs)
                $+$ ppIt it mbIt
    in if isJust mbIt && isEmpty res
        then ppCondTree ct Nothing ppIt
        else res
  where
    -- TODO: this ends up printing trailing spaces when combined with nest.
    ppIf (CondBranch c thenTree (Just elseTree)) = ppIfElse it ppIt c thenTree elseTree
    ppIf (CondBranch c thenTree Nothing)         = ppIf' it ppIt c thenTree

ppIfCondition :: (Condition ConfVar) -> Doc
ppIfCondition c = (emptyLine $ text "if" <+> ppCondition c)

ppIf' :: a -> (a -> Maybe a -> Doc)
           -> Condition ConfVar
           -> CondTree ConfVar [Dependency] a
           -> Doc
ppIf' it ppIt c thenTree =
  if isEmpty thenDoc
     then mempty
     else ppIfCondition c $$ nest indentWith thenDoc
  where thenDoc = ppCondTree thenTree (if simplifiedPrinting then (Just it) else Nothing) ppIt

ppIfElse :: a -> (a -> Maybe a -> Doc)
              -> Condition ConfVar
              -> CondTree ConfVar [Dependency] a
              -> CondTree ConfVar [Dependency] a
              -> Doc
ppIfElse it ppIt c thenTree elseTree =
  case (isEmpty thenDoc, isEmpty elseDoc) of
    (True,  True)  -> mempty
    (False, True)  -> ppIfCondition c $$ nest indentWith thenDoc
    (True,  False) -> ppIfCondition (cNot c) $$ nest indentWith elseDoc
    (False, False) -> (ppIfCondition c $$ nest indentWith thenDoc)
                      $+$ (text "else" $$ nest indentWith elseDoc)
  where thenDoc = ppCondTree thenTree (if simplifiedPrinting then (Just it) else Nothing) ppIt
        elseDoc = ppCondTree elseTree (if simplifiedPrinting then (Just it) else Nothing) ppIt

emptyLine :: Doc -> Doc
emptyLine d                              = text "" $+$ d

-- | @since 1.26.0.0@
writePackageDescription :: FilePath -> PackageDescription -> NoCallStackIO ()
writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription pkg)

--TODO: make this use section syntax
-- add equivalent for GenericPackageDescription

-- | @since 1.26.0.0@
showPackageDescription :: PackageDescription -> String
showPackageDescription pkg = render $
     ppPackageDescription pkg
     $+$ ppMaybeLibrary (library pkg)
     $+$ ppSubLibraries (subLibraries pkg)
     $+$ ppForeignLibs  (foreignLibs pkg)
     $+$ ppExecutables  (executables pkg)
     $+$ ppTestSuites   (testSuites pkg)
     $+$ ppBenchmarks   (benchmarks pkg)

ppMaybeLibrary :: Maybe Library -> Doc
ppMaybeLibrary Nothing = mempty
ppMaybeLibrary (Just lib) =
    emptyLine $ text "library"
        $+$ nest indentWith (ppFields libFieldDescrs lib)

ppSubLibraries :: [Library] -> Doc
ppSubLibraries libs = vcat [
    emptyLine $ text "library" <+> disp libname
        $+$ nest indentWith (ppFields libFieldDescrs lib)
    | lib@Library{ libName = Just libname } <- libs ]

ppForeignLibs :: [ForeignLib] -> Doc
ppForeignLibs flibs = vcat [
    emptyLine $ text "foreign library" <+> disp flibname
        $+$ nest indentWith (ppFields foreignLibFieldDescrs flib)
    | flib@ForeignLib{ foreignLibName = flibname } <- flibs ]

ppExecutables :: [Executable] -> Doc
ppExecutables exes = vcat [
    emptyLine $ text "executable" <+> disp (exeName exe)
        $+$ nest indentWith (ppFields executableFieldDescrs exe)
    | exe <- exes ]

ppTestSuites :: [TestSuite] -> Doc
ppTestSuites tests = vcat [
    emptyLine $ text "test-suite" <+> disp (testName test)
        $+$ nest indentWith (ppFields testSuiteFieldDescrs test_stanza)
    | test <- tests
    , let test_stanza
            = TestSuiteStanza {
                testStanzaTestType = Just (testSuiteInterfaceToTestType (testInterface test)),
                testStanzaMainIs = testSuiteInterfaceToMaybeMainIs (testInterface test),
                testStanzaTestModule = testSuiteInterfaceToMaybeModule (testInterface test),
                testStanzaBuildInfo = testBuildInfo test
            }
    ]

testSuiteInterfaceToTestType :: TestSuiteInterface -> TestType
testSuiteInterfaceToTestType (TestSuiteExeV10 ver _) = TestTypeExe ver
testSuiteInterfaceToTestType (TestSuiteLibV09 ver _) = TestTypeLib ver
testSuiteInterfaceToTestType (TestSuiteUnsupported ty) = ty

testSuiteInterfaceToMaybeMainIs :: TestSuiteInterface -> Maybe FilePath
testSuiteInterfaceToMaybeMainIs (TestSuiteExeV10 _ fp) = Just fp
testSuiteInterfaceToMaybeMainIs TestSuiteLibV09{} = Nothing
testSuiteInterfaceToMaybeMainIs TestSuiteUnsupported{} = Nothing

testSuiteInterfaceToMaybeModule :: TestSuiteInterface -> Maybe ModuleName
testSuiteInterfaceToMaybeModule (TestSuiteLibV09 _ mod_name) = Just mod_name
testSuiteInterfaceToMaybeModule TestSuiteExeV10{} = Nothing
testSuiteInterfaceToMaybeModule TestSuiteUnsupported{} = Nothing

ppBenchmarks :: [Benchmark] -> Doc
ppBenchmarks benchs = vcat [
    emptyLine $ text "benchmark" <+> disp (benchmarkName bench)
        $+$ nest indentWith (ppFields benchmarkFieldDescrs bench_stanza)
    | bench <- benchs
    , let bench_stanza = BenchmarkStanza {
                benchmarkStanzaBenchmarkType = Just (benchmarkInterfaceToBenchmarkType (benchmarkInterface bench)),
                benchmarkStanzaMainIs = benchmarkInterfaceToMaybeMainIs (benchmarkInterface bench),
                benchmarkStanzaBenchmarkModule = Nothing,
                benchmarkStanzaBuildInfo = benchmarkBuildInfo bench
            }]

benchmarkInterfaceToBenchmarkType :: BenchmarkInterface -> BenchmarkType
benchmarkInterfaceToBenchmarkType (BenchmarkExeV10 ver _)   = BenchmarkTypeExe ver
benchmarkInterfaceToBenchmarkType (BenchmarkUnsupported ty) = ty

benchmarkInterfaceToMaybeMainIs :: BenchmarkInterface -> Maybe FilePath
benchmarkInterfaceToMaybeMainIs (BenchmarkExeV10 _ fp) = Just fp
benchmarkInterfaceToMaybeMainIs BenchmarkUnsupported{} = Nothing


-- | @since 1.26.0.0@
writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> NoCallStackIO ()
writeHookedBuildInfo fpath = writeFileAtomic fpath . BS.Char8.pack
                             . showHookedBuildInfo

-- | @since 1.26.0.0@
showHookedBuildInfo :: HookedBuildInfo -> String
showHookedBuildInfo (mb_lib_bi, ex_bis) = render $
     (case mb_lib_bi of
        Nothing -> mempty
        Just bi -> ppBuildInfo bi)
   $$ vcat [    space
             $$ (text "executable:" <+> disp name)
             $$ ppBuildInfo bi
           | (name, bi) <- ex_bis ]
  where
     ppBuildInfo bi = ppFields binfoFieldDescrs bi
                   $$ ppCustomFields (customFieldsBI bi)