content: {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE ViewPatterns #-}
  {-# LANGUAGE CPP #-}
  module Hpack.Render (
  -- | /__NOTE:__/ This module is exposed to allow integration of Hpack into
  -- other tools.  It is not meant for general use by end users.  The following
  -- caveats apply:
  --
  -- * The API is undocumented, consult the source instead.
  --
  -- * The exposed types and functions primarily serve Hpack's own needs, not
  -- that of a public API.  Breaking changes can happen as Hpack evolves.
  --
  -- As an Hpack user you either want to use the @hpack@ executable or a build
  -- tool that supports Hpack (e.g. @stack@ or @cabal2nix@).
  
    renderPackage
  , renderPackageWith
  , defaultRenderSettings
  , RenderSettings(..)
  , Alignment(..)
  , CommaStyle(..)
  #ifdef TEST
  , RenderEnv(..)
  , renderConditional
  , renderDependencies
  , renderLibraryFields
  , renderExecutableFields
  , renderFlag
  , renderSourceRepository
  , renderDirectories
  , formatDescription
  #endif
  ) where
  
  import           Imports
  
  import           Data.Char
  import           Data.Maybe
  import           Data.Map.Lazy (Map)
  import qualified Data.Map.Lazy as Map
  import           Control.Monad.Reader
  
  import           Hpack.Util
  import           Hpack.Config
  import           Hpack.Render.Hints
  import           Hpack.Render.Dsl hiding (sortFieldsBy)
  import qualified Hpack.Render.Dsl as Dsl
  
  data RenderEnv = RenderEnv {
    renderEnvCabalVersion :: CabalVersion
  , renderEnvPackageName :: String
  }
  
  type RenderM = Reader RenderEnv
  
  getCabalVersion :: RenderM CabalVersion
  getCabalVersion = asks renderEnvCabalVersion
  
  getPackageName :: RenderM String
  getPackageName = asks renderEnvPackageName
  
  renderPackage :: [String] -> Package -> String
  renderPackage oldCabalFile = renderPackageWith settings headerFieldsAlignment formattingHintsFieldOrder formattingHintsSectionsFieldOrder
    where
      FormattingHints{..} = sniffFormattingHints oldCabalFile
      headerFieldsAlignment = fromMaybe 16 formattingHintsAlignment
      settings = formattingHintsRenderSettings
  
  renderPackageWith :: RenderSettings -> Alignment -> [String] -> [(String, [String])] -> Package -> String
  renderPackageWith settings headerFieldsAlignment existingFieldOrder sectionsFieldOrder Package{..} = intercalate "\n" (unlines header : chunks)
    where
      chunks :: [String]
      chunks = map unlines . filter (not . null) . map (render settings 0) $ sortStanzaFields sectionsFieldOrder stanzas
  
      header :: [String]
      header = concatMap (render settings {renderSettingsFieldAlignment = headerFieldsAlignment} 0) packageFields
  
      packageFields :: [Element]
      packageFields = addVerbatim packageVerbatim . sortFieldsBy existingFieldOrder $
        headerFields ++ [
          Field "tested-with" $ CommaSeparatedList packageTestedWith
        , Field "extra-source-files" (renderPaths packageExtraSourceFiles)
        , Field "extra-doc-files" (renderPaths packageExtraDocFiles)
        , Field "extra-files" (renderPaths packageExtraFiles)
        , Field "data-files" (renderPaths packageDataFiles)
        ] ++ maybe [] (return . Field "data-dir" . Literal) packageDataDir
  
      sourceRepository :: [Element]
      sourceRepository = maybe [] (return . renderSourceRepository) packageSourceRepository
  
      customSetup :: [Element]
      customSetup = maybe [] (return . renderCustomSetup) packageCustomSetup
  
      stanzas :: [Element]
      stanzas = flip runReader (RenderEnv packageCabalVersion packageName) $ do
        library <- maybe (return []) (fmap return . renderLibrary) packageLibrary
        internalLibraries <- renderInternalLibraries packageInternalLibraries
        executables <- renderExecutables packageExecutables
        tests <- renderTests packageTests
        benchmarks <- renderBenchmarks packageBenchmarks
        return $ concat [
            sourceRepository
          , customSetup
          , map renderFlag packageFlags
          , library
          , internalLibraries
          , executables
          , tests
          , benchmarks
          ]
  
      headerFields :: [Element]
      headerFields = mapMaybe (\(name, value) -> Field name . Literal <$> value) $ [
          ("name", Just packageName)
        , ("version", Just packageVersion)
        , ("synopsis", packageSynopsis)
        , ("description", (formatDescription packageCabalVersion headerFieldsAlignment <$> packageDescription))
        , ("category", packageCategory)
        , ("stability", packageStability)
        , ("homepage", packageHomepage)
        , ("bug-reports", packageBugReports)
        , ("author", formatList packageAuthor)
        , ("maintainer", formatList packageMaintainer)
        , ("copyright", formatList packageCopyright)
        , ("license", packageLicense)
        , case packageLicenseFile of
            [file] -> ("license-file", Just file)
            files  -> ("license-files", formatList files)
        , ("build-type", Just (show packageBuildType))
        ]
  
      formatList :: [String] -> Maybe String
      formatList xs = guard (not $ null xs) >> (Just $ intercalate separator xs)
        where
          separator = let Alignment n = headerFieldsAlignment in ",\n" ++ replicate n ' '
  
  sortStanzaFields :: [(String, [String])] -> [Element] -> [Element]
  sortStanzaFields sectionsFieldOrder = go
    where
      go sections = case sections of
        [] -> []
        Stanza name fields : xs | Just fieldOrder <- lookup name sectionsFieldOrder -> Stanza name (sortFieldsBy fieldOrder fields) : go xs
        x : xs -> x : go xs
  
  formatDescription :: CabalVersion -> Alignment -> String -> String
  formatDescription cabalVersion (Alignment alignment) description = case map emptyLineToDot $ lines description of
    x : xs -> intercalate "\n" (x : indent xs)
    [] -> ""
    where
      n :: Int
      n = max alignment (length ("description: " :: String))
  
      indentation :: String
      indentation = replicate n ' '
  
      emptyLineToDot :: String -> String
      emptyLineToDot xs
        | isEmptyLine xs && cabalVersion < makeCabalVersion [3] = "."
        | otherwise = xs
  
      indent :: [String] -> [String]
      indent = map indentLine
  
      indentLine :: String -> String
      indentLine xs
        | isEmptyLine xs = ""
        | otherwise = indentation ++ xs
  
      isEmptyLine :: String -> Bool
      isEmptyLine = all isSpace
  
  renderSourceRepository :: SourceRepository -> Element
  renderSourceRepository SourceRepository{..} = Stanza "source-repository head" [
      Field "type" "git"
    , Field "location" (Literal sourceRepositoryUrl)
    , Field "subdir" (maybe "" Literal sourceRepositorySubdir)
    ]
  
  renderFlag :: Flag -> Element
  renderFlag Flag {..} = Stanza ("flag " ++ flagName) $ description ++ [
      Field "manual" (Literal $ show flagManual)
    , Field "default" (Literal $ show flagDefault)
    ]
    where
      description = maybe [] (return . Field "description" . Literal) flagDescription
  
  renderInternalLibraries :: Map String (Section Library) -> RenderM [Element]
  renderInternalLibraries = traverse renderInternalLibrary . Map.toList
  
  renderInternalLibrary :: (String, Section Library) -> RenderM Element
  renderInternalLibrary (name, sect) = do
    Stanza ("library " ++ name) <$> renderLibrarySection sect
  
  renderExecutables :: Map String (Section Executable) -> RenderM [Element]
  renderExecutables = traverse renderExecutable . Map.toList
  
  renderExecutable :: (String, Section Executable) -> RenderM Element
  renderExecutable (name, sect) = do
    Stanza ("executable " ++ name) <$> renderExecutableSection [] sect
  
  renderTests :: Map String (Section Executable) -> RenderM [Element]
  renderTests = traverse renderTest . Map.toList
  
  renderTest :: (String, Section Executable) -> RenderM Element
  renderTest (name, sect) = do
    Stanza ("test-suite " ++ name) <$>
      renderExecutableSection [Field "type" "exitcode-stdio-1.0"] sect
  
  renderBenchmarks :: Map String (Section Executable) -> RenderM [Element]
  renderBenchmarks = traverse renderBenchmark . Map.toList
  
  renderBenchmark :: (String, Section Executable) -> RenderM Element
  renderBenchmark (name, sect) = do
    Stanza ("benchmark " ++ name) <$>
      renderExecutableSection [Field "type" "exitcode-stdio-1.0"] sect
  
  renderExecutableSection :: [Element] -> Section Executable -> RenderM [Element]
  renderExecutableSection extraFields = renderSection renderExecutableFields extraFields
  
  renderExecutableFields :: Executable -> [Element]
  renderExecutableFields Executable{..} = mainIs ++ [otherModules, generatedModules]
    where
      mainIs = maybe [] (return . Field "main-is" . Literal) executableMain
      otherModules = renderOtherModules executableOtherModules
      generatedModules = renderGeneratedModules executableGeneratedModules
  
  renderCustomSetup :: CustomSetup -> Element
  renderCustomSetup CustomSetup{..} =
    Stanza "custom-setup" $ renderDependencies "setup-depends" customSetupDependencies
  
  renderLibrary :: Section Library -> RenderM Element
  renderLibrary sect = Stanza "library" <$> renderLibrarySection sect
  
  renderLibrarySection :: Section Library -> RenderM [Element]
  renderLibrarySection = renderSection renderLibraryFields []
  
  renderLibraryFields :: Library -> [Element]
  renderLibraryFields Library{..} =
    maybe [] (return . renderExposed) libraryExposed ++
    maybe [] (return . renderVisibility) libraryVisibility ++ [
      renderExposedModules libraryExposedModules
    , renderOtherModules libraryOtherModules
    , renderGeneratedModules libraryGeneratedModules
    , renderReexportedModules libraryReexportedModules
    , renderSignatures librarySignatures
    ]
  
  renderExposed :: Bool -> Element
  renderExposed = Field "exposed" . Literal . show
  
  renderVisibility :: String -> Element
  renderVisibility = Field "visibility" . Literal
  
  renderSection :: (a -> [Element]) -> [Element] -> Section a -> RenderM [Element]
  renderSection renderSectionData extraFieldsStart Section{..} = do
    buildTools <- renderBuildTools sectionBuildTools sectionSystemBuildTools
    conditionals <- traverse (renderConditional renderSectionData) sectionConditionals
    return . addVerbatim sectionVerbatim $
         extraFieldsStart
      ++ renderSectionData sectionData
      ++ [
        renderDirectories "hs-source-dirs" sectionSourceDirs
      , renderDefaultExtensions sectionDefaultExtensions
      , renderOtherExtensions sectionOtherExtensions
      , renderGhcOptions sectionGhcOptions
      , renderGhcProfOptions sectionGhcProfOptions
      , renderGhcSharedOptions sectionGhcSharedOptions
      , renderGhcjsOptions sectionGhcjsOptions
      , renderCppOptions sectionCppOptions
      , renderAsmOptions sectionAsmOptions
      , renderCcOptions sectionCcOptions
      , renderCxxOptions sectionCxxOptions
      , renderDirectories "include-dirs" sectionIncludeDirs
      , Field "install-includes" (LineSeparatedList sectionInstallIncludes)
      , Field "asm-sources" (renderPaths sectionAsmSources)
      , Field "c-sources" (renderPaths sectionCSources)
      , Field "cxx-sources" (renderPaths sectionCxxSources)
      , Field "js-sources" (renderPaths sectionJsSources)
      , renderDirectories "extra-lib-dirs" sectionExtraLibDirs
      , Field "extra-libraries" (LineSeparatedList sectionExtraLibraries)
      , renderDirectories "extra-frameworks-dirs" sectionExtraFrameworksDirs
      , Field "frameworks" (LineSeparatedList sectionFrameworks)
      , renderLdOptions sectionLdOptions
      , Field "pkgconfig-depends" (CommaSeparatedList sectionPkgConfigDependencies)
      ]
      ++ buildTools
      ++ renderDependencies "build-depends" sectionDependencies
      ++ maybe [] (return . renderBuildable) sectionBuildable
      ++ maybe [] (return . renderLanguage) sectionLanguage
      ++ conditionals
  
  addVerbatim :: [Verbatim] -> [Element] -> [Element]
  addVerbatim verbatim fields = filterVerbatim verbatim fields ++ renderVerbatim verbatim
  
  filterVerbatim :: [Verbatim] -> [Element] -> [Element]
  filterVerbatim verbatim = filter p
    where
      p :: Element -> Bool
      p = \ case
        Field name _ -> name `notElem` fields
        _ -> True
      fields = concatMap verbatimFieldNames verbatim
  
  verbatimFieldNames :: Verbatim -> [String]
  verbatimFieldNames verbatim = case verbatim of
    VerbatimLiteral _ -> []
    VerbatimObject o -> Map.keys o
  
  renderVerbatim :: [Verbatim] -> [Element]
  renderVerbatim = concatMap $ \ case
    VerbatimLiteral s -> [Verbatim s]
    VerbatimObject o -> renderVerbatimObject o
  
  renderVerbatimObject :: Map String VerbatimValue -> [Element]
  renderVerbatimObject = map renderPair . Map.toList
    where
      renderPair (key, value) = case lines (verbatimValueToString value) of
        [x] -> Field key (Literal x)
        xs -> Field key (LineSeparatedList xs)
  
  renderConditional :: (a -> [Element]) -> Conditional (Section a) -> RenderM Element
  renderConditional renderSectionData (Conditional condition sect mElse) = case mElse of
    Nothing -> if_
    Just else_ -> Group <$> if_ <*> (Stanza "else" <$> renderSection renderSectionData [] else_)
    where
      if_ = Stanza ("if " ++ renderCond condition) <$> renderSection renderSectionData [] sect
  
  renderCond :: Cond -> String
  renderCond = \ case
    CondExpression c -> c
    CondBool True -> "true"
    CondBool False -> "false"
  
  renderDirectories :: String -> [String] -> Element
  renderDirectories name = Field name . LineSeparatedList . replaceDots
    where
      replaceDots = map replaceDot
      replaceDot xs = case xs of
        "." -> "./"
        _ -> xs
  
  renderExposedModules :: [Module] -> Element
  renderExposedModules = Field "exposed-modules" . LineSeparatedList . map unModule
  
  renderOtherModules :: [Module] -> Element
  renderOtherModules = Field "other-modules" . LineSeparatedList . map unModule
  
  renderGeneratedModules :: [Module] -> Element
  renderGeneratedModules = Field "autogen-modules" . LineSeparatedList . map unModule
  
  renderReexportedModules :: [String] -> Element
  renderReexportedModules = Field "reexported-modules" . CommaSeparatedList
  
  renderSignatures :: [String] -> Element
  renderSignatures = Field "signatures" . CommaSeparatedList
  
  renderDependencies :: String -> Dependencies -> [Element]
  renderDependencies name deps = [
      Field name (CommaSeparatedList renderedDeps)
    , Field "mixins" (CommaSeparatedList $ concat mixins)
    ]
    where
      (renderedDeps, mixins) = unzip . map renderDependency . Map.toList $ unDependencies deps
  
  renderDependency :: (String, DependencyInfo) -> (String, [String])
  renderDependency (name, DependencyInfo mixins version) = (
        name ++ renderVersion version
      , [ name ++ " " ++ mixin | mixin <- mixins ]
      )
  
  renderVersion :: DependencyVersion -> String
  renderVersion (DependencyVersion _ c) = renderVersionConstraint c
  
  renderVersionConstraint :: VersionConstraint -> String
  renderVersionConstraint version = case version of
    AnyVersion -> ""
    VersionRange x -> " " ++ x
  
  renderBuildTools :: Map BuildTool DependencyVersion -> SystemBuildTools -> RenderM [Element]
  renderBuildTools buildTools systemBuildTools = do
    xs <- traverse renderBuildTool $ Map.toList buildTools
    return [
        Field "build-tools" $ CommaSeparatedList $ [x | BuildTools x <- xs] ++ renderSystemBuildTools systemBuildTools
      , Field "build-tool-depends" $ CommaSeparatedList [x | BuildToolDepends x <- xs]
      ]
  
  data RenderBuildTool = BuildTools String | BuildToolDepends String
  
  renderBuildTool :: (BuildTool,  DependencyVersion) -> RenderM RenderBuildTool
  renderBuildTool (buildTool, renderVersion -> version) = do
    cabalVersion <- getCabalVersion
    packageName <- getPackageName
    let supportsBuildTools = cabalVersion < makeCabalVersion [2]
    return $ case buildTool of
      LocalBuildTool executable
        | supportsBuildTools -> BuildTools (executable ++ version)
        | otherwise -> BuildToolDepends (packageName ++ ":" ++ executable ++ version)
      BuildTool pkg executable
        | supportsBuildTools && isknownBuildTool pkg executable -> BuildTools (executable ++ version)
        | otherwise -> BuildToolDepends (pkg ++ ":" ++ executable ++ version)
    where
      isknownBuildTool :: String -> String -> Bool
      isknownBuildTool pkg executable = pkg == executable && executable `elem` knownBuildTools
  
      knownBuildTools :: [String]
      knownBuildTools = [
          "alex"
        , "c2hs"
        , "cpphs"
        , "greencard"
        , "haddock"
        , "happy"
        , "hsc2hs"
        , "hscolour"
        ]
  
  renderSystemBuildTools :: SystemBuildTools -> [String]
  renderSystemBuildTools = map renderSystemBuildTool . Map.toList . unSystemBuildTools
  
  renderSystemBuildTool :: (String, VersionConstraint) -> String
  renderSystemBuildTool (name, constraint) = name ++ renderVersionConstraint constraint
  
  renderLanguage :: Language -> Element
  renderLanguage (Language lang) = Field "default-language" (Literal lang)
  
  renderGhcOptions :: [GhcOption] -> Element
  renderGhcOptions = Field "ghc-options" . WordList
  
  renderGhcProfOptions :: [GhcProfOption] -> Element
  renderGhcProfOptions = Field "ghc-prof-options" . WordList
  
  renderGhcSharedOptions :: [GhcOption] -> Element
  renderGhcSharedOptions = Field "ghc-shared-options" . WordList
  
  renderGhcjsOptions :: [GhcjsOption] -> Element
  renderGhcjsOptions = Field "ghcjs-options" . WordList
  
  renderCppOptions :: [CppOption] -> Element
  renderCppOptions = Field "cpp-options" . WordList
  
  renderAsmOptions :: [AsmOption] -> Element
  renderAsmOptions = Field "asm-options" . WordList
  
  renderCcOptions :: [CcOption] -> Element
  renderCcOptions = Field "cc-options" . WordList
  
  renderCxxOptions :: [CxxOption] -> Element
  renderCxxOptions = Field "cxx-options" . WordList
  
  renderLdOptions :: [LdOption] -> Element
  renderLdOptions = Field "ld-options" . WordList
  
  renderBuildable :: Bool -> Element
  renderBuildable = Field "buildable" . Literal . show
  
  renderDefaultExtensions :: [String] -> Element
  renderDefaultExtensions = Field "default-extensions" . LineSeparatedList
  
  renderOtherExtensions :: [String] -> Element
  renderOtherExtensions = Field "other-extensions" . LineSeparatedList
  
  renderPaths :: [Path] -> Value
  renderPaths = LineSeparatedList . map renderPath
    where
      renderPath :: Path -> FilePath
      renderPath (Path path)
        | needsQuoting path = show path
        | otherwise = path
  
      needsQuoting :: FilePath -> Bool
      needsQuoting = any (\x -> isSpace x || x == ',')
  
  sortFieldsBy :: [String] -> [Element] -> [Element]
  sortFieldsBy existingFieldOrder = Dsl.sortFieldsBy ("import" : existingFieldOrder)
  