-----------------------------------------------------------------------------
-- |
-- 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 (ForeignLib (foreignLibName))
import Distribution.Types.UnqualComponentName
import Distribution.Types.CondTree

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

import Distribution.FieldGrammar (PrettyFieldGrammar', prettyFieldGrammar)
import Distribution.PackageDescription.FieldGrammar
       (packageDescriptionFieldGrammar, buildInfoFieldGrammar,
        flagFieldGrammar, foreignLibFieldGrammar, libraryFieldGrammar,
        benchmarkFieldGrammar, testSuiteFieldGrammar,
        setupBInfoFieldGrammar, sourceRepoFieldGrammar, executableFieldGrammar)

import qualified Distribution.PackageDescription.FieldGrammar as FG

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

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

-- | 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 . ($+$ text "") . ppGenericPackageDescription

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

ppPackageDescription :: PackageDescription -> Doc
ppPackageDescription pd =
    prettyFieldGrammar packageDescriptionFieldGrammar 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 kind $+$
    nest indentWith (prettyFieldGrammar (sourceRepoFieldGrammar kind) repo)
  where
    kind = repoKind repo

ppSetupBInfo :: Maybe SetupBuildInfo -> Doc
ppSetupBInfo Nothing = mempty
ppSetupBInfo (Just sbi)
    | defaultSetupDepends sbi = mempty
    | otherwise =
        emptyLine $ text "custom-setup" $+$
        nest indentWith (prettyFieldGrammar (setupBInfoFieldGrammar False) sbi)

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

ppFlag :: Flag -> Doc
ppFlag flag@(MkFlag name _ _ _)  =
    emptyLine $ text "flag" <+> ppFlagName name $+$
    nest indentWith (prettyFieldGrammar (flagFieldGrammar name) flag)

ppCondTree2 :: PrettyFieldGrammar' s -> CondTree ConfVar [Dependency] s -> Doc
ppCondTree2 grammar = go
  where
    -- TODO: recognise elif opportunities
    go (CondNode it _ ifs) =
        prettyFieldGrammar grammar it
        $+$ vcat (map ppIf ifs)

    ppIf (CondBranch c thenTree Nothing)
--        | isEmpty thenDoc = mempty
        | otherwise       = ppIfCondition c $$ nest indentWith thenDoc
      where
        thenDoc = go thenTree

    ppIf (CondBranch c thenTree (Just elseTree)) =
          case (False, False) of
 --       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 = go thenTree
        elseDoc = go elseTree

ppCondLibrary :: Maybe (CondTree ConfVar [Dependency] Library) -> Doc
ppCondLibrary Nothing = mempty
ppCondLibrary (Just condTree) =
    emptyLine $ text "library" $+$
    nest indentWith (ppCondTree2 (libraryFieldGrammar Nothing) condTree)

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

ppCondForeignLibs :: [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)] -> Doc
ppCondForeignLibs flibs = vcat
    [ emptyLine $ (text "foreign-library" <+> disp n) $+$
      nest indentWith (ppCondTree2 (foreignLibFieldGrammar n) condTree)
    | (n, condTree) <- flibs
    ]

ppCondExecutables :: [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)] -> Doc
ppCondExecutables exes = vcat
    [ emptyLine $ (text "executable" <+> disp n) $+$
      nest indentWith (ppCondTree2 (executableFieldGrammar n) condTree)
    | (n, condTree) <- exes
    ]

ppCondTestSuites :: [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)] -> Doc
ppCondTestSuites suites = vcat
    [ emptyLine $ (text "test-suite" <+> disp n) $+$
      nest indentWith (ppCondTree2 testSuiteFieldGrammar (fmap FG.unvalidateTestSuite condTree))
    | (n, condTree) <- suites
    ]

ppCondBenchmarks :: [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)] -> Doc
ppCondBenchmarks suites = vcat
    [ emptyLine $ (text "benchmark" <+> disp n) $+$
      nest indentWith (ppCondTree2 benchmarkFieldGrammar (fmap FG.unvalidateBenchmark condTree))
    | (n, condTree) <- suites
    ]

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

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

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

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

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

-- | @since 2.0.0.2
showPackageDescription :: PackageDescription -> String
showPackageDescription = showGenericPackageDescription . pdToGpd

pdToGpd :: PackageDescription -> GenericPackageDescription
pdToGpd pd = GenericPackageDescription
    { packageDescription = pd
    , genPackageFlags    = []
    , condLibrary        = mkCondTree <$> library pd
    , condSubLibraries   = mkCondTreeL <$> subLibraries pd
    , condForeignLibs    = mkCondTree' foreignLibName <$> foreignLibs pd
    , condExecutables    = mkCondTree' exeName <$> executables pd
    , condTestSuites     = mkCondTree' testName <$> testSuites pd
    , condBenchmarks     = mkCondTree' benchmarkName <$> benchmarks pd
    }
  where
    -- We set CondTree's [Dependency] to an empty list, as it
    -- is not pretty printed anyway.
    mkCondTree  x = CondNode x [] []
    mkCondTreeL l = (fromMaybe (mkUnqualComponentName "") (libName l), CondNode l [] [])

    mkCondTree'
        :: (a -> UnqualComponentName)
        -> a -> (UnqualComponentName, CondTree ConfVar [Dependency] a)
    mkCondTree' f x = (f x, CondNode x [] [])

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

-- | @since 2.0.0.2
showHookedBuildInfo :: HookedBuildInfo -> String
showHookedBuildInfo (mb_lib_bi, ex_bis) = render $
    maybe mempty (prettyFieldGrammar buildInfoFieldGrammar) mb_lib_bi
    $$ vcat
        [ space
        $$ (text "executable:" <+> disp name)
        $$  prettyFieldGrammar buildInfoFieldGrammar bi
        | (name, bi) <- ex_bis
        ]
    $+$ text ""