{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
module Hpack.Run (
  run
-- exported for testing
, renderPackage
, renderSourceRepository
, formatDescription
) where

import           Prelude ()
import           Prelude.Compat

import           Control.Monad
import           Data.Char
import           Data.Maybe
import           Data.List.Compat
import           System.Exit.Compat

import           Hpack.Util
import           Hpack.Config
import           Hpack.Render

run :: IO ([String], FilePath, String)
run = do
  mPackage <- readPackageConfig packageConfig
  case mPackage of
    Right (warnings, package) -> do
      let cabalFile = packageName package ++ ".cabal"

      old <- tryReadFile cabalFile

      let alignment = fromMaybe 16 (old >>= sniffAlignment)
          settings = maybe defaultRenderSettings sniffRenderSettings old
          output = renderPackage settings alignment (maybe [] extractFieldOrderHint old) package
      return (warnings, cabalFile, output)
    Left err -> die err

renderPackage :: RenderSettings -> Int -> [String] -> Package -> String
renderPackage settings alignment existingFieldOrder Package{..} = intercalate "\n" (header : chunks)
  where
    chunks :: [String]
    chunks = map unlines . filter (not . null) . map (render settings 0) $ stanzas

    header = unlines $ map formatField sortedFields

    extraSourceFiles :: Field
    extraSourceFiles = Field "extra-source-files" (LineSeparatedList packageExtraSourceFiles)

    dataFiles :: Field
    dataFiles = Field "data-files" (LineSeparatedList packageDataFiles)

    sourceRepository = maybe [] (return . renderSourceRepository) packageSourceRepository

    library = maybe [] (return . renderLibrary) packageLibrary

    stanzas :: [Stanza]
    stanzas = Fields [extraSourceFiles] : Fields [dataFiles] : sourceRepository ++ library ++ renderExecutables packageExecutables ++ renderTests packageTests

    padding name = replicate (alignment - length name - 2) ' '

    formatField :: (String, String) -> String
    formatField (name, value) = name ++ ": " ++ padding name ++ value

    sortedFields :: [(String, String)]
    sortedFields = foldr insertByDefaultFieldOrder (sortBy orderingForExistingFields existing) new
      where
        (existing, new) = partition ((`elem` existingFieldOrder) . fst) fields

        insertByDefaultFieldOrder :: (String, a) -> [(String, a)] -> [(String, a)]
        insertByDefaultFieldOrder x@(key1, _) xs = case xs of
          [] -> [x]
          y@(key2, _) : ys -> if index key1 < index key2 then x : y : ys else y : insertByDefaultFieldOrder x ys
          where
            index :: String -> Maybe Int
            index = (`elemIndex` defaultFieldOrder)

    orderingForExistingFields :: (String, a) -> (String, a) -> Ordering
    orderingForExistingFields (key1, _) (key2, _) = index key1 `compare` index key2
      where
        index :: String -> Maybe Int
        index = (`elemIndex` existingFieldOrder)

    fields :: [(String, String)]
    fields = mapMaybe (\(name, value) -> (,) name <$> value) $ [
        ("name", Just packageName)
      , ("version", Just packageVersion)
      , ("synopsis", packageSynopsis)
      , ("description", (formatDescription alignment <$> packageDescription))
      , ("category", packageCategory)
      , ("stability", packageStability)
      , ("homepage", packageHomepage)
      , ("bug-reports", packageBugReports)
      , ("author", formatList packageAuthor)
      , ("maintainer", formatList packageMaintainer)
      , ("copyright", formatList packageCopyright)
      , ("license", packageLicense)
      , ("license-file", packageLicenseFile)
      , ("build-type", Just "Simple")
      , ("cabal-version", Just ">= 1.10")
      ]

    formatList :: [String] -> Maybe String
    formatList xs = guard (not $ null xs) >> (Just $ intercalate separator xs)
      where
        separator = ",\n" ++ replicate alignment ' '

    defaultFieldOrder :: [String]
    defaultFieldOrder = map fst fields

formatDescription :: Int -> String -> String
formatDescription alignment description = case map emptyLineToDot $ lines description of
  x : xs -> intercalate "\n" (x : map (indentation ++) xs)
  [] -> ""
  where
    n = max alignment (length ("description: " :: String))
    indentation = replicate n ' '

    emptyLineToDot xs
      | isEmptyLine xs = "."
      | otherwise = xs

    isEmptyLine = all isSpace

renderSourceRepository :: SourceRepository -> Stanza
renderSourceRepository SourceRepository{..} = Stanza "source-repository head" [
    Field "type" "git"
  , Field "location" (Literal sourceRepositoryUrl)
  , Field "subdir" (maybe "" Literal sourceRepositorySubdir)
  ]

renderExecutables :: [Section Executable] -> [Stanza]
renderExecutables = map renderExecutable

renderExecutable :: Section Executable -> Stanza
renderExecutable section@(sectionData -> Executable{..}) =
  Stanza ("executable " ++ executableName) (renderExecutableSection section)

renderTests :: [Section Executable] -> [Stanza]
renderTests = map renderTest

renderTest :: Section Executable -> Stanza
renderTest section@(sectionData -> Executable{..}) =
  Stanza ("test-suite " ++ executableName)
    (Field "type" "exitcode-stdio-1.0" : renderExecutableSection section)

renderExecutableSection :: Section Executable -> [Field]
renderExecutableSection section@(sectionData -> Executable{..}) =
  mainIs : renderSection section ++ [otherModules, defaultLanguage]
  where
    mainIs = Field "main-is" (Literal executableMain)
    otherModules = renderOtherModules executableOtherModules

renderLibrary :: Section Library -> Stanza
renderLibrary section@(sectionData -> Library{..}) = Stanza "library" $
  renderSection section ++ [
    renderExposedModules libraryExposedModules
  , renderOtherModules libraryOtherModules
  , defaultLanguage
  ]

renderSection :: Section a -> [Field]
renderSection Section{..} = [
    renderSourceDirs sectionSourceDirs
  , renderDefaultExtensions sectionDefaultExtensions
  , renderGhcOptions sectionGhcOptions
  , renderCppOptions sectionCppOptions
  , renderDependencies sectionDependencies
  ]

defaultLanguage :: Field
defaultLanguage = Field "default-language" "Haskell2010"

renderSourceDirs :: [String] -> Field
renderSourceDirs dirs = Field "hs-source-dirs" (CommaSeparatedList dirs)

renderExposedModules :: [String] -> Field
renderExposedModules modules = Field "exposed-modules" (LineSeparatedList modules)

renderOtherModules :: [String] -> Field
renderOtherModules modules = Field "other-modules" (LineSeparatedList modules)

renderDependencies :: [Dependency] -> Field
renderDependencies dependencies = Field "build-depends" (CommaSeparatedList $ map dependencyName dependencies)

renderGhcOptions :: [GhcOption] -> Field
renderGhcOptions = Field "ghc-options" . WordList

renderCppOptions :: [GhcOption] -> Field
renderCppOptions = Field "cpp-options" . WordList

renderDefaultExtensions :: [String] -> Field
renderDefaultExtensions = Field "default-extensions" . WordList