module Hpack.Run (
run
, 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
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)
output = renderPackage alignment (maybe [] extractFieldOrderHint old) package
return (warnings, cabalFile, output)
Left err -> die err
renderPackage :: Int -> [String] -> Package -> String
renderPackage alignment existingFieldOrder Package{..} = intercalate "\n" sections
where
sections :: [String]
sections = catMaybes [
header
, extraSourceFiles
, sourceRepository
, library
] ++ renderExecutables packageExecutables ++ renderTests packageTests
header = Just (unlines $ map formatField sortedFields)
extraSourceFiles = guard (not . null $ packageExtraSourceFiles) >> Just (unlines $ "extra-source-files:" : map (" " ++) packageExtraSourceFiles)
sourceRepository = renderSourceRepository <$> packageSourceRepository
library = renderLibrary <$> packageLibrary
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: ")
indentation = replicate n ' '
emptyLineToDot xs
| isEmptyLine xs = "."
| otherwise = xs
isEmptyLine = all isSpace
renderSourceRepository :: SourceRepository -> String
renderSourceRepository SourceRepository{..} = concat [
"source-repository head\n"
, " type: git\n"
, " location: " ++ sourceRepositoryUrl ++ "\n"
, maybe "" ((" subdir: " ++) . (++ "\n")) sourceRepositorySubdir
]
renderExecutables :: [Section Executable] -> [String]
renderExecutables = map renderExecutable
renderExecutable :: Section Executable -> String
renderExecutable section@(sectionData -> Executable{..}) =
"executable "
++ executableName ++ "\n"
++ renderExecutableSection section
renderTests :: [Section Executable] -> [String]
renderTests = map renderTest
renderTest :: Section Executable -> String
renderTest section@(sectionData -> Executable{..}) =
"test-suite " ++ executableName ++ "\n"
++ " type: exitcode-stdio-1.0\n"
++ renderExecutableSection section
renderExecutableSection :: Section Executable -> String
renderExecutableSection section@(sectionData -> Executable{..}) =
" main-is: " ++ executableMain ++ "\n"
++ renderSection section
renderLibrary :: Section Library -> String
renderLibrary section@(sectionData -> Library{..}) =
"library\n"
++ renderExposedModules libraryExposedModules
++ renderOtherModules libraryOtherModules
++ renderSection section
renderSection :: Section a -> String
renderSection Section{..} =
renderSourceDirs sectionSourceDirs
++ renderDependencies sectionDependencies
++ renderDefaultExtensions sectionDefaultExtensions
++ renderGhcOptions sectionGhcOptions
++ renderCppOptions sectionCppOptions
++ " default-language: Haskell2010\n"
renderSourceDirs :: [String] -> String
renderSourceDirs dirs
| null dirs = ""
| otherwise = " hs-source-dirs: " ++ intercalate ", " dirs ++ "\n"
renderExposedModules :: [String] -> String
renderExposedModules modules
| null modules = ""
| otherwise = " exposed-modules:\n" ++ (unlines $ map (" " ++) modules)
renderOtherModules :: [String] -> String
renderOtherModules modules
| null modules = ""
| otherwise = " other-modules:\n" ++ (unlines $ map (" " ++) modules)
renderDependencies :: [[Dependency]] -> String
renderDependencies dependencies
| null dependencies = ""
| otherwise = concatMap render $ zip (True : repeat False) (map (map dependencyName) dependencies)
where
render (isFirst, xs)
| isFirst = " build-depends:\n " ++ intercalate "\n , " xs ++ "\n"
| otherwise = "\n , " ++ intercalate "\n , " xs ++ "\n"
renderGhcOptions :: [GhcOption] -> String
renderGhcOptions = renderOptions "ghc-options"
renderCppOptions :: [GhcOption] -> String
renderCppOptions = renderOptions "cpp-options"
renderDefaultExtensions :: [String] -> String
renderDefaultExtensions = renderOptions "default-extensions"
renderOptions :: String -> [String] -> String
renderOptions field options
| null options = ""
| otherwise = " " ++ field ++ ": " ++ unwords options ++ "\n"