diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,12 @@ +## Changes in 0.26.0 + - Major refactoring of the exposed API (much cleaner now, but lot's of + breaking changes!) + - Remove Git conflict markers before checking the hash of any existing + `.cabal` files (equivalent to `git checkout --ours`). This allows to + regenerate the `.cabal` file on conflicts when rebasing without passing + `-f` in some cases and helps with preserving the formatting. + - Allow local files to be used as defaults (#248) + ## Changes in 0.25.0 - Keep non-existing literal files on glob expansion (see #101) diff --git a/driver/Main.hs b/driver/Main.hs --- a/driver/Main.hs +++ b/driver/Main.hs @@ -1,6 +1,9 @@ module Main (main) where +import System.Environment + import qualified Hpack +import qualified Hpack.Config as Hpack main :: IO () -main = Hpack.main +main = getArgs >>= Hpack.getOptions Hpack.packageConfig >>= mapM_ (uncurry Hpack.hpack) diff --git a/hpack.cabal b/hpack.cabal --- a/hpack.cabal +++ b/hpack.cabal @@ -1,11 +1,11 @@ --- This file has been generated from package.yaml by hpack version 0.24.0. +-- This file has been generated from package.yaml by hpack version 0.25.0. -- -- see: https://github.com/sol/hpack -- --- hash: bdc3b02a4c50d7839928d668388a26aa10ba6b493748bcfc2eb9cabd61cc016d +-- hash: 6affba6bd6791822c191936fdc6314baff1c094aaaebbdd3bf1020f907131a8e name: hpack -version: 0.25.0 +version: 0.26.0 synopsis: An alternative format for Haskell packages description: See README at category: Development @@ -31,8 +31,8 @@ build-depends: Cabal , Glob >=0.9.0 - , aeson >=1.0.0 - , base >=4.8 && <5 + , aeson >=1.2.1.0 + , base >=4.9 && <5 , bifunctors , bytestring , containers @@ -53,7 +53,7 @@ exposed-modules: Hpack Hpack.Config - Hpack.Run + Hpack.Render Hpack.Yaml other-modules: Data.Aeson.Config.FromValue @@ -62,12 +62,12 @@ Data.Aeson.Config.Util Hpack.CabalFile Hpack.Defaults - Hpack.Dependency - Hpack.FormattingHints Hpack.Haskell Hpack.Options - Hpack.Render + Hpack.Render.Dsl + Hpack.Render.Hints Hpack.Syntax.Defaults + Hpack.Syntax.Dependency Hpack.Syntax.Git Hpack.Utf8 Hpack.Util @@ -82,8 +82,8 @@ build-depends: Cabal , Glob >=0.9.0 - , aeson >=1.0.0 - , base >=4.8 && <5 + , aeson >=1.2.1.0 + , base >=4.9 && <5 , bifunctors , bytestring , containers @@ -119,8 +119,8 @@ , Glob >=0.9.0 , HUnit , QuickCheck - , aeson >=1.0.0 - , base >=4.8 && <5 + , aeson >=1.2.1.0 + , base >=4.9 && <5 , bifunctors , bytestring , containers @@ -152,13 +152,13 @@ Hpack.CabalFileSpec Hpack.ConfigSpec Hpack.DefaultsSpec - Hpack.DependencySpec - Hpack.FormattingHintsSpec Hpack.HaskellSpec Hpack.OptionsSpec + Hpack.Render.DslSpec + Hpack.Render.HintsSpec Hpack.RenderSpec - Hpack.RunSpec Hpack.Syntax.DefaultsSpec + Hpack.Syntax.DependencySpec Hpack.Syntax.GitSpec Hpack.Utf8Spec Hpack.UtilSpec @@ -171,13 +171,13 @@ Hpack.CabalFile Hpack.Config Hpack.Defaults - Hpack.Dependency - Hpack.FormattingHints Hpack.Haskell Hpack.Options Hpack.Render - Hpack.Run + Hpack.Render.Dsl + Hpack.Render.Hints Hpack.Syntax.Defaults + Hpack.Syntax.Dependency Hpack.Syntax.Git Hpack.Utf8 Hpack.Util diff --git a/src/Data/Aeson/Config/FromValue.hs b/src/Data/Aeson/Config/FromValue.hs --- a/src/Data/Aeson/Config/FromValue.hs +++ b/src/Data/Aeson/Config/FromValue.hs @@ -11,7 +11,7 @@ module Data.Aeson.Config.FromValue ( FromValue(..) , Parser -, DecodeResult +, Result , decodeValue , Generic @@ -52,9 +52,9 @@ import Data.Aeson.Config.Util import Data.Aeson.Config.Parser -type DecodeResult a = Either String (a, [String]) +type Result a = Either String (a, [String]) -decodeValue :: FromValue a => Value -> DecodeResult a +decodeValue :: FromValue a => Value -> Result a decodeValue = runParser fromValue (.:) :: FromValue a => Object -> Text -> Parser a diff --git a/src/Hpack.hs b/src/Hpack.hs --- a/src/Hpack.hs +++ b/src/Hpack.hs @@ -1,26 +1,47 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} module Hpack ( - hpack +-- | /__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@). + +-- * Version + version + +-- * Running Hpack +, hpack , hpackResult +, printResult , Result(..) , Status(..) + +-- * Options +, defaultOptions +, setTarget +, setDecode +, getOptions , Verbose(..) +, Options(..) , Force(..) -, version -, main -, mainWith -, RunOptions(..) -, defaultRunOptions + #ifdef TEST +, hpackResultWithVersion , header -, hpackWithVersionResult #endif ) where import Control.Monad import Data.Version (Version) import qualified Data.Version as Version +import System.FilePath import System.Environment import System.Exit import System.IO (stderr) @@ -29,18 +50,17 @@ import Paths_hpack (version) import Hpack.Options import Hpack.Config -import Hpack.Run +import Hpack.Render import Hpack.Util import Hpack.Utf8 as Utf8 import Hpack.CabalFile -import Hpack.Yaml programVersion :: Version -> String programVersion v = "hpack version " ++ Version.showVersion v header :: FilePath -> Version -> Hash -> String header p v hash = unlines [ - "-- This file has been generated from " ++ p ++ " by " ++ programVersion v ++ "." + "-- This file has been generated from " ++ takeFileName p ++ " by " ++ programVersion v ++ "." , "--" , "-- see: https://github.com/sol/hpack" , "--" @@ -48,37 +68,55 @@ , "" ] -main :: IO () -main = mainWith packageConfig decodeYaml +data Options = Options { + optionsDecodeOptions :: DecodeOptions +, optionsForce :: Force +, optionsToStdout :: Bool +} -mainWith :: FilePath -> (FilePath -> IO (Either String Value)) -> IO () -mainWith configFile decode = do - result <- getArgs >>= parseOptions configFile +getOptions :: FilePath -> [String] -> IO (Maybe (Verbose, Options)) +getOptions defaultPackageConfig args = do + result <- parseOptions defaultPackageConfig args case result of - PrintVersion -> putStrLn (programVersion version) - PrintNumericVersion -> putStrLn (Version.showVersion version) - Help -> printHelp + PrintVersion -> do + putStrLn (programVersion version) + return Nothing + PrintNumericVersion -> do + putStrLn (Version.showVersion version) + return Nothing + Help -> do + printHelp + return Nothing Run options -> case options of - Options _verbose _force True dir file -> hpackStdOut (RunOptions dir file decode) - Options verbose force False dir file -> hpack (RunOptions dir file decode) verbose force + ParseOptions verbose force toStdout file -> do + return $ Just (verbose, Options defaultDecodeOptions {decodeOptionsTarget = file} force toStdout) ParseError -> do printHelp exitFailure printHelp :: IO () printHelp = do + name <- getProgName Utf8.hPutStrLn stderr $ unlines [ - "Usage: hpack [ --silent ] [ --force | -f ] [ PATH ] [ - ]" - , " hpack --version" - , " hpack --help" + "Usage: " ++ name ++ " [ --silent ] [ --force | -f ] [ PATH ] [ - ]" + , " " ++ name ++ " --version" + , " " ++ name ++ " --help" ] -hpack :: RunOptions -> Verbose -> Force -> IO () -hpack = hpackWithVersion version +hpack :: Verbose -> Options -> IO () +hpack verbose options = hpackResult options >>= printResult verbose -hpackResult :: RunOptions -> Force -> IO Result -hpackResult = hpackWithVersionResult version +defaultOptions :: Options +defaultOptions = Options defaultDecodeOptions NoForce False +setTarget :: FilePath -> Options -> Options +setTarget target options@Options{..} = + options {optionsDecodeOptions = optionsDecodeOptions {decodeOptionsTarget = target}} + +setDecode :: (FilePath -> IO (Either String Value)) -> Options -> Options +setDecode decode options@Options{..} = + options {optionsDecodeOptions = optionsDecodeOptions {decodeOptionsDecode = decode}} + data Result = Result { resultWarnings :: [String] , resultCabalFile :: String @@ -92,20 +130,18 @@ | OutputUnchanged deriving (Eq, Show) -hpackWithVersion :: Version -> RunOptions -> Verbose -> Force -> IO () -hpackWithVersion v options verbose force = do - r <- hpackWithVersionResult v options force - printWarnings (resultWarnings r) - when (verbose == Verbose) $ putStrLn $ - case resultStatus r of - Generated -> "generated " ++ resultCabalFile r - OutputUnchanged -> resultCabalFile r ++ " is up-to-date" - AlreadyGeneratedByNewerHpack -> resultCabalFile r ++ " was generated with a newer version of hpack, please upgrade and try again." - ExistingCabalFileWasModifiedManually -> resultCabalFile r ++ " was modified manually, please use --force to overwrite." +printResult :: Verbose -> Result -> IO () +printResult verbose r = do + printWarnings (resultWarnings r) + when (verbose == Verbose) $ putStrLn $ + case resultStatus r of + Generated -> "generated " ++ resultCabalFile r + OutputUnchanged -> resultCabalFile r ++ " is up-to-date" + AlreadyGeneratedByNewerHpack -> resultCabalFile r ++ " was generated with a newer version of hpack, please upgrade and try again." + ExistingCabalFileWasModifiedManually -> resultCabalFile r ++ " was modified manually, please use --force to overwrite." printWarnings :: [String] -> IO () -printWarnings warnings = do - forM_ warnings $ \warning -> Utf8.hPutStrLn stderr ("WARNING: " ++ warning) +printWarnings = mapM_ $ Utf8.hPutStrLn stderr . ("WARNING: " ++) mkStatus :: [String] -> Version -> CabalFile -> Status mkStatus new v (CabalFile mOldVersion mHash old) = case (mOldVersion, mHash) of @@ -118,10 +154,14 @@ | old == new -> OutputUnchanged | otherwise -> Generated -hpackWithVersionResult :: Version -> RunOptions -> Force -> IO Result -hpackWithVersionResult v options@RunOptions{..} force = do - (warnings, cabalFile, new) <- run options +hpackResult :: Options -> IO Result +hpackResult = hpackResultWithVersion version + +hpackResultWithVersion :: Version -> Options -> IO Result +hpackResultWithVersion v (Options options force toStdout) = do + DecodeResult pkg cabalFile warnings <- readPackageConfig options >>= either die return oldCabalFile <- readCabalFile cabalFile + let new = renderPackage (maybe [] cabalFileContents oldCabalFile) pkg let status = case force of Force -> Generated @@ -129,16 +169,12 @@ case status of Generated -> do let hash = sha256 new - Utf8.writeFile cabalFile (header runOptionsConfigFile v hash ++ new) + if toStdout + then Utf8.putStr new + else Utf8.writeFile cabalFile (header (decodeOptionsTarget options) v hash ++ new) _ -> return () return Result { resultWarnings = warnings , resultCabalFile = cabalFile , resultStatus = status } - -hpackStdOut :: RunOptions -> IO () -hpackStdOut options = do - (warnings, _cabalFile, new) <- run options - Utf8.putStr new - printWarnings warnings diff --git a/src/Hpack/CabalFile.hs b/src/Hpack/CabalFile.hs --- a/src/Hpack/CabalFile.hs +++ b/src/Hpack/CabalFile.hs @@ -28,7 +28,7 @@ parse (splitHeader -> (h, c)) = CabalFile (extractVersion h) (extractHash h) c splitHeader :: String -> ([String], [String]) - splitHeader = fmap (dropWhile null) . span ("--" `isPrefixOf`) . lines + splitHeader = fmap (dropWhile null) . span ("--" `isPrefixOf`) . removeGitConflictMarkers . lines extractHash :: [String] -> Maybe Hash extractHash = extract "-- hash: " Just @@ -51,3 +51,24 @@ parseVersion xs = case [v | (v, "") <- readP_to_S Version.parseVersion xs] of [v] -> Just v _ -> Nothing + +removeGitConflictMarkers :: [String] -> [String] +removeGitConflictMarkers = takeBoth + where + takeBoth input = case break (isPrefixOf marker) input of + (both, _marker : rest) -> both ++ takeOurs rest + (both, []) -> both + where + marker = "<<<<<<< " + + takeOurs input = case break (== marker) input of + (ours, _marker : rest) -> ours ++ dropTheirs rest + (ours, []) -> ours + where + marker = "=======" + + dropTheirs input = case break (isPrefixOf marker) input of + (_theirs, _marker : rest) -> takeBoth rest + (_theirs, []) -> [] + where + marker = ">>>>>>> " diff --git a/src/Hpack/Config.hs b/src/Hpack/Config.hs --- a/src/Hpack/Config.hs +++ b/src/Hpack/Config.hs @@ -13,9 +13,24 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} module Hpack.Config ( - packageConfig +-- | /__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@). + + DecodeOptions(..) +, defaultDecodeOptions +, packageConfig +, DecodeResult(..) , readPackageConfig -, readPackageConfigWith + , renamePackage , packageDependencies , package @@ -36,12 +51,17 @@ , Conditional(..) , Flag(..) , SourceRepository(..) +, BuildType(..) +, GhcProfOption +, GhcjsOption +, CppOption +, CcOption +, LdOption #ifdef TEST , renameDependencies , Empty(..) , getModules , pathsModuleFromPackageName -, BuildType(..) , Cond(..) , LibrarySection(..) @@ -81,7 +101,7 @@ import qualified Hpack.Util as Util import Hpack.Defaults import qualified Hpack.Yaml as Yaml -import Hpack.Dependency +import Hpack.Syntax.Dependency package :: String -> String -> Package package name version = Package { @@ -209,10 +229,10 @@ deriving (Eq, Show) instance FromValue Verbatim where - fromValue v = - VerbatimLiteral <$> fromValue v - <|> VerbatimObject <$> fromValue v - <|> typeMismatch (formatOrList ["String", "Object"]) v + fromValue v = case v of + String s -> return (VerbatimLiteral $ T.unpack s) + Object _ -> VerbatimObject <$> fromValue v + _ -> typeMismatch (formatOrList ["String", "Object"]) v data CommonOptions cSources jsSources a = CommonOptions { commonOptionsSourceDirs :: Maybe (List FilePath) @@ -508,16 +528,37 @@ decodeYaml :: FromValue a => FilePath -> Warnings (Errors IO) a decodeYaml file = lift (ExceptT $ Yaml.decodeYaml file) >>= decodeValue file -readPackageConfig :: FilePath -> FilePath -> IO (Either String (Package, [String])) -readPackageConfig = readPackageConfigWith Yaml.decodeYaml +data DecodeOptions = DecodeOptions { + decodeOptionsTarget :: FilePath +, decodeOptionsUserDataDir :: Maybe FilePath +, decodeOptionsDecode :: FilePath -> IO (Either String Value) +} -readPackageConfigWith :: (FilePath -> IO (Either String Value)) -> FilePath -> FilePath -> IO (Either String (Package, [String])) -readPackageConfigWith readValue userDataDir file = runExceptT $ runWriterT $ do +defaultDecodeOptions :: DecodeOptions +defaultDecodeOptions = DecodeOptions packageConfig Nothing Yaml.decodeYaml + +data DecodeResult = DecodeResult { + decodeResultPackage :: Package +, decodeResultCabalFile :: FilePath +, decodeResultWarnings :: [String] +} deriving (Eq, Show) + +readPackageConfig :: DecodeOptions -> IO (Either String DecodeResult) +readPackageConfig (DecodeOptions file mUserDataDir readValue) = runExceptT $ fmap addCabalFile . runWriterT $ do value <- lift . ExceptT $ readValue file config <- decodeValue file value dir <- liftIO $ takeDirectory <$> canonicalizePath file + userDataDir <- liftIO $ maybe (getAppUserDataDirectory "hpack") return mUserDataDir toPackage userDataDir dir config + where + addCabalFile :: (Package, [String]) -> DecodeResult + addCabalFile (pkg, warnings) = DecodeResult pkg (takeDirectory_ file (packageName pkg ++ ".cabal")) warnings + takeDirectory_ :: FilePath -> FilePath + takeDirectory_ p + | takeFileName p == p = "" + | otherwise = takeDirectory p + decodeValue :: FromValue a => FilePath -> Value -> Warnings (Errors IO) a decodeValue file value = do (a, unknown) <- lift . ExceptT . return $ first (prefix ++) (Config.decodeValue value) @@ -824,8 +865,8 @@ where parseGithub :: Text -> SourceRepository parseGithub input = case map T.unpack $ T.splitOn "/" input of - [user, repo, subdir] -> - SourceRepository (githubBaseUrl ++ user ++ "/" ++ repo) (Just subdir) + [owner, repo, subdir] -> + SourceRepository (githubBaseUrl ++ owner ++ "/" ++ repo) (Just subdir) _ -> SourceRepository (githubBaseUrl ++ T.unpack input) Nothing homepage :: Maybe String diff --git a/src/Hpack/Defaults.hs b/src/Hpack/Defaults.hs --- a/src/Hpack/Defaults.hs +++ b/src/Hpack/Defaults.hs @@ -25,12 +25,12 @@ type URL = String -defaultsUrl :: Defaults -> URL -defaultsUrl Defaults{..} = "https://raw.githubusercontent.com/" ++ defaultsGithubUser ++ "/" ++ defaultsGithubRepo ++ "/" ++ defaultsRef ++ "/" ++ intercalate "/" defaultsPath +defaultsUrl :: Github -> URL +defaultsUrl Github{..} = "https://raw.githubusercontent.com/" ++ githubOwner ++ "/" ++ githubRepo ++ "/" ++ githubRef ++ "/" ++ intercalate "/" githubPath -defaultsCachePath :: FilePath -> Defaults -> FilePath -defaultsCachePath dir Defaults{..} = joinPath $ - dir : "defaults" : defaultsGithubUser : defaultsGithubRepo : defaultsRef : defaultsPath +defaultsCachePath :: FilePath -> Github -> FilePath +defaultsCachePath dir Github{..} = joinPath $ + dir : "defaults" : githubOwner : githubRepo : githubRef : githubPath data Result = Found | NotFound | Failed String deriving (Eq, Show) @@ -52,15 +52,21 @@ formatStatus (Status code message) = show code ++ " " ++ B.unpack message ensure :: FilePath -> Defaults -> IO (Either String FilePath) -ensure dir defaults = - ensureFile file url >>= \ case - Found -> return (Right file) - NotFound -> return (Left notFound) - Failed err -> return (Left err) +ensure dir = \ case + DefaultsGithub defaults -> do + let + url = defaultsUrl defaults + file = defaultsCachePath dir defaults + ensureFile file url >>= \ case + Found -> return (Right file) + NotFound -> return (Left $ notFound url) + Failed err -> return (Left err) + DefaultsLocal (Local file) -> + doesFileExist file >>= \ case + True -> return (Right file) + False -> return (Left $ notFound file) where - url = defaultsUrl defaults - file = defaultsCachePath dir defaults - notFound = "Invalid value for \"defaults\"! File " ++ url ++ " does not exist!" + notFound file = "Invalid value for \"defaults\"! File " ++ file ++ " does not exist!" ensureFile :: FilePath -> URL -> IO Result ensureFile file url = do diff --git a/src/Hpack/Dependency.hs b/src/Hpack/Dependency.hs deleted file mode 100644 --- a/src/Hpack/Dependency.hs +++ /dev/null @@ -1,170 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeFamilies #-} -module Hpack.Dependency ( - Dependencies(..) -, DependencyVersion(..) -, SourceDependency(..) -, GitRef -, GitUrl -, githubBaseUrl -, scientificToVersion -) where - -import qualified Data.Text as T -import Text.PrettyPrint (renderStyle, Style(..), Mode(..)) -import Control.Monad -import qualified Distribution.Compat.ReadP as D -import qualified Distribution.Package as D -import qualified Distribution.Text as D -import qualified Distribution.Version as D -import Data.Map.Lazy (Map) -import qualified Data.Map.Lazy as Map -import Data.Scientific -import Control.Applicative -import GHC.Exts - -import Data.Aeson.Config.FromValue - -githubBaseUrl :: String -githubBaseUrl = "https://github.com/" - -newtype Dependencies = Dependencies { - unDependencies :: Map String DependencyVersion -} deriving (Eq, Show, Monoid) - -instance IsList Dependencies where - type Item Dependencies = (String, DependencyVersion) - fromList = Dependencies . Map.fromList - toList = Map.toList . unDependencies - -data DependencyVersion = - AnyVersion - | VersionRange String - | SourceDependency SourceDependency - deriving (Eq, Show) - -data SourceDependency = GitRef GitUrl GitRef (Maybe FilePath) | Local FilePath - deriving (Eq, Show) - -type GitUrl = String -type GitRef = String - -instance FromValue Dependencies where - fromValue v = case v of - String _ -> dependenciesFromList . return <$> fromValue v - Array _ -> dependenciesFromList <$> fromValue v - Object _ -> Dependencies <$> fromValue v - _ -> typeMismatch "Array, Object, or String" v - where - fromDependency :: Dependency -> (String, DependencyVersion) - fromDependency (Dependency name version) = (name, version) - - dependenciesFromList :: [Dependency] -> Dependencies - dependenciesFromList = Dependencies . Map.fromList . map fromDependency - - -instance FromValue DependencyVersion where - fromValue v = case v of - Null -> return AnyVersion - Object _ -> SourceDependency <$> fromValue v - Number n -> return (scientificToDependencyVersion n) - String s -> parseVersionRange ("== " ++ input) <|> parseVersionRange input - where - input = T.unpack s - - _ -> typeMismatch "Null, Object, Number, or String" v - -scientificToDependencyVersion :: Scientific -> DependencyVersion -scientificToDependencyVersion n = VersionRange ("==" ++ version) - where - version = scientificToVersion n - -scientificToVersion :: Scientific -> String -scientificToVersion n = version - where - version = formatScientific Fixed (Just decimalPlaces) n - decimalPlaces - | e < 0 = abs e - | otherwise = 0 - e = base10Exponent n - -instance FromValue SourceDependency where - fromValue = withObject (\o -> let - local :: Parser SourceDependency - local = Local <$> o .: "path" - - git :: Parser SourceDependency - git = GitRef <$> url <*> ref <*> subdir - - url :: Parser String - url = - ((githubBaseUrl ++) <$> o .: "github") - <|> (o .: "git") - <|> fail "neither key \"git\" nor key \"github\" present" - - ref :: Parser String - ref = o .: "ref" - - subdir :: Parser (Maybe FilePath) - subdir = o .:? "subdir" - - in local <|> git) - -data Dependency = Dependency { - _dependencyName :: String -, _dependencyVersion :: DependencyVersion -} deriving (Eq, Show) - -instance FromValue Dependency where - fromValue v = case v of - String s -> uncurry Dependency <$> parseDependency (T.unpack s) - Object o -> addSourceDependency o - _ -> typeMismatch "Object or String" v - where - addSourceDependency o = Dependency <$> name <*> (SourceDependency <$> fromValue v) - where - name :: Parser String - name = o .: "name" - -depPkgName :: D.Dependency -> String -#if MIN_VERSION_Cabal(2,0,0) -depPkgName = D.unPackageName . D.depPkgName -#else -depPkgName (D.Dependency (D.PackageName name) _) = name -#endif - -depVerRange :: D.Dependency -> D.VersionRange -#if MIN_VERSION_Cabal(2,0,0) -depVerRange = D.depVerRange -#else -depVerRange (D.Dependency _ versionRange) = versionRange -#endif - -parseDependency :: Monad m => String -> m (String, DependencyVersion) -parseDependency = liftM fromCabal . parseCabalDependency - where - fromCabal :: D.Dependency -> (String, DependencyVersion) - fromCabal d = (depPkgName d, dependencyVersionFromCabal $ depVerRange d) - -dependencyVersionFromCabal :: D.VersionRange -> DependencyVersion -dependencyVersionFromCabal versionRange - | D.isAnyVersion versionRange = AnyVersion - | otherwise = VersionRange . renderStyle style . D.disp $ versionRange - where - style = Style OneLineMode 0 0 - -parseCabalDependency :: Monad m => String -> m D.Dependency -parseCabalDependency = cabalParse "dependency" - -parseVersionRange :: Monad m => String -> m DependencyVersion -parseVersionRange = liftM dependencyVersionFromCabal . parseCabalVersionRange - -parseCabalVersionRange :: Monad m => String -> m D.VersionRange -parseCabalVersionRange = cabalParse "constraint" - -cabalParse :: (Monad m, D.Text a) => String -> String -> m a -cabalParse subject s = case [d | (d, "") <- D.readP_to_S D.parse s] of - [d] -> return d - _ -> fail $ unwords ["invalid", subject, show s] diff --git a/src/Hpack/FormattingHints.hs b/src/Hpack/FormattingHints.hs deleted file mode 100644 --- a/src/Hpack/FormattingHints.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ViewPatterns #-} -module Hpack.FormattingHints ( - FormattingHints (..) -, sniffFormattingHints -#ifdef TEST -, extractFieldOrder -, extractSectionsFieldOrder -, breakLines -, unindent -, sniffAlignment -, splitField -, sniffIndentation -, sniffCommaStyle -#endif -) where - -import Data.Char -import Data.Maybe -import Data.List -import Control.Applicative - -import Hpack.Render - -data FormattingHints = FormattingHints { - formattingHintsFieldOrder :: [String] -, formattingHintsSectionsFieldOrder :: [(String, [String])] -, formattingHintsAlignment :: Maybe Alignment -, formattingHintsRenderSettings :: RenderSettings -} deriving (Eq, Show) - -sniffFormattingHints :: String -> FormattingHints -sniffFormattingHints (breakLines -> input) = FormattingHints { - formattingHintsFieldOrder = extractFieldOrder input -, formattingHintsSectionsFieldOrder = extractSectionsFieldOrder input -, formattingHintsAlignment = sniffAlignment input -, formattingHintsRenderSettings = sniffRenderSettings input -} - -breakLines :: String -> [String] -breakLines = filter (not . null) . map (reverse . dropWhile isSpace . reverse) . lines - -extractFieldOrder :: [String] -> [String] -extractFieldOrder = map fst . catMaybes . map splitField - -extractSectionsFieldOrder :: [String] -> [(String, [String])] -extractSectionsFieldOrder = map (fmap extractFieldOrder) . splitSections - where - splitSections input = case break startsWithSpace input of - ([], []) -> [] - (xs, ys) -> case span startsWithSpace ys of - (fields, zs) -> case reverse xs of - name : _ -> (name, unindent fields) : splitSections zs - _ -> splitSections zs - - startsWithSpace :: String -> Bool - startsWithSpace xs = case xs of - y : _ -> isSpace y - _ -> False - -unindent :: [String] -> [String] -unindent input = map (drop indentation) input - where - indentation = minimum $ map (length . takeWhile isSpace) input - -sniffAlignment :: [String] -> Maybe Alignment -sniffAlignment input = case nub . catMaybes . map indentation . catMaybes . map splitField $ input of - [n] -> Just (Alignment n) - _ -> Nothing - where - - indentation :: (String, String) -> Maybe Int - indentation (name, value) = case span isSpace value of - (_, "") -> Nothing - (xs, _) -> (Just . succ . length $ name ++ xs) - -splitField :: String -> Maybe (String, String) -splitField field = case span isNameChar field of - (xs, ':':ys) -> Just (xs, ys) - _ -> Nothing - where - isNameChar = (`elem` nameChars) - nameChars = ['a'..'z'] ++ ['A'..'Z'] ++ "-" - -sniffIndentation :: [String] -> Maybe Int -sniffIndentation input = sniffFrom "library" <|> sniffFrom "executable" - where - sniffFrom :: String -> Maybe Int - sniffFrom section = case findSection . removeEmptyLines $ input of - _ : x : _ -> Just . length $ takeWhile isSpace x - _ -> Nothing - where - findSection = dropWhile (not . isPrefixOf section) - - removeEmptyLines :: [String] -> [String] - removeEmptyLines = filter $ any (not . isSpace) - -sniffCommaStyle :: [String] -> Maybe CommaStyle -sniffCommaStyle input - | any startsWithComma input = Just LeadingCommas - | any (startsWithComma . reverse) input = Just TrailingCommas - | otherwise = Nothing - where - startsWithComma = isPrefixOf "," . dropWhile isSpace - -sniffRenderSettings :: [String] -> RenderSettings -sniffRenderSettings input = RenderSettings indentation fieldAlignment commaStyle - where - indentation = fromMaybe (renderSettingsIndentation defaultRenderSettings) (sniffIndentation input) - fieldAlignment = renderSettingsFieldAlignment defaultRenderSettings - commaStyle = fromMaybe (renderSettingsCommaStyle defaultRenderSettings) (sniffCommaStyle input) diff --git a/src/Hpack/Options.hs b/src/Hpack/Options.hs --- a/src/Hpack/Options.hs +++ b/src/Hpack/Options.hs @@ -1,11 +1,10 @@ {-# LANGUAGE LambdaCase #-} module Hpack.Options where -import Control.Monad import System.FilePath import System.Directory -data ParseResult = Help | PrintVersion | PrintNumericVersion | Run Options | ParseError +data ParseResult = Help | PrintVersion | PrintNumericVersion | Run ParseOptions | ParseError deriving (Eq, Show) data Verbose = Verbose | NoVerbose @@ -14,50 +13,55 @@ data Force = Force | NoForce deriving (Eq, Show) -data Options = Options { - optionsVerbose :: Verbose -, optionsForce :: Force -, optionsToStdout :: Bool -, optionsConfigDir :: Maybe FilePath -, optionsConfigFile :: FilePath +data ParseOptions = ParseOptions { + parseOptionsVerbose :: Verbose +, parseOptionsForce :: Force +, parseOptionsToStdout :: Bool +, parseOptionsTarget :: FilePath } deriving (Eq, Show) parseOptions :: FilePath -> [String] -> IO ParseResult -parseOptions defaultConfigFile xs = case xs of +parseOptions defaultTarget = \ case ["--version"] -> return PrintVersion ["--numeric-version"] -> return PrintNumericVersion ["--help"] -> return Help - _ -> case targets of - Just (target, toStdout) -> do - (dir, file) <- splitDirectory defaultConfigFile target - return $ Run (Options verbose force toStdout dir file) - Nothing -> return ParseError + args -> case targets of + Right (target, toStdout) -> do + file <- expandTarget defaultTarget target + let + options + | toStdout = ParseOptions NoVerbose Force toStdout file + | otherwise = ParseOptions verbose force toStdout file + return (Run options) + Left err -> return err where silentFlag = "--silent" forceFlags = ["--force", "-f"] flags = silentFlag : forceFlags - verbose = if silentFlag `elem` xs then NoVerbose else Verbose - force = if any (`elem` xs) forceFlags then Force else NoForce - ys = filter (`notElem` flags) xs + verbose = if silentFlag `elem` args then NoVerbose else Verbose + force = if any (`elem` args) forceFlags then Force else NoForce + ys = filter (`notElem` flags) args + targets :: Either ParseResult (Maybe FilePath, Bool) targets = case ys of - ["-"] -> Just (Nothing, True) - ["-", "-"] -> Nothing - [dir] -> Just (Just dir, False) - [dir, "-"] -> Just (Just dir, True) - [] -> Just (Nothing, False) - _ -> Nothing + ["-"] -> Right (Nothing, True) + ["-", "-"] -> Left ParseError + [path] -> Right (Just path, False) + [path, "-"] -> Right (Just path, True) + [] -> Right (Nothing, False) + _ -> Left ParseError -splitDirectory :: FilePath -> Maybe FilePath -> IO (Maybe FilePath, FilePath) -splitDirectory defaultFileName = \ case - Nothing -> return (Nothing, defaultFileName) - (Just p) -> do - isDirectory <- doesDirectoryExist p - return $ if isDirectory - then (Just p, defaultFileName) - else let - file = takeFileName p - dir = takeDirectory p - in (guard (p /= file) >> Just dir, if null file then defaultFileName else file) +expandTarget :: FilePath -> Maybe FilePath -> IO FilePath +expandTarget defaultTarget = \ case + Nothing -> return defaultTarget + Just "" -> return defaultTarget + Just target -> do + isFile <- doesFileExist target + isDirectory <- doesDirectoryExist target + return $ case takeFileName target of + _ | isFile -> target + _ | isDirectory -> target defaultTarget + "" -> target defaultTarget + _ -> target diff --git a/src/Hpack/Render.hs b/src/Hpack/Render.hs --- a/src/Hpack/Render.hs +++ b/src/Hpack/Render.hs @@ -1,133 +1,400 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} module Hpack.Render ( --- * AST - Element (..) -, Value (..) +-- | /__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@). --- * Render -, RenderSettings (..) -, CommaStyle (..) + renderPackage +, renderPackageWith , defaultRenderSettings -, Alignment (..) -, Nesting -, render - --- * Utils -, sortFieldsBy - +, RenderSettings(..) +, Alignment(..) +, CommaStyle(..) #ifdef TEST -, Lines (..) -, renderValue -, addSortKey +, renderConditional +, renderLibraryFields +, renderExecutableFields +, renderFlag +, renderSourceRepository +, renderDirectories +, formatDescription #endif ) where -import Data.String +import Control.Monad +import Data.Char +import Data.Maybe import Data.List +import Data.Version +import Data.Map.Lazy (Map) +import qualified Data.Map.Lazy as Map -data Value = - Literal String - | CommaSeparatedList [String] - | LineSeparatedList [String] - | WordList [String] - deriving (Eq, Show) +import Hpack.Util +import Hpack.Config +import Hpack.Syntax.Dependency (scientificToVersion) +import Hpack.Render.Hints +import Hpack.Render.Dsl -data Element = Stanza String [Element] | Group Element Element | Field String Value | Verbatim String - deriving (Eq, Show) +renderPackage :: [String] -> Package -> String +renderPackage oldCabalFile = renderPackageWith settings alignment formattingHintsFieldOrder formattingHintsSectionsFieldOrder + where + FormattingHints{..} = sniffFormattingHints oldCabalFile + alignment = fromMaybe 16 formattingHintsAlignment + settings = formattingHintsRenderSettings -data Lines = SingleLine String | MultipleLines [String] - deriving (Eq, Show) +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) $ sortSectionFields sectionsFieldOrder stanzas -data CommaStyle = LeadingCommas | TrailingCommas - deriving (Eq, Show) + header :: [String] + header = concatMap (render settings {renderSettingsFieldAlignment = headerFieldsAlignment} 0) (filterVerbatim packageVerbatim $ headerFields) -newtype Nesting = Nesting Int - deriving (Eq, Show, Num, Enum) + extraSourceFiles :: Element + extraSourceFiles = Field "extra-source-files" (LineSeparatedList packageExtraSourceFiles) -newtype Alignment = Alignment Int - deriving (Eq, Show, Num) + extraDocFiles :: Element + extraDocFiles = Field "extra-doc-files" (LineSeparatedList packageExtraDocFiles) -data RenderSettings = RenderSettings { - renderSettingsIndentation :: Int -, renderSettingsFieldAlignment :: Alignment -, renderSettingsCommaStyle :: CommaStyle -} deriving (Eq, Show) + dataFiles :: Element + dataFiles = Field "data-files" (LineSeparatedList packageDataFiles) -defaultRenderSettings :: RenderSettings -defaultRenderSettings = RenderSettings 2 0 LeadingCommas + sourceRepository :: [Element] + sourceRepository = maybe [] (return . renderSourceRepository) packageSourceRepository -render :: RenderSettings -> Nesting -> Element -> [String] -render settings nesting (Stanza name elements) = indent settings nesting name : renderElements settings (succ nesting) elements -render settings nesting (Group a b) = render settings nesting a ++ render settings nesting b -render settings nesting (Field name value) = renderField settings nesting name value -render settings nesting (Verbatim str) = map (indent settings nesting) (lines str) + customSetup :: [Element] + customSetup = maybe [] (return . renderCustomSetup) packageCustomSetup -renderElements :: RenderSettings -> Nesting -> [Element] -> [String] -renderElements settings nesting = concatMap (render settings nesting) + library :: [Element] + library = maybe [] (return . renderLibrary) packageLibrary -renderField :: RenderSettings -> Nesting -> String -> Value -> [String] -renderField settings@RenderSettings{..} nesting name value = case renderValue settings value of - SingleLine "" -> [] - SingleLine x -> [indent settings nesting (name ++ ": " ++ padding ++ x)] - MultipleLines [] -> [] - MultipleLines xs -> (indent settings nesting name ++ ":") : map (indent settings $ succ nesting) xs + stanzas :: [Element] + stanzas = addVerbatim packageVerbatim $ + extraSourceFiles + : extraDocFiles + : dataFiles + : sourceRepository + ++ concat [ + customSetup + , map renderFlag packageFlags + , library + , renderInternalLibraries packageInternalLibraries + , renderExecutables packageExecutables + , renderTests packageTests + , renderBenchmarks packageBenchmarks + ] + + headerFields :: [Element] + headerFields = sortFieldsBy existingFieldOrder . mapMaybe (\(name, value) -> Field name . Literal <$> value) $ [ + ("name", Just packageName) + , ("version", Just packageVersion) + , ("synopsis", packageSynopsis) + , ("description", (formatDescription 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) + , ("tested-with", packageTestedWith) + , ("build-type", Just (show packageBuildType)) + , ("cabal-version", cabalVersion) + ] + + formatList :: [String] -> Maybe String + formatList xs = guard (not $ null xs) >> (Just $ intercalate separator xs) + where + separator = let Alignment n = headerFieldsAlignment in ",\n" ++ replicate n ' ' + + cabalVersion :: Maybe String + cabalVersion = (">= " ++) . showVersion <$> maximum [ + Just (makeVersion [1,10]) + , packageCabalVersion + , packageLibrary >>= libraryCabalVersion + , internalLibsCabalVersion packageInternalLibraries + , executablesCabalVersion packageExecutables + , executablesCabalVersion packageTests + , executablesCabalVersion packageBenchmarks + ] + where + packageCabalVersion :: Maybe Version + packageCabalVersion = maximum [ + Nothing + , makeVersion [1,24] <$ packageCustomSetup + , makeVersion [1,18] <$ guard (not (null packageExtraDocFiles)) + ] + + libraryCabalVersion :: Section Library -> Maybe Version + libraryCabalVersion sect = maximum [ + makeVersion [1,22] <$ guard hasReexportedModules + , makeVersion [2,0] <$ guard hasSignatures + , makeVersion [2,0] <$ guard hasGeneratedModules + ] + where + hasReexportedModules = any (not . null . libraryReexportedModules) sect + hasSignatures = any (not . null . librarySignatures) sect + hasGeneratedModules = any (not . null . libraryGeneratedModules) sect + + internalLibsCabalVersion :: Map String (Section Library) -> Maybe Version + internalLibsCabalVersion internalLibraries = makeVersion [2,0] <$ guard (not (Map.null internalLibraries)) + + executablesCabalVersion :: Map String (Section Executable) -> Maybe Version + executablesCabalVersion = foldr max Nothing . map executableCabalVersion . Map.elems + + executableCabalVersion :: Section Executable -> Maybe Version + executableCabalVersion sect = makeVersion [2,0] <$ guard (executableHasGeneratedModules sect) + + executableHasGeneratedModules :: Section Executable -> Bool + executableHasGeneratedModules = any (not . null . executableGeneratedModules) + +sortSectionFields :: [(String, [String])] -> [Element] -> [Element] +sortSectionFields sectionsFieldOrder = go where - Alignment fieldAlignment = renderSettingsFieldAlignment - padding = replicate (fieldAlignment - length name - 2) ' ' + 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 -renderValue :: RenderSettings -> Value -> Lines -renderValue RenderSettings{..} v = case v of - Literal s -> SingleLine s - WordList ws -> SingleLine $ unwords ws - LineSeparatedList xs -> renderLineSeparatedList renderSettingsCommaStyle xs - CommaSeparatedList xs -> renderCommaSeparatedList renderSettingsCommaStyle xs +formatDescription :: Alignment -> String -> String +formatDescription (Alignment 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 ' ' -renderLineSeparatedList :: CommaStyle -> [String] -> Lines -renderLineSeparatedList style = MultipleLines . map (padding ++) + emptyLineToDot xs + | isEmptyLine xs = "." + | otherwise = xs + + 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 - padding = case style of - LeadingCommas -> " " - TrailingCommas -> "" + description = maybe [] (return . Field "description" . Literal) flagDescription -renderCommaSeparatedList :: CommaStyle -> [String] -> Lines -renderCommaSeparatedList style = MultipleLines . case style of - LeadingCommas -> map renderLeadingComma . zip (True : repeat False) - TrailingCommas -> map renderTrailingComma . reverse . zip (True : repeat False) . reverse +renderInternalLibraries :: Map String (Section Library) -> [Element] +renderInternalLibraries = map renderInternalLibrary . Map.toList + +renderInternalLibrary :: (String, Section Library) -> Element +renderInternalLibrary (name, sect) = + Stanza ("library " ++ name) (renderLibrarySection sect) + +renderExecutables :: Map String (Section Executable) -> [Element] +renderExecutables = map renderExecutable . Map.toList + +renderExecutable :: (String, Section Executable) -> Element +renderExecutable (name, sect@(sectionData -> Executable{..})) = + Stanza ("executable " ++ name) (renderExecutableSection [] sect) + +renderTests :: Map String (Section Executable) -> [Element] +renderTests = map renderTest . Map.toList + +renderTest :: (String, Section Executable) -> Element +renderTest (name, sect) = + Stanza ("test-suite " ++ name) + (renderExecutableSection [Field "type" "exitcode-stdio-1.0"] sect) + +renderBenchmarks :: Map String (Section Executable) -> [Element] +renderBenchmarks = map renderBenchmark . Map.toList + +renderBenchmark :: (String, Section Executable) -> Element +renderBenchmark (name, sect) = + Stanza ("benchmark " ++ name) + (renderExecutableSection [Field "type" "exitcode-stdio-1.0"] sect) + +renderExecutableSection :: [Element] -> Section Executable -> [Element] +renderExecutableSection extraFields = renderSection renderExecutableFields extraFields [defaultLanguage] + +renderExecutableFields :: Executable -> [Element] +renderExecutableFields Executable{..} = mainIs ++ [otherModules, generatedModules] where - renderLeadingComma :: (Bool, String) -> String - renderLeadingComma (isFirst, x) - | isFirst = " " ++ x - | otherwise = ", " ++ x + mainIs = maybe [] (return . Field "main-is" . Literal) executableMain + otherModules = renderOtherModules executableOtherModules + generatedModules = renderGeneratedModules executableGeneratedModules - renderTrailingComma :: (Bool, String) -> String - renderTrailingComma (isLast, x) - | isLast = x - | otherwise = x ++ "," +renderCustomSetup :: CustomSetup -> Element +renderCustomSetup CustomSetup{..} = + Stanza "custom-setup" [renderDependencies "setup-depends" customSetupDependencies] -instance IsString Value where - fromString = Literal +renderLibrary :: Section Library -> Element +renderLibrary sect = Stanza "library" $ renderLibrarySection sect -indent :: RenderSettings -> Nesting -> String -> String -indent RenderSettings{..} (Nesting nesting) s = replicate (nesting * renderSettingsIndentation) ' ' ++ s +renderLibrarySection :: Section Library -> [Element] +renderLibrarySection = renderSection renderLibraryFields [] [defaultLanguage] -sortFieldsBy :: [String] -> [Element] -> [Element] -sortFieldsBy existingFieldOrder = - map snd - . sortOn fst - . addSortKey - . map (\a -> (existingIndex a, a)) +renderLibraryFields :: Library -> [Element] +renderLibraryFields Library{..} = + maybe [] (return . renderExposed) libraryExposed ++ [ + renderExposedModules libraryExposedModules + , renderOtherModules libraryOtherModules + , renderGeneratedModules libraryGeneratedModules + , renderReexportedModules libraryReexportedModules + , renderSignatures librarySignatures + ] + +renderExposed :: Bool -> Element +renderExposed = Field "exposed" . Literal . show + +renderSection :: (a -> [Element]) -> [Element] -> [Element] -> Section a -> [Element] +renderSection renderSectionData extraFieldsStart extraFieldsEnd Section{..} = addVerbatim sectionVerbatim $ + extraFieldsStart + ++ renderSectionData sectionData ++ [ + renderDirectories "hs-source-dirs" sectionSourceDirs + , renderDefaultExtensions sectionDefaultExtensions + , renderOtherExtensions sectionOtherExtensions + , renderGhcOptions sectionGhcOptions + , renderGhcProfOptions sectionGhcProfOptions + , renderGhcjsOptions sectionGhcjsOptions + , renderCppOptions sectionCppOptions + , renderCcOptions sectionCcOptions + , renderDirectories "include-dirs" sectionIncludeDirs + , Field "install-includes" (LineSeparatedList sectionInstallIncludes) + , Field "c-sources" (LineSeparatedList sectionCSources) + , Field "js-sources" (LineSeparatedList sectionJsSources) + , renderDirectories "extra-lib-dirs" sectionExtraLibDirs + , Field "extra-libraries" (LineSeparatedList sectionExtraLibraries) + , renderDirectories "extra-frameworks-dirs" sectionExtraFrameworksDirs + , Field "frameworks" (LineSeparatedList sectionFrameworks) + , renderLdOptions sectionLdOptions + , renderDependencies "build-depends" sectionDependencies + , Field "pkgconfig-depends" (CommaSeparatedList sectionPkgConfigDependencies) + , renderDependencies "build-tools" sectionBuildTools + ] + ++ maybe [] (return . renderBuildable) sectionBuildable + ++ map (renderConditional renderSectionData) sectionConditionals + ++ extraFieldsEnd + +addVerbatim :: [Verbatim] -> [Element] -> [Element] +addVerbatim verbatim fields = filterVerbatim verbatim fields ++ renderVerbatim verbatim + +filterVerbatim :: [Verbatim] -> [Element] -> [Element] +filterVerbatim verbatim = filter p where - existingIndex :: Element -> Maybe Int - existingIndex (Field name _) = name `elemIndex` existingFieldOrder - existingIndex _ = Nothing + p :: Element -> Bool + p = \ case + Field name _ -> name `notElem` fields + _ -> True + fields = concatMap verbatimFieldNames verbatim -addSortKey :: [(Maybe Int, a)] -> [((Int, Int), a)] -addSortKey = go (-1) . zip [0..] +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 - go :: Int -> [(Int, (Maybe Int, a))] -> [((Int, Int), a)] - go n xs = case xs of - [] -> [] - (x, (Just y, a)) : ys -> ((y, x), a) : go y ys - (x, (Nothing, a)) : ys -> ((n, x), a) : go n ys + renderPair (key, value) = case value of + VerbatimString s -> case lines s of + [x] -> Field key (Literal x) + xs -> Field key (LineSeparatedList xs) + VerbatimNumber n -> Field key (Literal $ scientificToVersion n) + VerbatimBool b -> Field key (Literal $ show b) + VerbatimNull -> Field key (Literal "") + +renderConditional :: (a -> [Element]) -> Conditional (Section a) -> 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 " ++ condition) (renderSection renderSectionData [] [] sect) + +defaultLanguage :: Element +defaultLanguage = Field "default-language" "Haskell2010" + +renderDirectories :: String -> [String] -> Element +renderDirectories name = Field name . LineSeparatedList . replaceDots + where + replaceDots = map replaceDot + replaceDot xs = case xs of + "." -> "./." + _ -> xs + +renderExposedModules :: [String] -> Element +renderExposedModules = Field "exposed-modules" . LineSeparatedList + +renderOtherModules :: [String] -> Element +renderOtherModules = Field "other-modules" . LineSeparatedList + +renderGeneratedModules :: [String] -> Element +renderGeneratedModules = Field "autogen-modules" . LineSeparatedList + +renderReexportedModules :: [String] -> Element +renderReexportedModules = Field "reexported-modules" . LineSeparatedList + +renderSignatures :: [String] -> Element +renderSignatures = Field "signatures" . CommaSeparatedList + +renderDependencies :: String -> Dependencies -> Element +renderDependencies name = Field name . CommaSeparatedList . map renderDependency . Map.toList . unDependencies + +renderDependency :: (String, DependencyVersion) -> String +renderDependency (name, version) = name ++ v + where + v = case version of + AnyVersion -> "" + VersionRange x -> " " ++ x + SourceDependency _ -> "" + +renderGhcOptions :: [GhcOption] -> Element +renderGhcOptions = Field "ghc-options" . WordList + +renderGhcProfOptions :: [GhcProfOption] -> Element +renderGhcProfOptions = Field "ghc-prof-options" . WordList + +renderGhcjsOptions :: [GhcjsOption] -> Element +renderGhcjsOptions = Field "ghcjs-options" . WordList + +renderCppOptions :: [CppOption] -> Element +renderCppOptions = Field "cpp-options" . WordList + +renderCcOptions :: [CcOption] -> Element +renderCcOptions = Field "cc-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" . WordList + +renderOtherExtensions :: [String] -> Element +renderOtherExtensions = Field "other-extensions" . WordList diff --git a/src/Hpack/Render/Dsl.hs b/src/Hpack/Render/Dsl.hs new file mode 100644 --- /dev/null +++ b/src/Hpack/Render/Dsl.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Hpack.Render.Dsl ( +-- * AST + Element (..) +, Value (..) + +-- * Render +, RenderSettings (..) +, CommaStyle (..) +, defaultRenderSettings +, Alignment (..) +, Nesting +, render + +-- * Utils +, sortFieldsBy + +#ifdef TEST +, Lines (..) +, renderValue +, addSortKey +#endif +) where + +import Data.String +import Data.List + +data Value = + Literal String + | CommaSeparatedList [String] + | LineSeparatedList [String] + | WordList [String] + deriving (Eq, Show) + +data Element = Stanza String [Element] | Group Element Element | Field String Value | Verbatim String + deriving (Eq, Show) + +data Lines = SingleLine String | MultipleLines [String] + deriving (Eq, Show) + +data CommaStyle = LeadingCommas | TrailingCommas + deriving (Eq, Show) + +newtype Nesting = Nesting Int + deriving (Eq, Show, Num, Enum) + +newtype Alignment = Alignment Int + deriving (Eq, Show, Num) + +data RenderSettings = RenderSettings { + renderSettingsIndentation :: Int +, renderSettingsFieldAlignment :: Alignment +, renderSettingsCommaStyle :: CommaStyle +} deriving (Eq, Show) + +defaultRenderSettings :: RenderSettings +defaultRenderSettings = RenderSettings 2 0 LeadingCommas + +render :: RenderSettings -> Nesting -> Element -> [String] +render settings nesting (Stanza name elements) = indent settings nesting name : renderElements settings (succ nesting) elements +render settings nesting (Group a b) = render settings nesting a ++ render settings nesting b +render settings nesting (Field name value) = renderField settings nesting name value +render settings nesting (Verbatim str) = map (indent settings nesting) (lines str) + +renderElements :: RenderSettings -> Nesting -> [Element] -> [String] +renderElements settings nesting = concatMap (render settings nesting) + +renderField :: RenderSettings -> Nesting -> String -> Value -> [String] +renderField settings@RenderSettings{..} nesting name value = case renderValue settings value of + SingleLine "" -> [] + SingleLine x -> [indent settings nesting (name ++ ": " ++ padding ++ x)] + MultipleLines [] -> [] + MultipleLines xs -> (indent settings nesting name ++ ":") : map (indent settings $ succ nesting) xs + where + Alignment fieldAlignment = renderSettingsFieldAlignment + padding = replicate (fieldAlignment - length name - 2) ' ' + +renderValue :: RenderSettings -> Value -> Lines +renderValue RenderSettings{..} v = case v of + Literal s -> SingleLine s + WordList ws -> SingleLine $ unwords ws + LineSeparatedList xs -> renderLineSeparatedList renderSettingsCommaStyle xs + CommaSeparatedList xs -> renderCommaSeparatedList renderSettingsCommaStyle xs + +renderLineSeparatedList :: CommaStyle -> [String] -> Lines +renderLineSeparatedList style = MultipleLines . map (padding ++) + where + padding = case style of + LeadingCommas -> " " + TrailingCommas -> "" + +renderCommaSeparatedList :: CommaStyle -> [String] -> Lines +renderCommaSeparatedList style = MultipleLines . case style of + LeadingCommas -> map renderLeadingComma . zip (True : repeat False) + TrailingCommas -> map renderTrailingComma . reverse . zip (True : repeat False) . reverse + where + renderLeadingComma :: (Bool, String) -> String + renderLeadingComma (isFirst, x) + | isFirst = " " ++ x + | otherwise = ", " ++ x + + renderTrailingComma :: (Bool, String) -> String + renderTrailingComma (isLast, x) + | isLast = x + | otherwise = x ++ "," + +instance IsString Value where + fromString = Literal + +indent :: RenderSettings -> Nesting -> String -> String +indent RenderSettings{..} (Nesting nesting) s = replicate (nesting * renderSettingsIndentation) ' ' ++ s + +sortFieldsBy :: [String] -> [Element] -> [Element] +sortFieldsBy existingFieldOrder = + map snd + . sortOn fst + . addSortKey + . map (\a -> (existingIndex a, a)) + where + existingIndex :: Element -> Maybe Int + existingIndex (Field name _) = name `elemIndex` existingFieldOrder + existingIndex _ = Nothing + +addSortKey :: [(Maybe Int, a)] -> [((Int, Int), a)] +addSortKey = go (-1) . zip [0..] + where + go :: Int -> [(Int, (Maybe Int, a))] -> [((Int, Int), a)] + go n xs = case xs of + [] -> [] + (x, (Just y, a)) : ys -> ((y, x), a) : go y ys + (x, (Nothing, a)) : ys -> ((n, x), a) : go n ys diff --git a/src/Hpack/Render/Hints.hs b/src/Hpack/Render/Hints.hs new file mode 100644 --- /dev/null +++ b/src/Hpack/Render/Hints.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} +module Hpack.Render.Hints ( + FormattingHints (..) +, sniffFormattingHints +#ifdef TEST +, extractFieldOrder +, extractSectionsFieldOrder +, sanitize +, unindent +, sniffAlignment +, splitField +, sniffIndentation +, sniffCommaStyle +#endif +) where + +import Data.Char +import Data.Maybe +import Data.List +import Control.Applicative + +import Hpack.Render.Dsl + +data FormattingHints = FormattingHints { + formattingHintsFieldOrder :: [String] +, formattingHintsSectionsFieldOrder :: [(String, [String])] +, formattingHintsAlignment :: Maybe Alignment +, formattingHintsRenderSettings :: RenderSettings +} deriving (Eq, Show) + +sniffFormattingHints :: [String] -> FormattingHints +sniffFormattingHints (sanitize -> input) = FormattingHints { + formattingHintsFieldOrder = extractFieldOrder input +, formattingHintsSectionsFieldOrder = extractSectionsFieldOrder input +, formattingHintsAlignment = sniffAlignment input +, formattingHintsRenderSettings = sniffRenderSettings input +} + +sanitize :: [String] -> [String] +sanitize = filter (not . null) . map stripEnd + +stripEnd :: String -> String +stripEnd = reverse . dropWhile isSpace . reverse + +extractFieldOrder :: [String] -> [String] +extractFieldOrder = map fst . catMaybes . map splitField + +extractSectionsFieldOrder :: [String] -> [(String, [String])] +extractSectionsFieldOrder = map (fmap extractFieldOrder) . splitSections + where + splitSections input = case break startsWithSpace input of + ([], []) -> [] + (xs, ys) -> case span startsWithSpace ys of + (fields, zs) -> case reverse xs of + name : _ -> (name, unindent fields) : splitSections zs + _ -> splitSections zs + + startsWithSpace :: String -> Bool + startsWithSpace xs = case xs of + y : _ -> isSpace y + _ -> False + +unindent :: [String] -> [String] +unindent input = map (drop indentation) input + where + indentation = minimum $ map (length . takeWhile isSpace) input + +sniffAlignment :: [String] -> Maybe Alignment +sniffAlignment input = case nub . catMaybes . map indentation . catMaybes . map splitField $ input of + [n] -> Just (Alignment n) + _ -> Nothing + where + + indentation :: (String, String) -> Maybe Int + indentation (name, value) = case span isSpace value of + (_, "") -> Nothing + (xs, _) -> (Just . succ . length $ name ++ xs) + +splitField :: String -> Maybe (String, String) +splitField field = case span isNameChar field of + (xs, ':':ys) -> Just (xs, ys) + _ -> Nothing + where + isNameChar = (`elem` nameChars) + nameChars = ['a'..'z'] ++ ['A'..'Z'] ++ "-" + +sniffIndentation :: [String] -> Maybe Int +sniffIndentation input = sniffFrom "library" <|> sniffFrom "executable" + where + sniffFrom :: String -> Maybe Int + sniffFrom section = case findSection . removeEmptyLines $ input of + _ : x : _ -> Just . length $ takeWhile isSpace x + _ -> Nothing + where + findSection = dropWhile (not . isPrefixOf section) + + removeEmptyLines :: [String] -> [String] + removeEmptyLines = filter $ any (not . isSpace) + +sniffCommaStyle :: [String] -> Maybe CommaStyle +sniffCommaStyle input + | any startsWithComma input = Just LeadingCommas + | any (startsWithComma . reverse) input = Just TrailingCommas + | otherwise = Nothing + where + startsWithComma = isPrefixOf "," . dropWhile isSpace + +sniffRenderSettings :: [String] -> RenderSettings +sniffRenderSettings input = RenderSettings indentation fieldAlignment commaStyle + where + indentation = fromMaybe (renderSettingsIndentation defaultRenderSettings) (sniffIndentation input) + fieldAlignment = renderSettingsFieldAlignment defaultRenderSettings + commaStyle = fromMaybe (renderSettingsCommaStyle defaultRenderSettings) (sniffCommaStyle input) diff --git a/src/Hpack/Run.hs b/src/Hpack/Run.hs deleted file mode 100644 --- a/src/Hpack/Run.hs +++ /dev/null @@ -1,418 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE CPP #-} -module Hpack.Run ( - RunOptions(..) -, defaultRunOptions -, run -, renderPackage -, RenderSettings(..) -, Alignment(..) -, CommaStyle(..) -, defaultRenderSettings -#ifdef TEST -, renderConditional -, renderLibraryFields -, renderExecutableFields -, renderFlag -, renderSourceRepository -, renderDirectories -, formatDescription -#endif -) where - -import Control.Monad -import Data.Char -import Data.Maybe -import Data.List -import System.Exit -import System.FilePath -import System.Directory -import Data.Version -import Data.Map.Lazy (Map) -import qualified Data.Map.Lazy as Map -import qualified Data.Aeson as Aeson - -import Hpack.Util -import Hpack.Config -import Hpack.Dependency (scientificToVersion) -import Hpack.Render -import Hpack.FormattingHints -import Hpack.Yaml - -data RunOptions = RunOptions { - runOptionsConfigDir :: Maybe FilePath -, runOptionsConfigFile :: FilePath -, runOptionsDecode :: FilePath -> IO (Either String Aeson.Value) -} - -defaultRunOptions :: RunOptions -defaultRunOptions = RunOptions Nothing packageConfig decodeYaml - -run :: RunOptions -> IO ([String], FilePath, String) -run (RunOptions mDir c decode) = do - let dir = fromMaybe "" mDir - userDataDir <- getAppUserDataDirectory "hpack" - mPackage <- readPackageConfigWith decode userDataDir (dir c) - case mPackage of - Right (pkg, warnings) -> do - let cabalFile = dir (packageName pkg ++ ".cabal") - - old <- tryReadFile cabalFile - - let - FormattingHints{..} = sniffFormattingHints (fromMaybe "" old) - alignment = fromMaybe 16 formattingHintsAlignment - settings = formattingHintsRenderSettings - - output = renderPackage settings alignment formattingHintsFieldOrder formattingHintsSectionsFieldOrder pkg - - return (warnings, cabalFile, output) - Left err -> die err - -renderPackage :: RenderSettings -> Alignment -> [String] -> [(String, [String])] -> Package -> String -renderPackage settings alignment existingFieldOrder sectionsFieldOrder Package{..} = intercalate "\n" (unlines header : chunks) - where - chunks :: [String] - chunks = map unlines . filter (not . null) . map (render settings 0) $ sortSectionFields sectionsFieldOrder stanzas - - header :: [String] - header = concatMap (render settings {renderSettingsFieldAlignment = alignment} 0) (filterVerbatim packageVerbatim $ fields) - - extraSourceFiles :: Element - extraSourceFiles = Field "extra-source-files" (LineSeparatedList packageExtraSourceFiles) - - extraDocFiles :: Element - extraDocFiles = Field "extra-doc-files" (LineSeparatedList packageExtraDocFiles) - - dataFiles :: Element - dataFiles = Field "data-files" (LineSeparatedList packageDataFiles) - - sourceRepository :: [Element] - sourceRepository = maybe [] (return . renderSourceRepository) packageSourceRepository - - customSetup :: [Element] - customSetup = maybe [] (return . renderCustomSetup) packageCustomSetup - - library :: [Element] - library = maybe [] (return . renderLibrary) packageLibrary - - stanzas :: [Element] - stanzas = addVerbatim packageVerbatim $ - extraSourceFiles - : extraDocFiles - : dataFiles - : sourceRepository - ++ concat [ - customSetup - , map renderFlag packageFlags - , library - , renderInternalLibraries packageInternalLibraries - , renderExecutables packageExecutables - , renderTests packageTests - , renderBenchmarks packageBenchmarks - ] - - fields :: [Element] - fields = sortFieldsBy existingFieldOrder . mapMaybe (\(name, value) -> Field name . Literal <$> 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) - , case packageLicenseFile of - [file] -> ("license-file", Just file) - files -> ("license-files", formatList files) - , ("tested-with", packageTestedWith) - , ("build-type", Just (show packageBuildType)) - , ("cabal-version", cabalVersion) - ] - - formatList :: [String] -> Maybe String - formatList xs = guard (not $ null xs) >> (Just $ intercalate separator xs) - where - separator = let Alignment n = alignment in ",\n" ++ replicate n ' ' - - cabalVersion :: Maybe String - cabalVersion = (">= " ++) . showVersion <$> maximum [ - Just (makeVersion [1,10]) - , packageCabalVersion - , packageLibrary >>= libraryCabalVersion - , internalLibsCabalVersion packageInternalLibraries - , executablesCabalVersion packageExecutables - , executablesCabalVersion packageTests - , executablesCabalVersion packageBenchmarks - ] - where - packageCabalVersion :: Maybe Version - packageCabalVersion = maximum [ - Nothing - , makeVersion [1,24] <$ packageCustomSetup - , makeVersion [1,18] <$ guard (not (null packageExtraDocFiles)) - ] - - libraryCabalVersion :: Section Library -> Maybe Version - libraryCabalVersion sect = maximum [ - makeVersion [1,22] <$ guard hasReexportedModules - , makeVersion [2,0] <$ guard hasSignatures - , makeVersion [2,0] <$ guard hasGeneratedModules - ] - where - hasReexportedModules = any (not . null . libraryReexportedModules) sect - hasSignatures = any (not . null . librarySignatures) sect - hasGeneratedModules = any (not . null . libraryGeneratedModules) sect - - internalLibsCabalVersion :: Map String (Section Library) -> Maybe Version - internalLibsCabalVersion internalLibraries = makeVersion [2,0] <$ guard (not (Map.null internalLibraries)) - - executablesCabalVersion :: Map String (Section Executable) -> Maybe Version - executablesCabalVersion = foldr max Nothing . map executableCabalVersion . Map.elems - - executableCabalVersion :: Section Executable -> Maybe Version - executableCabalVersion sect = makeVersion [2,0] <$ guard (executableHasGeneratedModules sect) - - executableHasGeneratedModules :: Section Executable -> Bool - executableHasGeneratedModules = any (not . null . executableGeneratedModules) - -sortSectionFields :: [(String, [String])] -> [Element] -> [Element] -sortSectionFields 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 :: Alignment -> String -> String -formatDescription (Alignment 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 -> 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) -> [Element] -renderInternalLibraries = map renderInternalLibrary . Map.toList - -renderInternalLibrary :: (String, Section Library) -> Element -renderInternalLibrary (name, sect) = - Stanza ("library " ++ name) (renderLibrarySection sect) - -renderExecutables :: Map String (Section Executable) -> [Element] -renderExecutables = map renderExecutable . Map.toList - -renderExecutable :: (String, Section Executable) -> Element -renderExecutable (name, sect@(sectionData -> Executable{..})) = - Stanza ("executable " ++ name) (renderExecutableSection [] sect) - -renderTests :: Map String (Section Executable) -> [Element] -renderTests = map renderTest . Map.toList - -renderTest :: (String, Section Executable) -> Element -renderTest (name, sect) = - Stanza ("test-suite " ++ name) - (renderExecutableSection [Field "type" "exitcode-stdio-1.0"] sect) - -renderBenchmarks :: Map String (Section Executable) -> [Element] -renderBenchmarks = map renderBenchmark . Map.toList - -renderBenchmark :: (String, Section Executable) -> Element -renderBenchmark (name, sect) = - Stanza ("benchmark " ++ name) - (renderExecutableSection [Field "type" "exitcode-stdio-1.0"] sect) - -renderExecutableSection :: [Element] -> Section Executable -> [Element] -renderExecutableSection extraFields = renderSection renderExecutableFields extraFields [defaultLanguage] - -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 -> Element -renderLibrary sect = Stanza "library" $ renderLibrarySection sect - -renderLibrarySection :: Section Library -> [Element] -renderLibrarySection = renderSection renderLibraryFields [] [defaultLanguage] - -renderLibraryFields :: Library -> [Element] -renderLibraryFields Library{..} = - maybe [] (return . renderExposed) libraryExposed ++ [ - renderExposedModules libraryExposedModules - , renderOtherModules libraryOtherModules - , renderGeneratedModules libraryGeneratedModules - , renderReexportedModules libraryReexportedModules - , renderSignatures librarySignatures - ] - -renderExposed :: Bool -> Element -renderExposed = Field "exposed" . Literal . show - -renderSection :: (a -> [Element]) -> [Element] -> [Element] -> Section a -> [Element] -renderSection renderSectionData extraFieldsStart extraFieldsEnd Section{..} = addVerbatim sectionVerbatim $ - extraFieldsStart - ++ renderSectionData sectionData ++ [ - renderDirectories "hs-source-dirs" sectionSourceDirs - , renderDefaultExtensions sectionDefaultExtensions - , renderOtherExtensions sectionOtherExtensions - , renderGhcOptions sectionGhcOptions - , renderGhcProfOptions sectionGhcProfOptions - , renderGhcjsOptions sectionGhcjsOptions - , renderCppOptions sectionCppOptions - , renderCcOptions sectionCcOptions - , renderDirectories "include-dirs" sectionIncludeDirs - , Field "install-includes" (LineSeparatedList sectionInstallIncludes) - , Field "c-sources" (LineSeparatedList sectionCSources) - , Field "js-sources" (LineSeparatedList sectionJsSources) - , renderDirectories "extra-lib-dirs" sectionExtraLibDirs - , Field "extra-libraries" (LineSeparatedList sectionExtraLibraries) - , renderDirectories "extra-frameworks-dirs" sectionExtraFrameworksDirs - , Field "frameworks" (LineSeparatedList sectionFrameworks) - , renderLdOptions sectionLdOptions - , renderDependencies "build-depends" sectionDependencies - , Field "pkgconfig-depends" (CommaSeparatedList sectionPkgConfigDependencies) - , renderDependencies "build-tools" sectionBuildTools - ] - ++ maybe [] (return . renderBuildable) sectionBuildable - ++ map (renderConditional renderSectionData) sectionConditionals - ++ extraFieldsEnd - -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 value of - VerbatimString s -> case lines s of - [x] -> Field key (Literal x) - xs -> Field key (LineSeparatedList xs) - VerbatimNumber n -> Field key (Literal $ scientificToVersion n) - VerbatimBool b -> Field key (Literal $ show b) - VerbatimNull -> Field key (Literal "") - -renderConditional :: (a -> [Element]) -> Conditional (Section a) -> 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 " ++ condition) (renderSection renderSectionData [] [] sect) - -defaultLanguage :: Element -defaultLanguage = Field "default-language" "Haskell2010" - -renderDirectories :: String -> [String] -> Element -renderDirectories name = Field name . LineSeparatedList . replaceDots - where - replaceDots = map replaceDot - replaceDot xs = case xs of - "." -> "./." - _ -> xs - -renderExposedModules :: [String] -> Element -renderExposedModules = Field "exposed-modules" . LineSeparatedList - -renderOtherModules :: [String] -> Element -renderOtherModules = Field "other-modules" . LineSeparatedList - -renderGeneratedModules :: [String] -> Element -renderGeneratedModules = Field "autogen-modules" . LineSeparatedList - -renderReexportedModules :: [String] -> Element -renderReexportedModules = Field "reexported-modules" . LineSeparatedList - -renderSignatures :: [String] -> Element -renderSignatures = Field "signatures" . CommaSeparatedList - -renderDependencies :: String -> Dependencies -> Element -renderDependencies name = Field name . CommaSeparatedList . map renderDependency . Map.toList . unDependencies - -renderDependency :: (String, DependencyVersion) -> String -renderDependency (name, version) = name ++ v - where - v = case version of - AnyVersion -> "" - VersionRange x -> " " ++ x - SourceDependency _ -> "" - -renderGhcOptions :: [GhcOption] -> Element -renderGhcOptions = Field "ghc-options" . WordList - -renderGhcProfOptions :: [GhcProfOption] -> Element -renderGhcProfOptions = Field "ghc-prof-options" . WordList - -renderGhcjsOptions :: [GhcjsOption] -> Element -renderGhcjsOptions = Field "ghcjs-options" . WordList - -renderCppOptions :: [CppOption] -> Element -renderCppOptions = Field "cpp-options" . WordList - -renderCcOptions :: [CcOption] -> Element -renderCcOptions = Field "cc-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" . WordList - -renderOtherExtensions :: [String] -> Element -renderOtherExtensions = Field "other-extensions" . WordList diff --git a/src/Hpack/Syntax/Defaults.hs b/src/Hpack/Syntax/Defaults.hs --- a/src/Hpack/Syntax/Defaults.hs +++ b/src/Hpack/Syntax/Defaults.hs @@ -1,15 +1,19 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Hpack.Syntax.Defaults ( Defaults(..) +, Github(..) +, Local(..) #ifdef TEST -, isValidUser +, isValidOwner , isValidRepo #endif ) where +import Data.HashMap.Lazy (member) import Data.List import qualified Data.Text as T import System.FilePath.Posix (splitDirectories) @@ -17,35 +21,35 @@ import Data.Aeson.Config.FromValue import Hpack.Syntax.Git -data ParseDefaults = ParseDefaults { - parseDefaultsGithub :: Github -, parseDefaultsRef :: Ref -, parseDefaultsPath :: Maybe Path +data ParseGithub = ParseGithub { + parseGithubGithub :: GithubRepo +, parseGithubRef :: Ref +, parseGithubPath :: Maybe Path } deriving (Generic, FromValue) -data Github = Github { - githubUser :: String -, githubRepo :: String +data GithubRepo = GithubRepo { + githubRepoOwner :: String +, githubRepoName :: String } -instance FromValue Github where +instance FromValue GithubRepo where fromValue = withString parseGithub -parseGithub :: String -> Parser Github +parseGithub :: String -> Parser GithubRepo parseGithub github - | not (isValidUser user) = fail ("invalid user name " ++ show user) + | not (isValidOwner owner) = fail ("invalid owner name " ++ show owner) | not (isValidRepo repo) = fail ("invalid repository name " ++ show repo) - | otherwise = return (Github user repo) + | otherwise = return (GithubRepo owner repo) where - (user, repo) = drop 1 <$> break (== '/') github + (owner, repo) = drop 1 <$> break (== '/') github -isValidUser :: String -> Bool -isValidUser user = - not (null user) - && all isAlphaNumOrHyphen user - && doesNotHaveConsecutiveHyphens user - && doesNotBeginWithHyphen user - && doesNotEndWithHyphen user +isValidOwner :: String -> Bool +isValidOwner owner = + not (null owner) + && all isAlphaNumOrHyphen owner + && doesNotHaveConsecutiveHyphens owner + && doesNotBeginWithHyphen owner + && doesNotEndWithHyphen owner where isAlphaNumOrHyphen = (`elem` '-' : alphaNum) doesNotHaveConsecutiveHyphens = not . isInfixOf "--" @@ -77,38 +81,48 @@ instance FromValue Path where fromValue = withString parsePath - where - parsePath path - | '\\' `elem` path = fail ("rejecting '\\' in " ++ show path ++ ", please use '/' to separate path components") - | ':' `elem` path = fail ("rejecting ':' in " ++ show path) - | "/" `elem` p = fail ("rejecting absolute path " ++ show path) - | ".." `elem` p = fail ("rejecting \"..\" in " ++ show path) - | otherwise = return (Path p) - where - p = splitDirectories path -data Defaults = Defaults { - defaultsGithubUser :: String -, defaultsGithubRepo :: String -, defaultsRef :: String -, defaultsPath :: [FilePath] +parsePath :: String -> Parser Path +parsePath path + | '\\' `elem` path = fail ("rejecting '\\' in " ++ show path ++ ", please use '/' to separate path components") + | ':' `elem` path = fail ("rejecting ':' in " ++ show path) + | "/" `elem` p = fail ("rejecting absolute path " ++ show path) + | ".." `elem` p = fail ("rejecting \"..\" in " ++ show path) + | otherwise = return (Path p) + where + p = splitDirectories path + +data Github = Github { + githubOwner :: String +, githubRepo :: String +, githubRef :: String +, githubPath :: [FilePath] } deriving (Eq, Show) +toDefaultsGithub :: ParseGithub -> Github +toDefaultsGithub ParseGithub{..} = Github { + githubOwner = githubRepoOwner parseGithubGithub + , githubRepo = githubRepoName parseGithubGithub + , githubRef = unRef parseGithubRef + , githubPath = maybe [".hpack", "defaults.yaml"] unPath parseGithubPath + } + +parseDefaultsGithubFromString :: String -> Parser ParseGithub +parseDefaultsGithubFromString xs = case break (== '@') xs of + (github, '@' : ref) -> ParseGithub <$> parseGithub github <*> parseRef ref <*> pure Nothing + _ -> fail ("missing Git reference for " ++ show xs ++ ", the expected format is owner/repo@ref") + +data Local = Local { + localLocal :: String +} deriving (Eq, Show, Generic, FromValue) + +data Defaults = DefaultsLocal Local | DefaultsGithub Github + deriving (Eq, Show) + instance FromValue Defaults where - fromValue v = toDefaults <$> case v of - String s -> parseDefaultsFromString (T.unpack s) - Object _ -> fromValue v + fromValue v = case v of + String s -> DefaultsGithub . toDefaultsGithub <$> parseDefaultsGithubFromString (T.unpack s) + Object o | "local" `member` o -> DefaultsLocal <$> fromValue v + Object o | "github" `member` o -> DefaultsGithub . toDefaultsGithub <$> fromValue v + Object _ -> fail "neither key \"github\" nor key \"local\" present" _ -> typeMismatch "Object or String" v - where - toDefaults :: ParseDefaults -> Defaults - toDefaults ParseDefaults{..} = Defaults { - defaultsGithubUser = githubUser parseDefaultsGithub - , defaultsGithubRepo = githubRepo parseDefaultsGithub - , defaultsRef = unRef parseDefaultsRef - , defaultsPath = maybe [".hpack", "defaults.yaml"] unPath parseDefaultsPath - } - -parseDefaultsFromString :: String -> Parser ParseDefaults -parseDefaultsFromString xs = case break (== '@') xs of - (github, '@' : ref) -> ParseDefaults <$> parseGithub github <*> parseRef ref <*> pure Nothing - _ -> fail ("missing Git reference for " ++ show xs ++ ", the expected format is user/repo@ref") diff --git a/src/Hpack/Syntax/Dependency.hs b/src/Hpack/Syntax/Dependency.hs new file mode 100644 --- /dev/null +++ b/src/Hpack/Syntax/Dependency.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} +module Hpack.Syntax.Dependency ( + Dependencies(..) +, DependencyVersion(..) +, SourceDependency(..) +, GitRef +, GitUrl +, githubBaseUrl +, scientificToVersion +) where + +import qualified Data.Text as T +import Text.PrettyPrint (renderStyle, Style(..), Mode(..)) +import Control.Monad +import qualified Distribution.Compat.ReadP as D +import qualified Distribution.Package as D +import qualified Distribution.Text as D +import qualified Distribution.Version as D +import Data.Map.Lazy (Map) +import qualified Data.Map.Lazy as Map +import Data.Scientific +import Control.Applicative +import GHC.Exts + +import Data.Aeson.Config.FromValue + +githubBaseUrl :: String +githubBaseUrl = "https://github.com/" + +newtype Dependencies = Dependencies { + unDependencies :: Map String DependencyVersion +} deriving (Eq, Show, Monoid) + +instance IsList Dependencies where + type Item Dependencies = (String, DependencyVersion) + fromList = Dependencies . Map.fromList + toList = Map.toList . unDependencies + +data DependencyVersion = + AnyVersion + | VersionRange String + | SourceDependency SourceDependency + deriving (Eq, Show) + +data SourceDependency = GitRef GitUrl GitRef (Maybe FilePath) | Local FilePath + deriving (Eq, Show) + +type GitUrl = String +type GitRef = String + +instance FromValue Dependencies where + fromValue v = case v of + String _ -> dependenciesFromList . return <$> fromValue v + Array _ -> dependenciesFromList <$> fromValue v + Object _ -> Dependencies <$> fromValue v + _ -> typeMismatch "Array, Object, or String" v + where + fromDependency :: Dependency -> (String, DependencyVersion) + fromDependency (Dependency name version) = (name, version) + + dependenciesFromList :: [Dependency] -> Dependencies + dependenciesFromList = Dependencies . Map.fromList . map fromDependency + + +instance FromValue DependencyVersion where + fromValue v = case v of + Null -> return AnyVersion + Object _ -> SourceDependency <$> fromValue v + Number n -> return (scientificToDependencyVersion n) + String s -> parseVersionRange ("== " ++ input) <|> parseVersionRange input + where + input = T.unpack s + + _ -> typeMismatch "Null, Object, Number, or String" v + +scientificToDependencyVersion :: Scientific -> DependencyVersion +scientificToDependencyVersion n = VersionRange ("==" ++ version) + where + version = scientificToVersion n + +scientificToVersion :: Scientific -> String +scientificToVersion n = version + where + version = formatScientific Fixed (Just decimalPlaces) n + decimalPlaces + | e < 0 = abs e + | otherwise = 0 + e = base10Exponent n + +instance FromValue SourceDependency where + fromValue = withObject (\o -> let + local :: Parser SourceDependency + local = Local <$> o .: "path" + + git :: Parser SourceDependency + git = GitRef <$> url <*> ref <*> subdir + + url :: Parser String + url = + ((githubBaseUrl ++) <$> o .: "github") + <|> (o .: "git") + <|> fail "neither key \"git\" nor key \"github\" present" + + ref :: Parser String + ref = o .: "ref" + + subdir :: Parser (Maybe FilePath) + subdir = o .:? "subdir" + + in local <|> git) + +data Dependency = Dependency { + _dependencyName :: String +, _dependencyVersion :: DependencyVersion +} deriving (Eq, Show) + +instance FromValue Dependency where + fromValue v = case v of + String s -> uncurry Dependency <$> parseDependency (T.unpack s) + Object o -> addSourceDependency o + _ -> typeMismatch "Object or String" v + where + addSourceDependency o = Dependency <$> name <*> (SourceDependency <$> fromValue v) + where + name :: Parser String + name = o .: "name" + +depPkgName :: D.Dependency -> String +#if MIN_VERSION_Cabal(2,0,0) +depPkgName = D.unPackageName . D.depPkgName +#else +depPkgName (D.Dependency (D.PackageName name) _) = name +#endif + +depVerRange :: D.Dependency -> D.VersionRange +#if MIN_VERSION_Cabal(2,0,0) +depVerRange = D.depVerRange +#else +depVerRange (D.Dependency _ versionRange) = versionRange +#endif + +parseDependency :: Monad m => String -> m (String, DependencyVersion) +parseDependency = liftM fromCabal . parseCabalDependency + where + fromCabal :: D.Dependency -> (String, DependencyVersion) + fromCabal d = (depPkgName d, dependencyVersionFromCabal $ depVerRange d) + +dependencyVersionFromCabal :: D.VersionRange -> DependencyVersion +dependencyVersionFromCabal versionRange + | D.isAnyVersion versionRange = AnyVersion + | otherwise = VersionRange . renderStyle style . D.disp $ versionRange + where + style = Style OneLineMode 0 0 + +parseCabalDependency :: Monad m => String -> m D.Dependency +parseCabalDependency = cabalParse "dependency" + +parseVersionRange :: Monad m => String -> m DependencyVersion +parseVersionRange = liftM dependencyVersionFromCabal . parseCabalVersionRange + +parseCabalVersionRange :: Monad m => String -> m D.VersionRange +parseCabalVersionRange = cabalParse "constraint" + +cabalParse :: (Monad m, D.Text a) => String -> String -> m a +cabalParse subject s = case [d | (d, "") <- D.readP_to_S D.parse s] of + [d] -> return d + _ -> fail $ unwords ["invalid", subject, show s] diff --git a/src/Hpack/Yaml.hs b/src/Hpack/Yaml.hs --- a/src/Hpack/Yaml.hs +++ b/src/Hpack/Yaml.hs @@ -1,5 +1,19 @@ {-# LANGUAGE RecordWildCards #-} -module Hpack.Yaml where +module Hpack.Yaml ( +-- | /__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@). + + decodeYaml +) where import Data.Yaml hiding (decodeFile, decodeFileEither) import Data.Yaml.Include diff --git a/test/Data/Aeson/Config/FromValueSpec.hs b/test/Data/Aeson/Config/FromValueSpec.hs --- a/test/Data/Aeson/Config/FromValueSpec.hs +++ b/test/Data/Aeson/Config/FromValueSpec.hs @@ -12,7 +12,7 @@ import Data.Aeson.Config.FromValue -shouldDecodeTo :: (HasCallStack, Eq a, Show a, FromValue a) => Value -> DecodeResult a -> Expectation +shouldDecodeTo :: (HasCallStack, Eq a, Show a, FromValue a) => Value -> Result a -> Expectation shouldDecodeTo value expected = decodeValue value `shouldBe` expected shouldDecodeTo_ :: (HasCallStack, Eq a, Show a, FromValue a) => Value -> a -> Expectation @@ -39,7 +39,7 @@ describe "fromValue" $ do context "with a record" $ do let - left :: String -> DecodeResult Person + left :: String -> Result Person left = Left it "decodes a record" $ do [yaml| diff --git a/test/Data/Aeson/Config/TypesSpec.hs b/test/Data/Aeson/Config/TypesSpec.hs --- a/test/Data/Aeson/Config/TypesSpec.hs +++ b/test/Data/Aeson/Config/TypesSpec.hs @@ -12,7 +12,7 @@ describe "fromValue" $ do context "List" $ do let - parseError :: String -> DecodeResult (List Int) + parseError :: String -> Result (List Int) parseError prefix = Left (prefix ++ " - expected Int, encountered String") context "when parsing single values" $ do diff --git a/test/EndToEndSpec.hs b/test/EndToEndSpec.hs --- a/test/EndToEndSpec.hs +++ b/test/EndToEndSpec.hs @@ -17,9 +17,9 @@ import Data.String.Interpolate import Data.String.Interpolate.Util -import qualified Hpack.Run as Hpack -import Hpack.Config (packageConfig, readPackageConfig) -import Hpack.FormattingHints (FormattingHints(..), sniffFormattingHints) +import qualified Hpack.Render as Hpack +import Hpack.Config (packageConfig, readPackageConfig, DecodeOptions(..), DecodeResult(..), defaultDecodeOptions) +import Hpack.Render.Hints (FormattingHints(..), sniffFormattingHints) writeFile :: FilePath -> String -> IO () writeFile file c = touch file >> Prelude.writeFile file c @@ -232,6 +232,22 @@ , file ++ ": Ignoring unrecognized field $.foo" ] + it "accepts defaults from local files" $ do + writeFile "defaults.yaml" [i| + default-extensions: + - RecordWildCards + - DeriveFunctor + |] + [i| + defaults: + local: defaults.yaml + library: {} + |] `shouldRenderTo` library [i| + other-modules: + Paths_foo + default-extensions: RecordWildCards DeriveFunctor + |] + describe "version" $ do it "accepts string" $ do [i| @@ -1165,14 +1181,14 @@ run_ :: FilePath -> String -> IO (Either String ([String], String)) run_ c old = do - mPackage <- readPackageConfig "" c + mPackage <- readPackageConfig defaultDecodeOptions {decodeOptionsTarget = c, decodeOptionsUserDataDir = Just ""} return $ case mPackage of - Right (pkg, warnings) -> + Right (DecodeResult pkg _ warnings) -> let - FormattingHints{..} = sniffFormattingHints old + FormattingHints{..} = sniffFormattingHints (lines old) alignment = fromMaybe 0 formattingHintsAlignment settings = formattingHintsRenderSettings - output = Hpack.renderPackage settings alignment formattingHintsFieldOrder formattingHintsSectionsFieldOrder pkg + output = Hpack.renderPackageWith settings alignment formattingHintsFieldOrder formattingHintsSectionsFieldOrder pkg in Right (warnings, output) Left err -> Left err diff --git a/test/Hpack/CabalFileSpec.hs b/test/Hpack/CabalFileSpec.hs --- a/test/Hpack/CabalFileSpec.hs +++ b/test/Hpack/CabalFileSpec.hs @@ -1,9 +1,12 @@ +{-# LANGUAGE QuasiQuotes #-} module Hpack.CabalFileSpec (spec) where import Helper import Test.QuickCheck import Data.Version (showVersion) import Control.Monad +import Data.String.Interpolate +import Data.String.Interpolate.Util import Paths_hpack (version) @@ -40,3 +43,22 @@ forAll (replicateM 3 positive) $ \xs -> do let v = makeVersion xs parseVersion (showVersion v) `shouldBe` Just v + + describe "removeGitConflictMarkers" $ do + it "remove git conflict markers (git checkout --ours)" $ do + let + input = lines $ unindent [i| + foo + <<<<<<< 4a1ca1694ed77195a080688df9bef53c23045211 + bar2 + ======= + bar1 + >>>>>>> update foo on branch foo + baz + |] + expected = lines $ unindent [i| + foo + bar2 + baz + |] + removeGitConflictMarkers input `shouldBe` expected diff --git a/test/Hpack/ConfigSpec.hs b/test/Hpack/ConfigSpec.hs --- a/test/Hpack/ConfigSpec.hs +++ b/test/Hpack/ConfigSpec.hs @@ -24,7 +24,7 @@ import Data.Either import qualified Data.Map.Lazy as Map -import Hpack.Dependency +import Hpack.Syntax.Dependency import Hpack.Config hiding (package) import qualified Hpack.Config as Config @@ -49,14 +49,17 @@ library :: Library library = Library Nothing [] ["Paths_foo"] [] [] [] +testDecodeOptions :: FilePath -> DecodeOptions +testDecodeOptions file = defaultDecodeOptions {decodeOptionsTarget = file, decodeOptionsUserDataDir = Just undefined} + withPackage :: HasCallStack => String -> IO () -> ((Package, [String]) -> Expectation) -> Expectation withPackage content beforeAction expectation = withTempDirectory $ \dir_ -> do let dir = dir_ "foo" createDirectory dir writeFile (dir "package.yaml") content withCurrentDirectory dir beforeAction - r <- readPackageConfig undefined (dir "package.yaml") - either expectationFailure expectation r + r <- readPackageConfig (testDecodeOptions $ dir "package.yaml") + either expectationFailure (\ (DecodeResult p _ warnings) -> expectation (p, warnings)) r withPackageConfig :: String -> IO () -> (Package -> Expectation) -> Expectation withPackageConfig content beforeAction expectation = withPackage content beforeAction (expectation . fst) @@ -647,7 +650,7 @@ foo: bar foo baz |] - readPackageConfig undefined file `shouldReturn` Left (file ++ ":3:12: could not find expected ':' while scanning a simple key") + readPackageConfig (testDecodeOptions file) `shouldReturn` Left (file ++ ":3:12: could not find expected ':' while scanning a simple key") context "when package.yaml is invalid" $ do it "returns an error" $ \dir -> do @@ -656,12 +659,12 @@ - one - two |] - readPackageConfig undefined file >>= (`shouldSatisfy` isLeft) + readPackageConfig (testDecodeOptions file) >>= (`shouldSatisfy` isLeft) context "when package.yaml does not exist" $ do it "returns an error" $ \dir -> do let file = dir "package.yaml" - readPackageConfig undefined file `shouldReturn` Left [i|#{file}: Yaml file not found: #{file}|] + readPackageConfig (testDecodeOptions file) `shouldReturn` Left [i|#{file}: Yaml file not found: #{file}|] describe "fromValue" $ do context "with Cond" $ do @@ -683,7 +686,7 @@ it "rejects other values" $ do [yaml| 23 - |] `shouldDecodeTo` (Left "Error while parsing $ - expected Boolean or String, encountered Number" :: DecodeResult Cond) + |] `shouldDecodeTo` (Left "Error while parsing $ - expected Boolean or String, encountered Number" :: Result Cond) describe "formatOrList" $ do it "formats a singleton list" $ do diff --git a/test/Hpack/DefaultsSpec.hs b/test/Hpack/DefaultsSpec.hs --- a/test/Hpack/DefaultsSpec.hs +++ b/test/Hpack/DefaultsSpec.hs @@ -4,10 +4,15 @@ import Helper import System.Directory +import Hpack.Syntax.Defaults import Hpack.Defaults spec :: Spec spec = do + describe "ensure" $ do + it "fails when local file does not exist" $ do + ensure undefined (DefaultsLocal $ Local "foo") `shouldReturn` Left "Invalid value for \"defaults\"! File foo does not exist!" + describe "ensureFile" $ do let file = "foo" diff --git a/test/Hpack/DependencySpec.hs b/test/Hpack/DependencySpec.hs deleted file mode 100644 --- a/test/Hpack/DependencySpec.hs +++ /dev/null @@ -1,169 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ConstraintKinds #-} -module Hpack.DependencySpec (spec) where - -import Helper - -import Data.Aeson.Config.FromValueSpec (shouldDecodeTo, shouldDecodeTo_) - -import Data.Aeson.Config.FromValue -import Hpack.Dependency - -left :: String -> DecodeResult Dependencies -left = Left - -spec :: Spec -spec = do - describe "fromValue" $ do - context "when parsing Dependencies" $ do - context "with a scalar" $ do - it "accepts dependencies without constraints" $ do - [yaml| - hpack - |] `shouldDecodeTo_` Dependencies [("hpack", AnyVersion)] - - it "accepts dependencies with constraints" $ do - [yaml| - hpack >= 2 && < 3 - |] `shouldDecodeTo_` Dependencies [("hpack", VersionRange ">=2 && <3")] - - context "with invalid constraint" $ do - it "returns an error message" $ do - [yaml| - hpack == - |] `shouldDecodeTo` left "Error while parsing $ - invalid dependency \"hpack ==\"" - - context "with a list" $ do - it "accepts dependencies without constraints" $ do - [yaml| - - hpack - |] `shouldDecodeTo_` Dependencies [("hpack", AnyVersion)] - - it "accepts dependencies with constraints" $ do - [yaml| - - hpack >= 2 && < 3 - |] `shouldDecodeTo_` Dependencies [("hpack", VersionRange ">=2 && <3")] - - it "accepts git dependencies" $ do - let source = GitRef "https://github.com/sol/hpack" "master" Nothing - [yaml| - - name: hpack - git: https://github.com/sol/hpack - ref: master - |] `shouldDecodeTo_` Dependencies [("hpack", SourceDependency source)] - - it "accepts github dependencies" $ do - let source = GitRef "https://github.com/sol/hpack" "master" Nothing - [yaml| - - name: hpack - github: sol/hpack - ref: master - |] `shouldDecodeTo_` Dependencies [("hpack", SourceDependency source)] - - it "accepts an optional subdirectory for git dependencies" $ do - let source = GitRef "https://github.com/yesodweb/wai" "master" (Just "warp") - [yaml| - - name: warp - github: yesodweb/wai - ref: master - subdir: warp - |] `shouldDecodeTo_` Dependencies [("warp", SourceDependency source)] - - it "accepts local dependencies" $ do - let source = Local "../hpack" - [yaml| - - name: hpack - path: ../hpack - |] `shouldDecodeTo_` Dependencies [("hpack", SourceDependency source)] - - context "when ref is missing" $ do - it "produces accurate error messages" $ do - [yaml| - - name: hpack - git: sol/hpack - ef: master - |] `shouldDecodeTo` left "Error while parsing $[0] - key \"ref\" not present" - - context "when both git and github are missing" $ do - it "produces accurate error messages" $ do - [yaml| - - name: hpack - gi: sol/hpack - ref: master - |] `shouldDecodeTo` left "Error while parsing $[0] - neither key \"git\" nor key \"github\" present" - - context "with a mapping from dependency names to constraints" $ do - it "accepts dependencies without constraints" $ do - [yaml| - array: - |] `shouldDecodeTo_` Dependencies [("array", AnyVersion)] - - it "rejects invalid values" $ do - [yaml| - hpack: [] - |] `shouldDecodeTo` left "Error while parsing $.hpack - expected Null, Object, Number, or String, encountered Array" - - context "when the constraint is a Number" $ do - it "accepts 1" $ do - [yaml| - hpack: 1 - |] `shouldDecodeTo_` Dependencies [("hpack", VersionRange "==1")] - - it "accepts 1.0" $ do - [yaml| - hpack: 1.0 - |] `shouldDecodeTo_` Dependencies [("hpack", VersionRange "==1.0")] - - it "accepts 0.11" $ do - [yaml| - hpack: 0.11 - |] `shouldDecodeTo_` Dependencies [("hpack", VersionRange "==0.11")] - - it "accepts 0.110" $ do - [yaml| - hpack: 0.110 - |] `shouldDecodeTo_` Dependencies [("hpack", VersionRange "==0.110")] - - it "accepts 1e2" $ do - [yaml| - hpack: 1e2 - |] `shouldDecodeTo_` Dependencies [("hpack", VersionRange "==100")] - - context "when the constraint is a String" $ do - it "accepts version ranges" $ do - [yaml| - hpack: '>=2' - |] `shouldDecodeTo_` Dependencies [("hpack", VersionRange ">=2")] - - it "accepts specific versions" $ do - [yaml| - hpack: 0.10.8.2 - |] `shouldDecodeTo_` Dependencies [("hpack", VersionRange "==0.10.8.2")] - - it "accepts wildcard versions" $ do - [yaml| - hpack: 2.* - |] `shouldDecodeTo_` Dependencies [("hpack", VersionRange "==2.*")] - - it "reports parse errors" $ do - [yaml| - hpack: foo - |] `shouldDecodeTo` left "Error while parsing $.hpack - invalid constraint \"foo\"" - - context "when the constraint is an Object" $ do - it "accepts github dependencies" $ do - [yaml| - Cabal: - github: haskell/cabal - ref: d53b6e0d908dfedfdf4337b2935519fb1d689e76 - subdir: Cabal - |] `shouldDecodeTo_` Dependencies [("Cabal", SourceDependency (GitRef "https://github.com/haskell/cabal" "d53b6e0d908dfedfdf4337b2935519fb1d689e76" (Just "Cabal")))] - - it "ignores names in nested hashes" $ do - [yaml| - outer-name: - name: inner-name - path: somewhere - |] `shouldDecodeTo` Right (Dependencies [("outer-name", SourceDependency (Local "somewhere"))], ["$.outer-name.name"]) diff --git a/test/Hpack/FormattingHintsSpec.hs b/test/Hpack/FormattingHintsSpec.hs deleted file mode 100644 --- a/test/Hpack/FormattingHintsSpec.hs +++ /dev/null @@ -1,166 +0,0 @@ -module Hpack.FormattingHintsSpec (spec) where - -import Test.Hspec - -import Hpack.FormattingHints -import Hpack.Render - -spec :: Spec -spec = do - describe "extractFieldOrder" $ do - it "extracts field order hints" $ do - let input = [ - "name: cabalize" - , "version: 0.0.0" - , "license:" - , "license-file: " - , "build-type: Simple" - , "cabal-version: >= 1.10" - ] - extractFieldOrder input `shouldBe` [ - "name" - , "version" - , "license" - , "license-file" - , "build-type" - , "cabal-version" - ] - - describe "extractSectionsFieldOrder" $ do - it "splits input into sections" $ do - let input = [ - "name: cabalize" - , "version: 0.0.0" - , "" - , "library" - , " foo: 23" - , " bar: 42" - , "" - , "executable foo" - , " bar: 23" - , " baz: 42" - ] - extractSectionsFieldOrder input `shouldBe` [("library", ["foo", "bar"]), ("executable foo", ["bar", "baz"])] - - describe "breakLines" $ do - it "breaks input into lines" $ do - let input = unlines [ - "foo" - , "" - , " " - , " bar " - , " baz" - ] - breakLines input `shouldBe` [ - "foo" - , " bar" - , " baz" - ] - - describe "unindent" $ do - it "unindents" $ do - let input = [ - " foo" - , " bar" - , " baz" - ] - unindent input `shouldBe` [ - " foo" - , "bar" - , " baz" - ] - - describe "sniffAlignment" $ do - it "sniffs field alignment from given cabal file" $ do - let input = [ - "name: cabalize" - , "version: 0.0.0" - , "license: MIT" - , "license-file: LICENSE" - , "build-type: Simple" - , "cabal-version: >= 1.10" - ] - sniffAlignment input `shouldBe` Just 16 - - it "ignores fields without a value on the same line" $ do - let input = [ - "name: cabalize" - , "version: 0.0.0" - , "description: " - , " foo" - , " bar" - ] - sniffAlignment input `shouldBe` Just 16 - - describe "splitField" $ do - it "splits fields" $ do - splitField "foo: bar" `shouldBe` Just ("foo", " bar") - - it "accepts fields names with dashes" $ do - splitField "foo-bar: baz" `shouldBe` Just ("foo-bar", " baz") - - it "rejects fields names with spaces" $ do - splitField "foo bar: baz" `shouldBe` Nothing - - it "rejects invalid fields" $ do - splitField "foo bar" `shouldBe` Nothing - - describe "sniffIndentation" $ do - it "sniff alignment from executable section" $ do - let input = [ - "name: foo" - , "version: 0.0.0" - , "" - , "executable foo" - , " build-depends: bar" - ] - sniffIndentation input `shouldBe` Just 4 - - it "sniff alignment from library section" $ do - let input = [ - "name: foo" - , "version: 0.0.0" - , "" - , "library" - , " build-depends: bar" - ] - sniffIndentation input `shouldBe` Just 4 - - it "ignores empty lines" $ do - let input = [ - "executable foo" - , "" - , " build-depends: bar" - ] - sniffIndentation input `shouldBe` Just 4 - - it "ignores whitespace lines" $ do - let input = [ - "executable foo" - , " " - , " build-depends: bar" - ] - sniffIndentation input `shouldBe` Just 4 - - describe "sniffCommaStyle" $ do - it "detects leading commas" $ do - let input = [ - "executable foo" - , " build-depends:" - , " bar" - , " , baz" - ] - sniffCommaStyle input `shouldBe` Just LeadingCommas - - it "detects trailing commas" $ do - let input = [ - "executable foo" - , " build-depends:" - , " bar, " - , " baz" - ] - sniffCommaStyle input `shouldBe` Just TrailingCommas - - context "when detection fails" $ do - it "returns Nothing" $ do - sniffCommaStyle [] `shouldBe` Nothing diff --git a/test/Hpack/OptionsSpec.hs b/test/Hpack/OptionsSpec.hs --- a/test/Hpack/OptionsSpec.hs +++ b/test/Hpack/OptionsSpec.hs @@ -7,80 +7,70 @@ spec :: Spec spec = do describe "parseOptions" $ do - let configFile = "package.yaml" + let defaultTarget = "package.yaml" context "with --help" $ do it "returns Help" $ do - parseOptions configFile ["--help"] `shouldReturn` Help + parseOptions defaultTarget ["--help"] `shouldReturn` Help context "with --version" $ do it "returns PrintVersion" $ do - parseOptions configFile ["--version"] `shouldReturn` PrintVersion + parseOptions defaultTarget ["--version"] `shouldReturn` PrintVersion context "by default" $ do it "returns Run" $ do - parseOptions configFile [] `shouldReturn` Run (Options Verbose NoForce False Nothing configFile) + parseOptions defaultTarget [] `shouldReturn` Run (ParseOptions Verbose NoForce False defaultTarget) it "includes target" $ do - parseOptions configFile ["foo.yaml"] `shouldReturn` Run (Options Verbose NoForce False Nothing "foo.yaml") + parseOptions defaultTarget ["foo.yaml"] `shouldReturn` Run (ParseOptions Verbose NoForce False "foo.yaml") context "with superfluous arguments" $ do it "returns ParseError" $ do - parseOptions configFile ["foo", "bar"] `shouldReturn` ParseError + parseOptions defaultTarget ["foo", "bar"] `shouldReturn` ParseError context "with --silent" $ do it "sets optionsVerbose to NoVerbose" $ do - parseOptions configFile ["--silent"] `shouldReturn` Run (Options NoVerbose NoForce False Nothing configFile) + parseOptions defaultTarget ["--silent"] `shouldReturn` Run (ParseOptions NoVerbose NoForce False defaultTarget) context "with --force" $ do it "sets optionsForce to Force" $ do - parseOptions configFile ["--force"] `shouldReturn` Run (Options Verbose Force False Nothing configFile) + parseOptions defaultTarget ["--force"] `shouldReturn` Run (ParseOptions Verbose Force False defaultTarget) context "with -f" $ do it "sets optionsForce to Force" $ do - parseOptions configFile ["-f"] `shouldReturn` Run (Options Verbose Force False Nothing configFile) + parseOptions defaultTarget ["-f"] `shouldReturn` Run (ParseOptions Verbose Force False defaultTarget) context "with -" $ do - it "sets optionsToStdout to True" $ do - parseOptions configFile ["-"] `shouldReturn` Run (Options Verbose NoForce True Nothing configFile) + it "sets optionsToStdout to True, implies Force and NoVerbose" $ do + parseOptions defaultTarget ["-"] `shouldReturn` Run (ParseOptions NoVerbose Force True defaultTarget) it "rejects - for target" $ do - parseOptions configFile ["-", "-"] `shouldReturn` ParseError - - describe "splitDirectory" $ do - let packageConfig = "package.yaml" - context "when given Nothing" $ do - it "defaults file name to package.yaml" $ do - splitDirectory packageConfig Nothing `shouldReturn` (Nothing, "package.yaml") + parseOptions defaultTarget ["-", "-"] `shouldReturn` ParseError - context "when given a directory" $ do - it "defaults file name to package.yaml" $ do - withTempDirectory $ \dir -> do - splitDirectory packageConfig (Just dir) `shouldReturn` (Just dir, "package.yaml") + describe "expandTarget" $ around_ inTempDirectory $ do + let defaultTarget = "foo.yaml" + context "when target is Nothing" $ do + it "return default file" $ do + expandTarget defaultTarget Nothing `shouldReturn` defaultTarget - context "when given a file name" $ do - it "defaults directory to Nothing" $ do - inTempDirectory $ do - touch "foo.yaml" - splitDirectory packageConfig (Just "foo.yaml") `shouldReturn` (Nothing, "foo.yaml") + context "when target is a file" $ do + it "return file" $ do + let file = "foo/bar.yaml" + touch file + expandTarget defaultTarget (Just file) `shouldReturn` file - context "when given a path to a file" $ do - it "splits directory from file name" $ do - withTempDirectory $ \dir -> do - let file = dir "foo.yaml" - touch file - splitDirectory packageConfig (Just file) `shouldReturn` (Just dir, "foo.yaml") + context "when target is a directory" $ do + it "appends default file" $ do + touch "foo/.placeholder" + expandTarget defaultTarget (Just "foo") `shouldReturn` "foo" defaultTarget - context "when path does not exist" $ do - it "splits path into directory and file name" $ do - inTempDirectory $ do - splitDirectory packageConfig (Just "test/foo.yaml") `shouldReturn` (Just "test", "foo.yaml") + context "when target file does not exist" $ do + it "return target file" $ do + expandTarget defaultTarget (Just "foo/bar") `shouldReturn` "foo/bar" - context "when file does not exist" $ do - it "defaults directory to Nothing" $ do - inTempDirectory $ do - splitDirectory packageConfig (Just "test") `shouldReturn` (Nothing, "test") + context "when target directory does not exist" $ do + it "appends default file" $ do + expandTarget defaultTarget (Just "foo/") `shouldReturn` "foo" defaultTarget - context "when directory does not exist" $ do - it "defaults file name to package.yaml" $ do - inTempDirectory $ do - splitDirectory packageConfig (Just "test/") `shouldReturn` (Just "test", "package.yaml") + context "when target is the empty string" $ do + it "return default file" $ do + expandTarget defaultTarget (Just "") `shouldReturn` defaultTarget diff --git a/test/Hpack/Render/DslSpec.hs b/test/Hpack/Render/DslSpec.hs new file mode 100644 --- /dev/null +++ b/test/Hpack/Render/DslSpec.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE OverloadedStrings #-} +module Hpack.Render.DslSpec where + +import Test.Hspec +import Test.QuickCheck +import Data.List +import Data.Maybe + +import Hpack.Render.Dsl + +spec :: Spec +spec = do + describe "render" $ do + let render_ = render defaultRenderSettings 0 + context "when rendering a Stanza" $ do + it "renders stanza" $ do + let stanza = Stanza "foo" [ + Field "bar" "23" + , Field "baz" "42" + ] + render_ stanza `shouldBe` [ + "foo" + , " bar: 23" + , " baz: 42" + ] + + it "omits empty fields" $ do + let stanza = Stanza "foo" [ + Field "bar" "23" + , Field "baz" (WordList []) + ] + render_ stanza `shouldBe` [ + "foo" + , " bar: 23" + ] + + it "allows to customize indentation" $ do + let stanza = Stanza "foo" [ + Field "bar" "23" + , Field "baz" "42" + ] + render defaultRenderSettings{renderSettingsIndentation = 4} 0 stanza `shouldBe` [ + "foo" + , " bar: 23" + , " baz: 42" + ] + + it "renders nested stanzas" $ do + let input = Stanza "foo" [Field "bar" "23", Stanza "baz" [Field "qux" "42"]] + render_ input `shouldBe` [ + "foo" + , " bar: 23" + , " baz" + , " qux: 42" + ] + + context "when rendering a Field" $ do + context "when rendering a MultipleLines value" $ do + it "takes nesting into account" $ do + let field = Field "foo" (CommaSeparatedList ["bar", "baz"]) + render defaultRenderSettings 1 field `shouldBe` [ + " foo:" + , " bar" + , " , baz" + ] + + context "when value is empty" $ do + it "returns an empty list" $ do + let field = Field "foo" (CommaSeparatedList []) + render_ field `shouldBe` [] + + context "when rendering a SingleLine value" $ do + it "returns a single line" $ do + let field = Field "foo" (Literal "bar") + render_ field `shouldBe` ["foo: bar"] + + it "takes nesting into account" $ do + let field = Field "foo" (Literal "bar") + render defaultRenderSettings 2 field `shouldBe` [" foo: bar"] + + it "takes alignment into account" $ do + let field = Field "foo" (Literal "bar") + render defaultRenderSettings {renderSettingsFieldAlignment = 10} 0 field `shouldBe` ["foo: bar"] + + context "when value is empty" $ do + it "returns an empty list" $ do + let field = Field "foo" (Literal "") + render_ field `shouldBe` [] + + describe "renderValue" $ do + it "renders WordList" $ do + renderValue defaultRenderSettings (WordList ["foo", "bar", "baz"]) `shouldBe` SingleLine "foo bar baz" + + it "renders CommaSeparatedList" $ do + renderValue defaultRenderSettings (CommaSeparatedList ["foo", "bar", "baz"]) `shouldBe` MultipleLines [ + " foo" + , ", bar" + , ", baz" + ] + + it "renders LineSeparatedList" $ do + renderValue defaultRenderSettings (LineSeparatedList ["foo", "bar", "baz"]) `shouldBe` MultipleLines [ + " foo" + , " bar" + , " baz" + ] + + context "when renderSettingsCommaStyle is TrailingCommas" $ do + let settings = defaultRenderSettings{renderSettingsCommaStyle = TrailingCommas} + + it "renders CommaSeparatedList with trailing commas" $ do + renderValue settings (CommaSeparatedList ["foo", "bar", "baz"]) `shouldBe` MultipleLines [ + "foo," + , "bar," + , "baz" + ] + + it "renders LineSeparatedList without padding" $ do + renderValue settings (LineSeparatedList ["foo", "bar", "baz"]) `shouldBe` MultipleLines [ + "foo" + , "bar" + , "baz" + ] + + describe "sortFieldsBy" $ do + let + field name = Field name (Literal $ name ++ " value") + arbitraryFieldNames = sublistOf ["foo", "bar", "baz", "qux", "foobar", "foobaz"] >>= shuffle + + it "sorts fields" $ do + let fields = map field ["baz", "bar", "foo"] + sortFieldsBy ["foo", "bar", "baz"] fields `shouldBe` map field ["foo", "bar", "baz"] + + it "keeps existing field order" $ do + forAll (map field <$> arbitraryFieldNames) $ \fields -> do + forAll arbitraryFieldNames $ \existingFieldOrder -> do + let + existingIndex :: Element -> Maybe Int + existingIndex (Field name _) = name `elemIndex` existingFieldOrder + existingIndex _ = Nothing + + indexes :: [Int] + indexes = mapMaybe existingIndex (sortFieldsBy existingFieldOrder fields) + + sort indexes `shouldBe` indexes + + it "is stable" $ do + forAll arbitraryFieldNames $ \fieldNames -> do + forAll (elements $ subsequences fieldNames) $ \existingFieldOrder -> do + let fields = map field fieldNames + sortFieldsBy existingFieldOrder fields `shouldBe` fields + + describe "addSortKey" $ do + it "adds sort key" $ do + addSortKey [(Nothing, "foo"), (Just 3, "bar"), (Nothing, "baz")] `shouldBe` [((-1, 0), "foo"), ((3, 1), "bar"), ((3, 2), "baz" :: String)] diff --git a/test/Hpack/Render/HintsSpec.hs b/test/Hpack/Render/HintsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Hpack/Render/HintsSpec.hs @@ -0,0 +1,169 @@ +module Hpack.Render.HintsSpec (spec) where + +import Test.Hspec + +import Hpack.Render.Hints +import Hpack.Render.Dsl + +spec :: Spec +spec = do + describe "extractFieldOrder" $ do + it "extracts field order hints" $ do + let input = [ + "name: cabalize" + , "version: 0.0.0" + , "license:" + , "license-file: " + , "build-type: Simple" + , "cabal-version: >= 1.10" + ] + extractFieldOrder input `shouldBe` [ + "name" + , "version" + , "license" + , "license-file" + , "build-type" + , "cabal-version" + ] + + describe "extractSectionsFieldOrder" $ do + it "splits input into sections" $ do + let input = [ + "name: cabalize" + , "version: 0.0.0" + , "" + , "library" + , " foo: 23" + , " bar: 42" + , "" + , "executable foo" + , " bar: 23" + , " baz: 42" + ] + extractSectionsFieldOrder input `shouldBe` [("library", ["foo", "bar"]), ("executable foo", ["bar", "baz"])] + + describe "sanitize" $ do + it "removes empty lines" $ do + let input = [ + "foo" + , "" + , " " + , " bar " + , " baz" + ] + sanitize input `shouldBe` [ + "foo" + , " bar" + , " baz" + ] + + it "removes trailing whitespace" $ do + sanitize ["foo ", "bar "] `shouldBe` ["foo", "bar"] + + describe "unindent" $ do + it "unindents" $ do + let input = [ + " foo" + , " bar" + , " baz" + ] + unindent input `shouldBe` [ + " foo" + , "bar" + , " baz" + ] + + describe "sniffAlignment" $ do + it "sniffs field alignment from given cabal file" $ do + let input = [ + "name: cabalize" + , "version: 0.0.0" + , "license: MIT" + , "license-file: LICENSE" + , "build-type: Simple" + , "cabal-version: >= 1.10" + ] + sniffAlignment input `shouldBe` Just 16 + + it "ignores fields without a value on the same line" $ do + let input = [ + "name: cabalize" + , "version: 0.0.0" + , "description: " + , " foo" + , " bar" + ] + sniffAlignment input `shouldBe` Just 16 + + describe "splitField" $ do + it "splits fields" $ do + splitField "foo: bar" `shouldBe` Just ("foo", " bar") + + it "accepts fields names with dashes" $ do + splitField "foo-bar: baz" `shouldBe` Just ("foo-bar", " baz") + + it "rejects fields names with spaces" $ do + splitField "foo bar: baz" `shouldBe` Nothing + + it "rejects invalid fields" $ do + splitField "foo bar" `shouldBe` Nothing + + describe "sniffIndentation" $ do + it "sniff alignment from executable section" $ do + let input = [ + "name: foo" + , "version: 0.0.0" + , "" + , "executable foo" + , " build-depends: bar" + ] + sniffIndentation input `shouldBe` Just 4 + + it "sniff alignment from library section" $ do + let input = [ + "name: foo" + , "version: 0.0.0" + , "" + , "library" + , " build-depends: bar" + ] + sniffIndentation input `shouldBe` Just 4 + + it "ignores empty lines" $ do + let input = [ + "executable foo" + , "" + , " build-depends: bar" + ] + sniffIndentation input `shouldBe` Just 4 + + it "ignores whitespace lines" $ do + let input = [ + "executable foo" + , " " + , " build-depends: bar" + ] + sniffIndentation input `shouldBe` Just 4 + + describe "sniffCommaStyle" $ do + it "detects leading commas" $ do + let input = [ + "executable foo" + , " build-depends:" + , " bar" + , " , baz" + ] + sniffCommaStyle input `shouldBe` Just LeadingCommas + + it "detects trailing commas" $ do + let input = [ + "executable foo" + , " build-depends:" + , " bar, " + , " baz" + ] + sniffCommaStyle input `shouldBe` Just TrailingCommas + + context "when detection fails" $ do + it "returns Nothing" $ do + sniffCommaStyle [] `shouldBe` Nothing diff --git a/test/Hpack/RenderSpec.hs b/test/Hpack/RenderSpec.hs --- a/test/Hpack/RenderSpec.hs +++ b/test/Hpack/RenderSpec.hs @@ -1,155 +1,352 @@ {-# LANGUAGE OverloadedStrings #-} -module Hpack.RenderSpec where +{-# LANGUAGE OverloadedLists #-} +module Hpack.RenderSpec (spec) where -import Test.Hspec -import Test.QuickCheck +import Helper import Data.List -import Data.Maybe +import Hpack.ConfigSpec hiding (spec) +import Hpack.Config hiding (package) +import Hpack.Render.Dsl import Hpack.Render -spec :: Spec -spec = do - describe "render" $ do - let render_ = render defaultRenderSettings 0 - context "when rendering a Stanza" $ do - it "renders stanza" $ do - let stanza = Stanza "foo" [ - Field "bar" "23" - , Field "baz" "42" - ] - render_ stanza `shouldBe` [ - "foo" - , " bar: 23" - , " baz: 42" - ] +library :: Library +library = Library Nothing [] [] [] [] [] - it "omits empty fields" $ do - let stanza = Stanza "foo" [ - Field "bar" "23" - , Field "baz" (WordList []) - ] - render_ stanza `shouldBe` [ - "foo" - , " bar: 23" - ] +executable :: Section Executable +executable = section (Executable (Just "Main.hs") [] []) - it "allows to customize indentation" $ do - let stanza = Stanza "foo" [ - Field "bar" "23" - , Field "baz" "42" - ] - render defaultRenderSettings{renderSettingsIndentation = 4} 0 stanza `shouldBe` [ - "foo" - , " bar: 23" - , " baz: 42" - ] +renderEmptySection :: Empty -> [Element] +renderEmptySection Empty = [] - it "renders nested stanzas" $ do - let input = Stanza "foo" [Field "bar" "23", Stanza "baz" [Field "qux" "42"]] - render_ input `shouldBe` [ - "foo" - , " bar: 23" - , " baz" - , " qux: 42" - ] +spec :: Spec +spec = do + describe "renderPackageWith" $ do + let renderPackage_ = renderPackageWith defaultRenderSettings 0 [] [] + it "renders a package" $ do + renderPackage_ package `shouldBe` unlines [ + "name: foo" + , "version: 0.0.0" + , "build-type: Simple" + , "cabal-version: >= 1.10" + ] - context "when rendering a Field" $ do - context "when rendering a MultipleLines value" $ do - it "takes nesting into account" $ do - let field = Field "foo" (CommaSeparatedList ["bar", "baz"]) - render defaultRenderSettings 1 field `shouldBe` [ - " foo:" - , " bar" - , " , baz" - ] + it "aligns fields" $ do + renderPackageWith defaultRenderSettings 16 [] [] package `shouldBe` unlines [ + "name: foo" + , "version: 0.0.0" + , "build-type: Simple" + , "cabal-version: >= 1.10" + ] - context "when value is empty" $ do - it "returns an empty list" $ do - let field = Field "foo" (CommaSeparatedList []) - render_ field `shouldBe` [] + it "includes description" $ do + renderPackage_ package {packageDescription = Just "foo\n\nbar\n"} `shouldBe` unlines [ + "name: foo" + , "version: 0.0.0" + , "description: foo" + , " ." + , " bar" + , "build-type: Simple" + , "cabal-version: >= 1.10" + ] - context "when rendering a SingleLine value" $ do - it "returns a single line" $ do - let field = Field "foo" (Literal "bar") - render_ field `shouldBe` ["foo: bar"] + it "aligns description" $ do + renderPackageWith defaultRenderSettings 16 [] [] package {packageDescription = Just "foo\n\nbar\n"} `shouldBe` unlines [ + "name: foo" + , "version: 0.0.0" + , "description: foo" + , " ." + , " bar" + , "build-type: Simple" + , "cabal-version: >= 1.10" + ] - it "takes nesting into account" $ do - let field = Field "foo" (Literal "bar") - render defaultRenderSettings 2 field `shouldBe` [" foo: bar"] + it "includes stability" $ do + renderPackage_ package {packageStability = Just "experimental"} `shouldBe` unlines [ + "name: foo" + , "version: 0.0.0" + , "stability: experimental" + , "build-type: Simple" + , "cabal-version: >= 1.10" + ] - it "takes alignment into account" $ do - let field = Field "foo" (Literal "bar") - render defaultRenderSettings {renderSettingsFieldAlignment = 10} 0 field `shouldBe` ["foo: bar"] + it "includes license-file" $ do + renderPackage_ package {packageLicenseFile = ["FOO"]} `shouldBe` unlines [ + "name: foo" + , "version: 0.0.0" + , "license-file: FOO" + , "build-type: Simple" + , "cabal-version: >= 1.10" + ] - context "when value is empty" $ do - it "returns an empty list" $ do - let field = Field "foo" (Literal "") - render_ field `shouldBe` [] + it "aligns license-files" $ do + renderPackageWith defaultRenderSettings 16 [] [] package {packageLicenseFile = ["FOO", "BAR"]} `shouldBe` unlines [ + "name: foo" + , "version: 0.0.0" + , "license-files: FOO," + , " BAR" + , "build-type: Simple" + , "cabal-version: >= 1.10" + ] - describe "renderValue" $ do - it "renders WordList" $ do - renderValue defaultRenderSettings (WordList ["foo", "bar", "baz"]) `shouldBe` SingleLine "foo bar baz" + it "includes copyright holder" $ do + renderPackage_ package {packageCopyright = ["(c) 2015 Simon Hengel"]} `shouldBe` unlines [ + "name: foo" + , "version: 0.0.0" + , "copyright: (c) 2015 Simon Hengel" + , "build-type: Simple" + , "cabal-version: >= 1.10" + ] - it "renders CommaSeparatedList" $ do - renderValue defaultRenderSettings (CommaSeparatedList ["foo", "bar", "baz"]) `shouldBe` MultipleLines [ - " foo" - , ", bar" - , ", baz" + it "aligns copyright holders" $ do + renderPackageWith defaultRenderSettings 16 [] [] package {packageCopyright = ["(c) 2015 Foo", "(c) 2015 Bar"]} `shouldBe` unlines [ + "name: foo" + , "version: 0.0.0" + , "copyright: (c) 2015 Foo," + , " (c) 2015 Bar" + , "build-type: Simple" + , "cabal-version: >= 1.10" ] - it "renders LineSeparatedList" $ do - renderValue defaultRenderSettings (LineSeparatedList ["foo", "bar", "baz"]) `shouldBe` MultipleLines [ - " foo" - , " bar" - , " baz" + it "includes extra-source-files" $ do + renderPackage_ package {packageExtraSourceFiles = ["foo", "bar"]} `shouldBe` unlines [ + "name: foo" + , "version: 0.0.0" + , "build-type: Simple" + , "cabal-version: >= 1.10" + , "" + , "extra-source-files:" + , " foo" + , " bar" ] - context "when renderSettingsCommaStyle is TrailingCommas" $ do - let settings = defaultRenderSettings{renderSettingsCommaStyle = TrailingCommas} + it "includes buildable" $ do + renderPackage_ package {packageLibrary = Just (section library){sectionBuildable = Just False}} `shouldBe` unlines [ + "name: foo" + , "version: 0.0.0" + , "build-type: Simple" + , "cabal-version: >= 1.10" + , "" + , "library" + , " buildable: False" + , " default-language: Haskell2010" + ] - it "renders CommaSeparatedList with trailing commas" $ do - renderValue settings (CommaSeparatedList ["foo", "bar", "baz"]) `shouldBe` MultipleLines [ - "foo," - , "bar," - , "baz" + context "when rendering library section" $ do + it "renders library section" $ do + renderPackage_ package {packageLibrary = Just $ section library} `shouldBe` unlines [ + "name: foo" + , "version: 0.0.0" + , "build-type: Simple" + , "cabal-version: >= 1.10" + , "" + , "library" + , " default-language: Haskell2010" ] - it "renders LineSeparatedList without padding" $ do - renderValue settings (LineSeparatedList ["foo", "bar", "baz"]) `shouldBe` MultipleLines [ - "foo" - , "bar" - , "baz" + context "when given list of existing fields" $ do + it "retains field order" $ do + renderPackageWith defaultRenderSettings 16 ["cabal-version", "version", "name", "build-type"] [] package `shouldBe` unlines [ + "cabal-version: >= 1.10" + , "version: 0.0.0" + , "name: foo" + , "build-type: Simple" ] - describe "sortFieldsBy" $ do - let - field name = Field name (Literal $ name ++ " value") - arbitraryFieldNames = sublistOf ["foo", "bar", "baz", "qux", "foobar", "foobaz"] >>= shuffle + it "uses default field order for new fields" $ do + renderPackageWith defaultRenderSettings 16 ["name", "version", "cabal-version"] [] package `shouldBe` unlines [ + "name: foo" + , "version: 0.0.0" + , "build-type: Simple" + , "cabal-version: >= 1.10" + ] - it "sorts fields" $ do - let fields = map field ["baz", "bar", "foo"] - sortFieldsBy ["foo", "bar", "baz"] fields `shouldBe` map field ["foo", "bar", "baz"] + it "retains section field order" $ do + renderPackageWith defaultRenderSettings 0 [] [("executable foo", ["default-language", "main-is", "ghc-options"])] package {packageExecutables = [("foo", executable {sectionGhcOptions = ["-Wall", "-Werror"]})]} `shouldBe` unlines [ + "name: foo" + , "version: 0.0.0" + , "build-type: Simple" + , "cabal-version: >= 1.10" + , "" + , "executable foo" + , " default-language: Haskell2010" + , " main-is: Main.hs" + , " ghc-options: -Wall -Werror" + ] - it "keeps existing field order" $ do - forAll (map field <$> arbitraryFieldNames) $ \fields -> do - forAll arbitraryFieldNames $ \existingFieldOrder -> do - let - existingIndex :: Element -> Maybe Int - existingIndex (Field name _) = name `elemIndex` existingFieldOrder - existingIndex _ = Nothing + context "when rendering executable section" $ do + it "includes dependencies" $ do + renderPackage_ package {packageExecutables = [("foo", executable {sectionDependencies = Dependencies + [("foo", VersionRange "== 0.1.0"), ("bar", AnyVersion)]})]} `shouldBe` unlines [ + "name: foo" + , "version: 0.0.0" + , "build-type: Simple" + , "cabal-version: >= 1.10" + , "" + , "executable foo" + , " main-is: Main.hs" + , " build-depends:" + , " bar" + , " , foo == 0.1.0" + , " default-language: Haskell2010" + ] - indexes :: [Int] - indexes = mapMaybe existingIndex (sortFieldsBy existingFieldOrder fields) + it "includes GHC options" $ do + renderPackage_ package {packageExecutables = [("foo", executable {sectionGhcOptions = ["-Wall", "-Werror"]})]} `shouldBe` unlines [ + "name: foo" + , "version: 0.0.0" + , "build-type: Simple" + , "cabal-version: >= 1.10" + , "" + , "executable foo" + , " main-is: Main.hs" + , " ghc-options: -Wall -Werror" + , " default-language: Haskell2010" + ] - sort indexes `shouldBe` indexes + it "includes frameworks" $ do + renderPackage_ package {packageExecutables = [("foo", executable {sectionFrameworks = ["foo", "bar"]})]} `shouldBe` unlines [ + "name: foo" + , "version: 0.0.0" + , "build-type: Simple" + , "cabal-version: >= 1.10" + , "" + , "executable foo" + , " main-is: Main.hs" + , " frameworks:" + , " foo" + , " bar" + , " default-language: Haskell2010" + ] - it "is stable" $ do - forAll arbitraryFieldNames $ \fieldNames -> do - forAll (elements $ subsequences fieldNames) $ \existingFieldOrder -> do - let fields = map field fieldNames - sortFieldsBy existingFieldOrder fields `shouldBe` fields + it "includes extra-framework-dirs" $ do + renderPackage_ package {packageExecutables = [("foo", executable {sectionExtraFrameworksDirs = ["foo", "bar"]})]} `shouldBe` unlines [ + "name: foo" + , "version: 0.0.0" + , "build-type: Simple" + , "cabal-version: >= 1.10" + , "" + , "executable foo" + , " main-is: Main.hs" + , " extra-frameworks-dirs:" + , " foo" + , " bar" + , " default-language: Haskell2010" + ] - describe "addSortKey" $ do - it "adds sort key" $ do - addSortKey [(Nothing, "foo"), (Just 3, "bar"), (Nothing, "baz")] `shouldBe` [((-1, 0), "foo"), ((3, 1), "bar"), ((3, 2), "baz" :: String)] + it "includes GHC profiling options" $ do + renderPackage_ package {packageExecutables = [("foo", executable {sectionGhcProfOptions = ["-fprof-auto", "-rtsopts"]})]} `shouldBe` unlines [ + "name: foo" + , "version: 0.0.0" + , "build-type: Simple" + , "cabal-version: >= 1.10" + , "" + , "executable foo" + , " main-is: Main.hs" + , " ghc-prof-options: -fprof-auto -rtsopts" + , " default-language: Haskell2010" + ] + + describe "renderConditional" $ do + it "renders conditionals" $ do + let conditional = Conditional "os(windows)" (section Empty) {sectionDependencies = deps ["Win32"]} Nothing + render defaultRenderSettings 0 (renderConditional renderEmptySection conditional) `shouldBe` [ + "if os(windows)" + , " build-depends:" + , " Win32" + ] + + it "renders conditionals with else-branch" $ do + let conditional = Conditional "os(windows)" (section Empty) {sectionDependencies = deps ["Win32"]} (Just $ (section Empty) {sectionDependencies = deps ["unix"]}) + render defaultRenderSettings 0 (renderConditional renderEmptySection conditional) `shouldBe` [ + "if os(windows)" + , " build-depends:" + , " Win32" + , "else" + , " build-depends:" + , " unix" + ] + + it "renders nested conditionals" $ do + let conditional = Conditional "arch(i386)" (section Empty) {sectionGhcOptions = ["-threaded"], sectionConditionals = [innerConditional]} Nothing + innerConditional = Conditional "os(windows)" (section Empty) {sectionDependencies = deps ["Win32"]} Nothing + render defaultRenderSettings 0 (renderConditional renderEmptySection conditional) `shouldBe` [ + "if arch(i386)" + , " ghc-options: -threaded" + , " if os(windows)" + , " build-depends:" + , " Win32" + ] + + describe "renderFlag" $ do + it "renders flags" $ do + let flag = (Flag "foo" (Just "some flag") True False) + render defaultRenderSettings 0 (renderFlag flag) `shouldBe` [ + "flag foo" + , " description: some flag" + , " manual: True" + , " default: False" + ] + + describe "formatDescription" $ do + it "formats description" $ do + let description = unlines [ + "foo" + , "bar" + ] + "description: " ++ formatDescription 0 description `shouldBe` intercalate "\n" [ + "description: foo" + , " bar" + ] + + it "takes specified alignment into account" $ do + let description = unlines [ + "foo" + , "bar" + , "baz" + ] + "description: " ++ formatDescription 15 description `shouldBe` intercalate "\n" [ + "description: foo" + , " bar" + , " baz" + ] + + it "formats empty lines" $ do + let description = unlines [ + "foo" + , " " + , "bar" + ] + "description: " ++ formatDescription 0 description `shouldBe` intercalate "\n" [ + "description: foo" + , " ." + , " bar" + ] + + describe "renderSourceRepository" $ do + it "renders source-repository without subdir correctly" $ do + let repository = SourceRepository "https://github.com/hspec/hspec" Nothing + (render defaultRenderSettings 0 $ renderSourceRepository repository) + `shouldBe` [ + "source-repository head" + , " type: git" + , " location: https://github.com/hspec/hspec" + ] + + it "renders source-repository with subdir" $ do + let repository = SourceRepository "https://github.com/hspec/hspec" (Just "hspec-core") + (render defaultRenderSettings 0 $ renderSourceRepository repository) + `shouldBe` [ + "source-repository head" + , " type: git" + , " location: https://github.com/hspec/hspec" + , " subdir: hspec-core" + ] + + describe "renderDirectories" $ do + it "replaces . with ./. (for compatibility with cabal syntax)" $ do + (render defaultRenderSettings 0 $ renderDirectories "name" ["."]) + `shouldBe` [ + "name:" + , " ./." + ] diff --git a/test/Hpack/RunSpec.hs b/test/Hpack/RunSpec.hs deleted file mode 100644 --- a/test/Hpack/RunSpec.hs +++ /dev/null @@ -1,352 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedLists #-} -module Hpack.RunSpec (spec) where - -import Helper -import Data.List - -import Hpack.ConfigSpec hiding (spec) -import Hpack.Config hiding (package) -import Hpack.Render -import Hpack.Run - -library :: Library -library = Library Nothing [] [] [] [] [] - -executable :: Section Executable -executable = section (Executable (Just "Main.hs") [] []) - -renderEmptySection :: Empty -> [Element] -renderEmptySection Empty = [] - -spec :: Spec -spec = do - describe "renderPackage" $ do - let renderPackage_ = renderPackage defaultRenderSettings 0 [] [] - it "renders a package" $ do - renderPackage_ package `shouldBe` unlines [ - "name: foo" - , "version: 0.0.0" - , "build-type: Simple" - , "cabal-version: >= 1.10" - ] - - it "aligns fields" $ do - renderPackage defaultRenderSettings 16 [] [] package `shouldBe` unlines [ - "name: foo" - , "version: 0.0.0" - , "build-type: Simple" - , "cabal-version: >= 1.10" - ] - - it "includes description" $ do - renderPackage_ package {packageDescription = Just "foo\n\nbar\n"} `shouldBe` unlines [ - "name: foo" - , "version: 0.0.0" - , "description: foo" - , " ." - , " bar" - , "build-type: Simple" - , "cabal-version: >= 1.10" - ] - - it "aligns description" $ do - renderPackage defaultRenderSettings 16 [] [] package {packageDescription = Just "foo\n\nbar\n"} `shouldBe` unlines [ - "name: foo" - , "version: 0.0.0" - , "description: foo" - , " ." - , " bar" - , "build-type: Simple" - , "cabal-version: >= 1.10" - ] - - it "includes stability" $ do - renderPackage_ package {packageStability = Just "experimental"} `shouldBe` unlines [ - "name: foo" - , "version: 0.0.0" - , "stability: experimental" - , "build-type: Simple" - , "cabal-version: >= 1.10" - ] - - it "includes license-file" $ do - renderPackage_ package {packageLicenseFile = ["FOO"]} `shouldBe` unlines [ - "name: foo" - , "version: 0.0.0" - , "license-file: FOO" - , "build-type: Simple" - , "cabal-version: >= 1.10" - ] - - it "aligns license-files" $ do - renderPackage defaultRenderSettings 16 [] [] package {packageLicenseFile = ["FOO", "BAR"]} `shouldBe` unlines [ - "name: foo" - , "version: 0.0.0" - , "license-files: FOO," - , " BAR" - , "build-type: Simple" - , "cabal-version: >= 1.10" - ] - - it "includes copyright holder" $ do - renderPackage_ package {packageCopyright = ["(c) 2015 Simon Hengel"]} `shouldBe` unlines [ - "name: foo" - , "version: 0.0.0" - , "copyright: (c) 2015 Simon Hengel" - , "build-type: Simple" - , "cabal-version: >= 1.10" - ] - - it "aligns copyright holders" $ do - renderPackage defaultRenderSettings 16 [] [] package {packageCopyright = ["(c) 2015 Foo", "(c) 2015 Bar"]} `shouldBe` unlines [ - "name: foo" - , "version: 0.0.0" - , "copyright: (c) 2015 Foo," - , " (c) 2015 Bar" - , "build-type: Simple" - , "cabal-version: >= 1.10" - ] - - it "includes extra-source-files" $ do - renderPackage_ package {packageExtraSourceFiles = ["foo", "bar"]} `shouldBe` unlines [ - "name: foo" - , "version: 0.0.0" - , "build-type: Simple" - , "cabal-version: >= 1.10" - , "" - , "extra-source-files:" - , " foo" - , " bar" - ] - - it "includes buildable" $ do - renderPackage_ package {packageLibrary = Just (section library){sectionBuildable = Just False}} `shouldBe` unlines [ - "name: foo" - , "version: 0.0.0" - , "build-type: Simple" - , "cabal-version: >= 1.10" - , "" - , "library" - , " buildable: False" - , " default-language: Haskell2010" - ] - - context "when rendering library section" $ do - it "renders library section" $ do - renderPackage_ package {packageLibrary = Just $ section library} `shouldBe` unlines [ - "name: foo" - , "version: 0.0.0" - , "build-type: Simple" - , "cabal-version: >= 1.10" - , "" - , "library" - , " default-language: Haskell2010" - ] - - context "when given list of existing fields" $ do - it "retains field order" $ do - renderPackage defaultRenderSettings 16 ["cabal-version", "version", "name", "build-type"] [] package `shouldBe` unlines [ - "cabal-version: >= 1.10" - , "version: 0.0.0" - , "name: foo" - , "build-type: Simple" - ] - - it "uses default field order for new fields" $ do - renderPackage defaultRenderSettings 16 ["name", "version", "cabal-version"] [] package `shouldBe` unlines [ - "name: foo" - , "version: 0.0.0" - , "build-type: Simple" - , "cabal-version: >= 1.10" - ] - - it "retains section field order" $ do - renderPackage defaultRenderSettings 0 [] [("executable foo", ["default-language", "main-is", "ghc-options"])] package {packageExecutables = [("foo", executable {sectionGhcOptions = ["-Wall", "-Werror"]})]} `shouldBe` unlines [ - "name: foo" - , "version: 0.0.0" - , "build-type: Simple" - , "cabal-version: >= 1.10" - , "" - , "executable foo" - , " default-language: Haskell2010" - , " main-is: Main.hs" - , " ghc-options: -Wall -Werror" - ] - - context "when rendering executable section" $ do - it "includes dependencies" $ do - renderPackage_ package {packageExecutables = [("foo", executable {sectionDependencies = Dependencies - [("foo", VersionRange "== 0.1.0"), ("bar", AnyVersion)]})]} `shouldBe` unlines [ - "name: foo" - , "version: 0.0.0" - , "build-type: Simple" - , "cabal-version: >= 1.10" - , "" - , "executable foo" - , " main-is: Main.hs" - , " build-depends:" - , " bar" - , " , foo == 0.1.0" - , " default-language: Haskell2010" - ] - - it "includes GHC options" $ do - renderPackage_ package {packageExecutables = [("foo", executable {sectionGhcOptions = ["-Wall", "-Werror"]})]} `shouldBe` unlines [ - "name: foo" - , "version: 0.0.0" - , "build-type: Simple" - , "cabal-version: >= 1.10" - , "" - , "executable foo" - , " main-is: Main.hs" - , " ghc-options: -Wall -Werror" - , " default-language: Haskell2010" - ] - - it "includes frameworks" $ do - renderPackage_ package {packageExecutables = [("foo", executable {sectionFrameworks = ["foo", "bar"]})]} `shouldBe` unlines [ - "name: foo" - , "version: 0.0.0" - , "build-type: Simple" - , "cabal-version: >= 1.10" - , "" - , "executable foo" - , " main-is: Main.hs" - , " frameworks:" - , " foo" - , " bar" - , " default-language: Haskell2010" - ] - - it "includes extra-framework-dirs" $ do - renderPackage_ package {packageExecutables = [("foo", executable {sectionExtraFrameworksDirs = ["foo", "bar"]})]} `shouldBe` unlines [ - "name: foo" - , "version: 0.0.0" - , "build-type: Simple" - , "cabal-version: >= 1.10" - , "" - , "executable foo" - , " main-is: Main.hs" - , " extra-frameworks-dirs:" - , " foo" - , " bar" - , " default-language: Haskell2010" - ] - - it "includes GHC profiling options" $ do - renderPackage_ package {packageExecutables = [("foo", executable {sectionGhcProfOptions = ["-fprof-auto", "-rtsopts"]})]} `shouldBe` unlines [ - "name: foo" - , "version: 0.0.0" - , "build-type: Simple" - , "cabal-version: >= 1.10" - , "" - , "executable foo" - , " main-is: Main.hs" - , " ghc-prof-options: -fprof-auto -rtsopts" - , " default-language: Haskell2010" - ] - - describe "renderConditional" $ do - it "renders conditionals" $ do - let conditional = Conditional "os(windows)" (section Empty) {sectionDependencies = deps ["Win32"]} Nothing - render defaultRenderSettings 0 (renderConditional renderEmptySection conditional) `shouldBe` [ - "if os(windows)" - , " build-depends:" - , " Win32" - ] - - it "renders conditionals with else-branch" $ do - let conditional = Conditional "os(windows)" (section Empty) {sectionDependencies = deps ["Win32"]} (Just $ (section Empty) {sectionDependencies = deps ["unix"]}) - render defaultRenderSettings 0 (renderConditional renderEmptySection conditional) `shouldBe` [ - "if os(windows)" - , " build-depends:" - , " Win32" - , "else" - , " build-depends:" - , " unix" - ] - - it "renders nested conditionals" $ do - let conditional = Conditional "arch(i386)" (section Empty) {sectionGhcOptions = ["-threaded"], sectionConditionals = [innerConditional]} Nothing - innerConditional = Conditional "os(windows)" (section Empty) {sectionDependencies = deps ["Win32"]} Nothing - render defaultRenderSettings 0 (renderConditional renderEmptySection conditional) `shouldBe` [ - "if arch(i386)" - , " ghc-options: -threaded" - , " if os(windows)" - , " build-depends:" - , " Win32" - ] - - describe "renderFlag" $ do - it "renders flags" $ do - let flag = (Flag "foo" (Just "some flag") True False) - render defaultRenderSettings 0 (renderFlag flag) `shouldBe` [ - "flag foo" - , " description: some flag" - , " manual: True" - , " default: False" - ] - - describe "formatDescription" $ do - it "formats description" $ do - let description = unlines [ - "foo" - , "bar" - ] - "description: " ++ formatDescription 0 description `shouldBe` intercalate "\n" [ - "description: foo" - , " bar" - ] - - it "takes specified alignment into account" $ do - let description = unlines [ - "foo" - , "bar" - , "baz" - ] - "description: " ++ formatDescription 15 description `shouldBe` intercalate "\n" [ - "description: foo" - , " bar" - , " baz" - ] - - it "formats empty lines" $ do - let description = unlines [ - "foo" - , " " - , "bar" - ] - "description: " ++ formatDescription 0 description `shouldBe` intercalate "\n" [ - "description: foo" - , " ." - , " bar" - ] - - describe "renderSourceRepository" $ do - it "renders source-repository without subdir correctly" $ do - let repository = SourceRepository "https://github.com/hspec/hspec" Nothing - (render defaultRenderSettings 0 $ renderSourceRepository repository) - `shouldBe` [ - "source-repository head" - , " type: git" - , " location: https://github.com/hspec/hspec" - ] - - it "renders source-repository with subdir" $ do - let repository = SourceRepository "https://github.com/hspec/hspec" (Just "hspec-core") - (render defaultRenderSettings 0 $ renderSourceRepository repository) - `shouldBe` [ - "source-repository head" - , " type: git" - , " location: https://github.com/hspec/hspec" - , " subdir: hspec-core" - ] - - describe "renderDirectories" $ do - it "replaces . with ./. (for compatibility with cabal syntax)" $ do - (render defaultRenderSettings 0 $ renderDirectories "name" ["."]) - `shouldBe` [ - "name:" - , " ./." - ] diff --git a/test/Hpack/Syntax/DefaultsSpec.hs b/test/Hpack/Syntax/DefaultsSpec.hs --- a/test/Hpack/Syntax/DefaultsSpec.hs +++ b/test/Hpack/Syntax/DefaultsSpec.hs @@ -8,26 +8,29 @@ import Data.Aeson.Config.FromValue import Hpack.Syntax.Defaults +defaultsGithub :: String -> String -> String -> [FilePath] -> Defaults +defaultsGithub owner repo ref path = DefaultsGithub $ Github owner repo ref path + spec :: Spec spec = do - describe "isValidUser" $ do + describe "isValidOwner" $ do it "rejects the empty string" $ do - isValidUser "" `shouldBe` False + isValidOwner "" `shouldBe` False - it "accepts valid user names" $ do - isValidUser "Foo-Bar-23" `shouldBe` True + it "accepts valid owner names" $ do + isValidOwner "Foo-Bar-23" `shouldBe` True it "rejects dots" $ do - isValidUser "foo.bar" `shouldBe` False + isValidOwner "foo.bar" `shouldBe` False it "rejects multiple consecutive hyphens" $ do - isValidUser "foo--bar" `shouldBe` False + isValidOwner "foo--bar" `shouldBe` False it "rejects hyphens at the beginning" $ do - isValidUser "-foo" `shouldBe` False + isValidOwner "-foo" `shouldBe` False it "rejects hyphens at the end" $ do - isValidUser "foo-" `shouldBe` False + isValidOwner "foo-" `shouldBe` False describe "isValidRepo" $ do it "rejects the empty string" $ do @@ -51,27 +54,30 @@ describe "fromValue" $ do context "when parsing Defaults" $ do let - left :: String -> DecodeResult Defaults + left :: String -> Result Defaults left = Left context "with Object" $ do + it "fails when neither github nor local is present" $ do + [yaml| + defaults: + foo: one + bar: two + library: {} + |] `shouldDecodeTo` left "Error while parsing $ - neither key \"github\" nor key \"local\" present" + it "accepts Defaults from GitHub" $ do [yaml| github: sol/hpack ref: 0.1.0 path: defaults.yaml - |] `shouldDecodeTo_` Defaults { - defaultsGithubUser = "sol" - , defaultsGithubRepo = "hpack" - , defaultsRef = "0.1.0" - , defaultsPath = ["defaults.yaml"] - } + |] `shouldDecodeTo_` defaultsGithub "sol" "hpack" "0.1.0" ["defaults.yaml"] - it "rejects invalid user names" $ do + it "rejects invalid owner names" $ do [yaml| github: ../hpack ref: 0.1.0 path: defaults.yaml - |] `shouldDecodeTo` left "Error while parsing $.github - invalid user name \"..\"" + |] `shouldDecodeTo` left "Error while parsing $.github - invalid owner name \"..\"" it "rejects invalid repository names" $ do [yaml| @@ -119,17 +125,12 @@ it "accepts Defaults from GitHub" $ do [yaml| sol/hpack@0.1.0 - |] `shouldDecodeTo_` Defaults { - defaultsGithubUser = "sol" - , defaultsGithubRepo = "hpack" - , defaultsRef = "0.1.0" - , defaultsPath = [".hpack", "defaults.yaml"] - } + |] `shouldDecodeTo_` defaultsGithub "sol" "hpack" "0.1.0" [".hpack", "defaults.yaml"] - it "rejects invalid user names" $ do + it "rejects invalid owner names" $ do [yaml| ../hpack@0.1.0 - |] `shouldDecodeTo` left "Error while parsing $ - invalid user name \"..\"" + |] `shouldDecodeTo` left "Error while parsing $ - invalid owner name \"..\"" it "rejects invalid repository names" $ do [yaml| @@ -144,7 +145,7 @@ it "rejects missing Git reference" $ do [yaml| sol/hpack - |] `shouldDecodeTo` left "Error while parsing $ - missing Git reference for \"sol/hpack\", the expected format is user/repo@ref" + |] `shouldDecodeTo` left "Error while parsing $ - missing Git reference for \"sol/hpack\", the expected format is owner/repo@ref" context "with neither Object nor String" $ do it "fails" $ do diff --git a/test/Hpack/Syntax/DependencySpec.hs b/test/Hpack/Syntax/DependencySpec.hs new file mode 100644 --- /dev/null +++ b/test/Hpack/Syntax/DependencySpec.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +module Hpack.Syntax.DependencySpec (spec) where + +import Helper + +import Data.Aeson.Config.FromValueSpec (shouldDecodeTo, shouldDecodeTo_) + +import Data.Aeson.Config.FromValue +import Hpack.Syntax.Dependency + +left :: String -> Result Dependencies +left = Left + +spec :: Spec +spec = do + describe "fromValue" $ do + context "when parsing Dependencies" $ do + context "with a scalar" $ do + it "accepts dependencies without constraints" $ do + [yaml| + hpack + |] `shouldDecodeTo_` Dependencies [("hpack", AnyVersion)] + + it "accepts dependencies with constraints" $ do + [yaml| + hpack >= 2 && < 3 + |] `shouldDecodeTo_` Dependencies [("hpack", VersionRange ">=2 && <3")] + + context "with invalid constraint" $ do + it "returns an error message" $ do + [yaml| + hpack == + |] `shouldDecodeTo` left "Error while parsing $ - invalid dependency \"hpack ==\"" + + context "with a list" $ do + it "accepts dependencies without constraints" $ do + [yaml| + - hpack + |] `shouldDecodeTo_` Dependencies [("hpack", AnyVersion)] + + it "accepts dependencies with constraints" $ do + [yaml| + - hpack >= 2 && < 3 + |] `shouldDecodeTo_` Dependencies [("hpack", VersionRange ">=2 && <3")] + + it "accepts git dependencies" $ do + let source = GitRef "https://github.com/sol/hpack" "master" Nothing + [yaml| + - name: hpack + git: https://github.com/sol/hpack + ref: master + |] `shouldDecodeTo_` Dependencies [("hpack", SourceDependency source)] + + it "accepts github dependencies" $ do + let source = GitRef "https://github.com/sol/hpack" "master" Nothing + [yaml| + - name: hpack + github: sol/hpack + ref: master + |] `shouldDecodeTo_` Dependencies [("hpack", SourceDependency source)] + + it "accepts an optional subdirectory for git dependencies" $ do + let source = GitRef "https://github.com/yesodweb/wai" "master" (Just "warp") + [yaml| + - name: warp + github: yesodweb/wai + ref: master + subdir: warp + |] `shouldDecodeTo_` Dependencies [("warp", SourceDependency source)] + + it "accepts local dependencies" $ do + let source = Local "../hpack" + [yaml| + - name: hpack + path: ../hpack + |] `shouldDecodeTo_` Dependencies [("hpack", SourceDependency source)] + + context "when ref is missing" $ do + it "produces accurate error messages" $ do + [yaml| + - name: hpack + git: sol/hpack + ef: master + |] `shouldDecodeTo` left "Error while parsing $[0] - key \"ref\" not present" + + context "when both git and github are missing" $ do + it "produces accurate error messages" $ do + [yaml| + - name: hpack + gi: sol/hpack + ref: master + |] `shouldDecodeTo` left "Error while parsing $[0] - neither key \"git\" nor key \"github\" present" + + context "with a mapping from dependency names to constraints" $ do + it "accepts dependencies without constraints" $ do + [yaml| + array: + |] `shouldDecodeTo_` Dependencies [("array", AnyVersion)] + + it "rejects invalid values" $ do + [yaml| + hpack: [] + |] `shouldDecodeTo` left "Error while parsing $.hpack - expected Null, Object, Number, or String, encountered Array" + + context "when the constraint is a Number" $ do + it "accepts 1" $ do + [yaml| + hpack: 1 + |] `shouldDecodeTo_` Dependencies [("hpack", VersionRange "==1")] + + it "accepts 1.0" $ do + [yaml| + hpack: 1.0 + |] `shouldDecodeTo_` Dependencies [("hpack", VersionRange "==1.0")] + + it "accepts 0.11" $ do + [yaml| + hpack: 0.11 + |] `shouldDecodeTo_` Dependencies [("hpack", VersionRange "==0.11")] + + it "accepts 0.110" $ do + [yaml| + hpack: 0.110 + |] `shouldDecodeTo_` Dependencies [("hpack", VersionRange "==0.110")] + + it "accepts 1e2" $ do + [yaml| + hpack: 1e2 + |] `shouldDecodeTo_` Dependencies [("hpack", VersionRange "==100")] + + context "when the constraint is a String" $ do + it "accepts version ranges" $ do + [yaml| + hpack: '>=2' + |] `shouldDecodeTo_` Dependencies [("hpack", VersionRange ">=2")] + + it "accepts specific versions" $ do + [yaml| + hpack: 0.10.8.2 + |] `shouldDecodeTo_` Dependencies [("hpack", VersionRange "==0.10.8.2")] + + it "accepts wildcard versions" $ do + [yaml| + hpack: 2.* + |] `shouldDecodeTo_` Dependencies [("hpack", VersionRange "==2.*")] + + it "reports parse errors" $ do + [yaml| + hpack: foo + |] `shouldDecodeTo` left "Error while parsing $.hpack - invalid constraint \"foo\"" + + context "when the constraint is an Object" $ do + it "accepts github dependencies" $ do + [yaml| + Cabal: + github: haskell/cabal + ref: d53b6e0d908dfedfdf4337b2935519fb1d689e76 + subdir: Cabal + |] `shouldDecodeTo_` Dependencies [("Cabal", SourceDependency (GitRef "https://github.com/haskell/cabal" "d53b6e0d908dfedfdf4337b2935519fb1d689e76" (Just "Cabal")))] + + it "ignores names in nested hashes" $ do + [yaml| + outer-name: + name: inner-name + path: somewhere + |] `shouldDecodeTo` Right (Dependencies [("outer-name", SourceDependency (Local "somewhere"))], ["$.outer-name.name"]) diff --git a/test/HpackSpec.hs b/test/HpackSpec.hs --- a/test/HpackSpec.hs +++ b/test/HpackSpec.hs @@ -7,7 +7,7 @@ import Control.DeepSeq -import Hpack.Config (packageConfig) +import Hpack.Config import Hpack.CabalFile import Hpack hiding (hpack) @@ -16,14 +16,14 @@ spec :: Spec spec = do - describe "hpackWithVersionResult" $ do + describe "hpackResult" $ do context "with existing cabal file" $ around_ inTempDirectory $ before_ (writeFile packageConfig "name: foo") $ do let file = "foo.cabal" - hpackWithVersion v = hpackWithVersionResult v defaultRunOptions NoForce - hpack = hpackWithVersionResult version defaultRunOptions NoForce - hpackForce = hpackWithVersionResult version defaultRunOptions Force + hpackWithVersion v = hpackResultWithVersion v defaultOptions + hpack = hpackResult defaultOptions + hpackForce = hpackResult defaultOptions {optionsForce = Force} generated = Result [] file Generated modifiedManually = Result [] file ExistingCabalFileWasModifiedManually