hpack 0.25.0 → 0.26.0

raw patch · 34 files changed

+2060/−1887 lines, 34 filesdep ~aesondep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: aeson, base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−0
• driver/Main.hs +4/−1
• hpack.cabal +19/−19
• src/Data/Aeson/Config/FromValue.hs +3/−3
• src/Hpack.hs +85/−49
• src/Hpack/CabalFile.hs +22/−1
• src/Hpack/Config.hs +55/−14
• src/Hpack/Defaults.hs +19/−13
• src/Hpack/Dependency.hs +0/−170
• src/Hpack/FormattingHints.hs +0/−111
• src/Hpack/Options.hs +38/−34
• src/Hpack/Render.hs +367/−100
• src/Hpack/Render/Dsl.hs +133/−0
• src/Hpack/Render/Hints.hs +114/−0
• src/Hpack/Run.hs +0/−418
• src/Hpack/Syntax/Defaults.hs +64/−50
• src/Hpack/Syntax/Dependency.hs +170/−0
• src/Hpack/Yaml.hs +15/−1
• test/Data/Aeson/Config/FromValueSpec.hs +2/−2
• test/Data/Aeson/Config/TypesSpec.hs +1/−1
• test/EndToEndSpec.hs +23/−7
• test/Hpack/CabalFileSpec.hs +22/−0
• test/Hpack/ConfigSpec.hs +10/−7
• test/Hpack/DefaultsSpec.hs +5/−0
• test/Hpack/DependencySpec.hs +0/−169
• test/Hpack/FormattingHintsSpec.hs +0/−166
• test/Hpack/OptionsSpec.hs +35/−45
• test/Hpack/Render/DslSpec.hs +155/−0
• test/Hpack/Render/HintsSpec.hs +169/−0
• test/Hpack/RenderSpec.hs +320/−123
• test/Hpack/RunSpec.hs +0/−352
• test/Hpack/Syntax/DefaultsSpec.hs +27/−26
• test/Hpack/Syntax/DependencySpec.hs +169/−0
• test/HpackSpec.hs +5/−5

@@ -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) 

@@ -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)

@@ -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 <https://github.com/sol/hpack#readme> 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

@@ -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

@@ -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

@@ -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 = ">>>>>>> "

@@ -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

@@ -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

@@ -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]

@@ -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)

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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")

@@ -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]

@@ -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

@@ -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|

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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"

@@ -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"])

@@ -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

@@ -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

@@ -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)]

@@ -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

@@ -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:"+          , "    ./."+          ]

@@ -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:"-          , "    ./."-          ]

@@ -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

@@ -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"])

@@ -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