diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +## Changes in 0.21.0 + - Accept section-specific fields in conditionals (see #175, thanks to Scott + Fleischman) + - New section: `internal-libraries`, for Cabal 2's internal libraries (see #200). + ## Changes in 0.20.0 - Do not overwrite any existing cabal file if it has been modified manually diff --git a/hpack.cabal b/hpack.cabal --- a/hpack.cabal +++ b/hpack.cabal @@ -1,9 +1,11 @@ --- This file has been generated from package.yaml by hpack version 0.19.3. +-- This file has been generated from package.yaml by hpack version 0.20.0. -- -- see: https://github.com/sol/hpack +-- +-- hash: db045f3697ddf50f10677f67652465713155419437cab6c893deede5a3330f31 name: hpack -version: 0.20.0 +version: 0.21.0 synopsis: An alternative format for Haskell packages description: See README at category: Development @@ -30,8 +32,8 @@ Cabal , Glob , aeson >=0.11 - , base >=4.7 && <5 - , base-compat >=0.8 + , base >=4.8 && <5 + , bifunctors , bytestring , containers , cryptonite @@ -40,6 +42,7 @@ , filepath , pretty , text + , transformers , unordered-containers , yaml exposed-modules: @@ -55,6 +58,8 @@ Hpack.Haskell Hpack.Options Hpack.Render + Hpack.UnknownFields + Hpack.Utf8 Hpack.Util Paths_hpack default-language: Haskell2010 @@ -68,8 +73,8 @@ Cabal , Glob , aeson >=0.11 - , base >=4.7 && <5 - , base-compat >=0.8 + , base >=4.8 && <5 + , bifunctors , bytestring , containers , cryptonite @@ -79,6 +84,7 @@ , hpack , pretty , text + , transformers , unordered-containers , yaml other-modules: @@ -99,8 +105,8 @@ , HUnit >=1.6.0.0 , QuickCheck , aeson >=0.11 - , base >=4.7 && <5 - , base-compat >=0.8 + , base >=4.8 && <5 + , bifunctors , bytestring , containers , cryptonite @@ -113,9 +119,11 @@ , pretty , temporary , text + , transformers , unordered-containers , yaml other-modules: + EndToEndSpec Helper Hpack.CabalFileSpec Hpack.ConfigSpec @@ -126,6 +134,7 @@ Hpack.OptionsSpec Hpack.RenderSpec Hpack.RunSpec + Hpack.Utf8Spec Hpack.UtilSpec HpackSpec Hpack @@ -138,6 +147,8 @@ Hpack.Options Hpack.Render Hpack.Run + Hpack.UnknownFields + Hpack.Utf8 Hpack.Util Hpack.Yaml Paths_hpack diff --git a/src/Hpack.hs b/src/Hpack.hs --- a/src/Hpack.hs +++ b/src/Hpack.hs @@ -15,16 +15,12 @@ #endif ) where -import Prelude () -import Prelude.Compat - -import Control.Monad.Compat -import qualified Data.ByteString as B +import Control.Monad import Data.Version (Version) import qualified Data.Version as Version import System.Environment import System.Exit -import System.IO +import System.IO (stderr) import System.FilePath import System.Directory @@ -33,6 +29,7 @@ import Hpack.Config import Hpack.Run import Hpack.Util +import Hpack.Utf8 as Utf8 import Hpack.CabalFile programVersion :: Version -> String @@ -63,7 +60,7 @@ printHelp :: IO () printHelp = do - hPutStrLn stderr $ unlines [ + Utf8.hPutStrLn stderr $ unlines [ "Usage: hpack [ --silent ] [ --force | -f ] [ PATH ] [ - ]" , " hpack --version" , " hpack --help" @@ -101,7 +98,7 @@ printWarnings :: [String] -> IO () printWarnings warnings = do - forM_ warnings $ \warning -> hPutStrLn stderr ("WARNING: " ++ warning) + forM_ warnings $ \warning -> Utf8.hPutStrLn stderr ("WARNING: " ++ warning) splitDirectory :: Maybe FilePath -> IO (Maybe FilePath, FilePath) splitDirectory Nothing = return (Nothing, packageConfig) @@ -137,7 +134,7 @@ case status of Generated -> do let hash = sha256 new - B.writeFile cabalFile . encodeUtf8 $ header file v hash ++ new + Utf8.writeFile cabalFile (header file v hash ++ new) _ -> return () return Result { resultWarnings = warnings @@ -149,5 +146,5 @@ hpackStdOut p = do (dir, file) <- splitDirectory p (warnings, _cabalFile, new) <- run dir file - B.putStr (encodeUtf8 new) + Utf8.putStr new printWarnings warnings diff --git a/src/Hpack/CabalFile.hs b/src/Hpack/CabalFile.hs --- a/src/Hpack/CabalFile.hs +++ b/src/Hpack/CabalFile.hs @@ -3,11 +3,8 @@ {-# LANGUAGE ViewPatterns #-} module Hpack.CabalFile where -import Prelude () -import Prelude.Compat - -import Control.Monad.Compat -import Data.List.Compat +import Control.Monad +import Data.List import Data.Maybe import Data.Version (Version(..)) import qualified Data.Version as Version diff --git a/src/Hpack/Config.hs b/src/Hpack/Config.hs --- a/src/Hpack/Config.hs +++ b/src/Hpack/Config.hs @@ -8,11 +8,12 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RankNTypes #-} module Hpack.Config ( packageConfig , readPackageConfig @@ -36,36 +37,42 @@ , SourceRepository(..) #ifdef TEST , renameDependencies -, HasFieldNames(..) -, CaptureUnknownFields(..) , Empty(..) , getModules , determineModules , BuildType(..) + +, LibrarySection(..) +, fromLibrarySectionInConditional #endif ) where import Control.Applicative -import Control.Monad.Compat +import Control.Monad import Data.Aeson.Types import Data.Data +import Data.Bifunctor +import Data.Bifoldable +import Data.Bitraversable import Data.Map.Lazy (Map) import qualified Data.Map.Lazy as Map import qualified Data.HashMap.Lazy as HashMap -import Data.List.Compat (nub, (\\), sortBy, isPrefixOf) +import Data.List (nub, (\\), sortBy) import Data.Maybe -import Data.Monoid +import Data.Monoid hiding (Product) import Data.Ord import Data.String import Data.Text (Text) import qualified Data.Text as T import GHC.Generics (Generic, Rep) -import Prelude () -import Prelude.Compat import System.Directory import System.FilePath +import Data.Functor.Identity +import Control.Monad.Trans.Writer +import Control.Monad.IO.Class import Hpack.GenericsUtil +import Hpack.UnknownFields import Hpack.Util import Hpack.Yaml import Hpack.Dependency @@ -93,17 +100,18 @@ , packageSourceRepository = Nothing , packageCustomSetup = Nothing , packageLibrary = Nothing - , packageExecutables = [] - , packageTests = [] - , packageBenchmarks = [] + , packageInternalLibraries = mempty + , packageExecutables = mempty + , packageTests = mempty + , packageBenchmarks = mempty } renamePackage :: String -> Package -> Package renamePackage name p@Package{..} = p { packageName = name - , packageExecutables = map (renameDependencies packageName name) packageExecutables - , packageTests = map (renameDependencies packageName name) packageTests - , packageBenchmarks = map (renameDependencies packageName name) packageBenchmarks + , packageExecutables = fmap (renameDependencies packageName name) packageExecutables + , packageTests = fmap (renameDependencies packageName name) packageTests + , packageBenchmarks = fmap (renameDependencies packageName name) packageBenchmarks } renameDependencies :: String -> String -> Section a -> Section a @@ -113,7 +121,7 @@ | name == old = (new, version) | otherwise = dep - renameConditional :: Conditional -> Conditional + renameConditional :: Conditional (Section a) -> Conditional (Section a) renameConditional (Conditional condition then_ else_) = Conditional condition (renameDependencies old new then_) (renameDependencies old new <$> else_) packageDependencies :: Package -> [(String, DependencyVersion)] @@ -141,61 +149,6 @@ name :: String name = typeName (Proxy :: Proxy a) -hyphenize :: String -> String -> String -hyphenize name = -#if MIN_VERSION_aeson(0,10,0) - camelTo2 -#else - camelTo -#endif - '-' . drop (length name) . dropWhile (== '_') - -type FieldName = String - -class HasFieldNames a where - fieldNames :: Proxy a -> [FieldName] - - default fieldNames :: (HasTypeName a d m, Selectors (Rep a)) => Proxy a -> [String] - fieldNames proxy = map (hyphenize $ typeName proxy) (selectors proxy) - - ignoreUnderscoredUnknownFields :: Proxy a -> Bool - ignoreUnderscoredUnknownFields _ = False - -data CaptureUnknownFields a = CaptureUnknownFields { - captureUnknownFieldsFields :: [FieldName] -, captureUnknownFieldsValue :: a -} deriving (Eq, Show, Generic) - -captureUnknownFields :: forall a. (HasFieldNames a, FromJSON a) => Value -> Parser (CaptureUnknownFields a) -captureUnknownFields v = CaptureUnknownFields unknown <$> parseJSON v - where - unknown = getUnknownFields v (Proxy :: Proxy a) - -instance (HasFieldNames a, FromJSON a) => FromJSON (CaptureUnknownFields (Section a)) where - parseJSON v = do - (unknownFields, sect) <- toSection <$> parseJSON v <*> parseJSON v - return (CaptureUnknownFields (unknownSectionFields ++ unknownFields) sect) - where - unknownSectionFields = getUnknownFields v (Proxy :: Proxy (Section a)) - -instance FromJSON (CaptureUnknownFields CustomSetupSection) where - parseJSON = captureUnknownFields - -instance FromJSON (CaptureUnknownFields FlagSection) where - parseJSON = captureUnknownFields - -getUnknownFields :: forall a. HasFieldNames a => Value -> Proxy a -> [FieldName] -getUnknownFields v _ = case v of - Object o -> ignoreUnderscored unknown - where - unknown = keys \\ fields - keys = map T.unpack (HashMap.keys o) - fields = fieldNames (Proxy :: Proxy a) - ignoreUnderscored - | ignoreUnderscoredUnknownFields (Proxy :: Proxy a) = filter (not . isPrefixOf "_") - | otherwise = id - _ -> [] - data CustomSetupSection = CustomSetupSection { customSetupSectionDependencies :: Maybe Dependencies } deriving (Eq, Show, Generic) @@ -212,22 +165,28 @@ , librarySectionReexportedModules :: Maybe (List String) } deriving (Eq, Show, Generic) +emptyLibrarySection :: LibrarySection +emptyLibrarySection = LibrarySection Nothing Nothing Nothing Nothing + instance HasFieldNames LibrarySection instance FromJSON LibrarySection where parseJSON = genericParseJSON_ data ExecutableSection = ExecutableSection { - executableSectionMain :: FilePath + executableSectionMain :: Maybe FilePath , executableSectionOtherModules :: Maybe (List String) } deriving (Eq, Show, Generic) +emptyExecutableSection :: ExecutableSection +emptyExecutableSection = ExecutableSection Nothing Nothing + instance HasFieldNames ExecutableSection instance FromJSON ExecutableSection where parseJSON = genericParseJSON_ -data CommonOptions = CommonOptions { +data CommonOptions a capture cSources jsSources = CommonOptions { commonOptionsSourceDirs :: Maybe (List FilePath) , commonOptionsDependencies :: Maybe Dependencies , commonOptionsDefaultExtensions :: Maybe (List String) @@ -237,8 +196,8 @@ , commonOptionsGhcjsOptions :: Maybe (List GhcjsOption) , commonOptionsCppOptions :: Maybe (List CppOption) , commonOptionsCcOptions :: Maybe (List CcOption) -, commonOptionsCSources :: Maybe (List FilePath) -, commonOptionsJsSources :: Maybe (List FilePath) +, commonOptionsCSources :: cSources +, commonOptionsJsSources :: jsSources , commonOptionsExtraLibDirs :: Maybe (List FilePath) , commonOptionsExtraLibraries :: Maybe (List FilePath) , commonOptionsExtraFrameworksDirs :: Maybe (List FilePath) @@ -247,19 +206,91 @@ , commonOptionsInstallIncludes :: Maybe (List FilePath) , commonOptionsLdOptions :: Maybe (List LdOption) , commonOptionsBuildable :: Maybe Bool -, commonOptionsWhen :: Maybe (List ConditionalSection) +, commonOptionsWhen :: Maybe (List (ConditionalSection a capture cSources jsSources)) , commonOptionsBuildTools :: Maybe Dependencies -} deriving (Eq, Show, Generic) +} deriving Generic -instance HasFieldNames CommonOptions +type ParseCommonOptions a = CommonOptions a CaptureUnknownFields ParseCSources ParseJsSources -instance FromJSON CommonOptions where +instance HasFieldNames (ParseCommonOptions a) + +instance (FromJSON a, HasFieldNames a) => FromJSON (ParseCommonOptions a) where parseJSON = genericParseJSON_ -data ConditionalSection = ThenElseConditional (CaptureUnknownFields ThenElse) | FlatConditional (CaptureUnknownFields (Section Condition)) +type ParseCSources = Maybe (List FilePath) +type ParseJsSources = Maybe (List FilePath) + +type CSources = [FilePath] +type JsSources = [FilePath] + +type WithCommonOptions a capture cSources jsSources = Product (CommonOptions a capture cSources jsSources) a + +data Traverse m capture capture_ cSources cSources_ jsSources jsSources_ = Traverse { + traverseCapture :: forall a. capture a -> m (capture_ a) +, traverseCSources :: cSources -> m cSources_ +, traverseJsSources :: jsSources -> m jsSources_ +} + +type Traversal t = forall m capture capture_ cSources cSources_ jsSources jsSources_. (Monad m, Traversable capture_) + => Traverse m capture capture_ cSources cSources_ jsSources jsSources_ + -> t capture cSources jsSources + -> m (t capture_ cSources_ jsSources_) + +traverseCommonOptions :: Traversal (CommonOptions a) +traverseCommonOptions t@Traverse{..} c@CommonOptions{..} = do + cSources <- traverseCSources commonOptionsCSources + jsSources <- traverseJsSources commonOptionsJsSources + xs <- traverse (traverse (traverseConditionalSection t)) commonOptionsWhen + return c { + commonOptionsCSources = cSources + , commonOptionsJsSources = jsSources + , commonOptionsWhen = xs + } + +traverseConditionalSection :: Traversal (ConditionalSection a) +traverseConditionalSection t@Traverse{..} = \ case + ThenElseConditional c -> ThenElseConditional <$> (traverseCapture c >>= traverse (traverseThenElse t)) + FlatConditional c -> FlatConditional <$> (traverseCapture c >>= traverse (bitraverse (traverseWithCommonOptions t) return)) + +traverseThenElse :: Traversal (ThenElse a) +traverseThenElse t@Traverse{..} c@ThenElse{..} = do + then_ <- traverseCapture thenElseThen >>= traverse (traverseWithCommonOptions t) + else_ <- traverseCapture thenElseElse >>= traverse (traverseWithCommonOptions t) + return c{thenElseThen = then_, thenElseElse = else_} + +traverseWithCommonOptions :: Traversal (WithCommonOptions a) +traverseWithCommonOptions t = bitraverse (traverseCommonOptions t) return + +data Product a b = Product a b deriving (Eq, Show) -instance FromJSON ConditionalSection where +instance Bifunctor Product where + bimap fa fb (Product a b) = Product (fa a) (fb b) + +instance Bifoldable Product where + bifoldMap = bifoldMapDefault + +instance Bitraversable Product where + bitraverse fa fb (Product a b) = Product <$> fa a <*> fb b + +instance (FromJSON a, FromJSON b) => FromJSON (Product a b) where + parseJSON value = Product <$> parseJSON value <*> parseJSON value + +instance (HasFieldNames a, HasFieldNames b) => HasFieldNames (Product a b) where + fieldNames Proxy = + fieldNames (Proxy :: Proxy a) + ++ fieldNames (Proxy :: Proxy b) + ignoreUnderscoredUnknownFields Proxy = + ignoreUnderscoredUnknownFields (Proxy :: Proxy a) + || ignoreUnderscoredUnknownFields (Proxy :: Proxy b) + +data ConditionalSection a capture cSources jsSources = + ThenElseConditional (capture (ThenElse a capture cSources jsSources)) + | FlatConditional (capture (Product (WithCommonOptions a capture cSources jsSources) Condition)) + +type ParseConditionalSection a = ConditionalSection a CaptureUnknownFields ParseCSources ParseJsSources + +instance (FromJSON a, HasFieldNames a) => FromJSON (ParseConditionalSection a) where parseJSON v | hasKey "then" v || hasKey "else" v = ThenElseConditional <$> parseJSON v | otherwise = FlatConditional <$> parseJSON v @@ -277,18 +308,17 @@ instance HasFieldNames Condition -data ThenElse = ThenElse { +data ThenElse a capture cSources jsSources = ThenElse { _thenElseCondition :: String -, _thenElseThen :: (CaptureUnknownFields (Section Empty)) -, _thenElseElse :: (CaptureUnknownFields (Section Empty)) -} deriving (Eq, Show, Generic) +, thenElseThen :: capture (WithCommonOptions a capture cSources jsSources) +, thenElseElse :: capture (WithCommonOptions a capture cSources jsSources) +} deriving Generic -instance FromJSON (CaptureUnknownFields ThenElse) where - parseJSON = captureUnknownFields +type ParseThenElse a = ThenElse a CaptureUnknownFields ParseCSources ParseJsSources -instance HasFieldNames ThenElse +instance HasFieldNames (ParseThenElse a) -instance FromJSON ThenElse where +instance (FromJSON a, HasFieldNames a) => FromJSON (ParseThenElse a) where parseJSON = genericParseJSON_ data Empty = Empty @@ -316,9 +346,9 @@ "Custom" -> return Custom _ -> fail "build-type must be one of: Simple, Configure, Make, Custom" -type ExecutableConfig = CaptureUnknownFields (Section ExecutableSection) +type SectionConfig a capture cSources jsSources = capture (WithCommonOptions a capture cSources jsSources) -data PackageConfig = PackageConfig { +data PackageConfig capture cSources jsSources = PackageConfig { packageConfigName :: Maybe String , packageConfigVersion :: Maybe String , packageConfigSynopsis :: Maybe String @@ -334,26 +364,55 @@ , packageConfigLicense :: Maybe String , packageConfigLicenseFile :: Maybe (List String) , packageConfigTestedWith :: Maybe String -, packageConfigFlags :: Maybe (Map String (CaptureUnknownFields FlagSection)) +, packageConfigFlags :: Maybe (Map String (capture FlagSection)) , packageConfigExtraSourceFiles :: Maybe (List FilePath) , packageConfigDataFiles :: Maybe (List FilePath) , packageConfigGithub :: Maybe Text , packageConfigGit :: Maybe String -, packageConfigCustomSetup :: Maybe (CaptureUnknownFields CustomSetupSection) -, packageConfigLibrary :: Maybe (CaptureUnknownFields (Section LibrarySection)) -, packageConfigExecutable :: Maybe ExecutableConfig -, packageConfigExecutables :: Maybe (Map String ExecutableConfig) -, packageConfigTests :: Maybe (Map String (CaptureUnknownFields (Section ExecutableSection))) -, packageConfigBenchmarks :: Maybe (Map String (CaptureUnknownFields (Section ExecutableSection))) -} deriving (Eq, Show, Generic) +, packageConfigCustomSetup :: Maybe (capture CustomSetupSection) +, packageConfigLibrary :: Maybe (SectionConfig LibrarySection capture cSources jsSources) +, packageConfigInternalLibraries :: Maybe (Map String (SectionConfig LibrarySection capture cSources jsSources)) +, packageConfigExecutable :: Maybe (SectionConfig ExecutableSection capture cSources jsSources) +, packageConfigExecutables :: Maybe (Map String (SectionConfig ExecutableSection capture cSources jsSources)) +, packageConfigTests :: Maybe (Map String (SectionConfig ExecutableSection capture cSources jsSources)) +, packageConfigBenchmarks :: Maybe (Map String (SectionConfig ExecutableSection capture cSources jsSources)) +} deriving Generic -instance HasFieldNames PackageConfig where +traversePackageConfig :: Traversal PackageConfig +traversePackageConfig t@Traverse{..} p@PackageConfig{..} = do + flags <- traverse (traverse traverseCapture) packageConfigFlags + customSetup <- traverse traverseCapture packageConfigCustomSetup + library <- traverse (traverseSectionConfig t) packageConfigLibrary + internalLibraries <- traverseNamedConfigs t packageConfigInternalLibraries + executable <- traverse (traverseSectionConfig t) packageConfigExecutable + executables <- traverseNamedConfigs t packageConfigExecutables + tests <- traverseNamedConfigs t packageConfigTests + benchmarks <- traverseNamedConfigs t packageConfigBenchmarks + return p { + packageConfigFlags = flags + , packageConfigCustomSetup = customSetup + , packageConfigLibrary = library + , packageConfigInternalLibraries = internalLibraries + , packageConfigExecutable = executable + , packageConfigExecutables = executables + , packageConfigTests = tests + , packageConfigBenchmarks = benchmarks + } + where + traverseNamedConfigs = traverse . traverse . traverseSectionConfig + +traverseSectionConfig :: Traversal (SectionConfig p) +traverseSectionConfig t = traverseCapture t >=> traverse (traverseWithCommonOptions t) + +type ParsePackageConfig = PackageConfig CaptureUnknownFields ParseCSources ParseJsSources + +instance HasFieldNames ParsePackageConfig where ignoreUnderscoredUnknownFields _ = True -instance FromJSON PackageConfig where +instance FromJSON ParsePackageConfig where parseJSON value = handleNullValues <$> genericParseJSON_ value where - handleNullValues :: PackageConfig -> PackageConfig + handleNullValues :: ParsePackageConfig -> ParsePackageConfig handleNullValues = ifNull "homepage" (\p -> p {packageConfigHomepage = Just Nothing}) . ifNull "bug-reports" (\p -> p {packageConfigBugReports = Just Nothing}) @@ -377,7 +436,7 @@ Left err -> return (Left err) Right config -> do dir <- takeDirectory <$> canonicalizePath file - Right <$> mkPackage dir config + Right <$> toPackage dir config data Package = Package { packageName :: String @@ -401,9 +460,10 @@ , packageSourceRepository :: Maybe SourceRepository , packageCustomSetup :: Maybe CustomSetup , packageLibrary :: Maybe (Section Library) -, packageExecutables :: [Section Executable] -, packageTests :: [Section Executable] -, packageBenchmarks :: [Section Executable] +, packageInternalLibraries :: Map String (Section Library) +, packageExecutables :: Map String (Section Executable) +, packageTests :: Map String (Section Executable) +, packageBenchmarks :: Map String (Section Executable) } deriving (Eq, Show) data CustomSetup = CustomSetup { @@ -418,8 +478,7 @@ } deriving (Eq, Show) data Executable = Executable { - executableName :: String -, executableMain :: FilePath + executableMain :: Maybe FilePath , executableOtherModules :: [String] } deriving (Eq, Show) @@ -444,19 +503,15 @@ , sectionInstallIncludes :: [FilePath] , sectionLdOptions :: [LdOption] , sectionBuildable :: Maybe Bool -, sectionConditionals :: [Conditional] +, sectionConditionals :: [Conditional (Section a)] , sectionBuildTools :: Dependencies } deriving (Eq, Show, Functor, Foldable, Traversable) -data Conditional = Conditional { +data Conditional a = Conditional { conditionalCondition :: String -, conditionalThen :: Section () -, conditionalElse :: Maybe (Section ()) -} deriving (Eq, Show) - -instance HasFieldNames a => HasFieldNames (Section a) where - fieldNames Proxy = fieldNames (Proxy :: Proxy a) ++ fieldNames (Proxy :: Proxy CommonOptions) - ignoreUnderscoredUnknownFields _ = ignoreUnderscoredUnknownFields (Proxy :: Proxy a) +, conditionalThen :: a +, conditionalElse :: Maybe a +} deriving (Eq, Show, Functor, Foldable, Traversable) data FlagSection = FlagSection { _flagSectionDescription :: Maybe String @@ -484,39 +539,49 @@ , sourceRepositorySubdir :: Maybe String } deriving (Eq, Show) -mkPackage :: FilePath -> (CaptureUnknownFields (Section PackageConfig)) -> IO ([String], Package) -mkPackage dir (CaptureUnknownFields unknownFields globalOptions@Section{sectionData = PackageConfig{..}}) = do - libraryResult <- mapM (toLibrary dir packageName_ globalOptions) mLibrarySection +type Config capture cSources jsSources = + Product (CommonOptions Empty capture cSources jsSources) (PackageConfig capture cSources jsSources) + +traverseConfig :: Traversal Config +traverseConfig t = bitraverse (traverseCommonOptions t) (traversePackageConfig t) + +type ParseConfig = CaptureUnknownFields (Config CaptureUnknownFields ParseCSources ParseJsSources) + +toPackage :: FilePath -> ParseConfig -> IO ([String], Package) +toPackage dir = runWriterT . (extractUnknownFieldWarnings >=> expandForeignSources dir) >=> toPackage_ dir + +toPackage_ :: FilePath -> (Config Identity CSources JsSources, [String]) -> IO ([String], Package) +toPackage_ dir (Product (toSection . (`Product` Empty) -> globalOptions) PackageConfig{..}, packageWarnings) = do + mLibrary <- mapM (toLibrary dir packageName_ globalOptions) mLibrarySection + let - executableWarnings :: [String] - executableSections :: [(String, Section ExecutableSection)] - (executableWarnings, executableSections) = (warnings, map (fmap captureUnknownFieldsValue) sections) + executableSections :: Map String (Section ExecutableSection) + (executableWarning, executableSections) = (warning, sections) where - sections = case (packageConfigExecutable, packageConfigExecutables) of - (Nothing, Nothing) -> [] - (Just executable, _) -> [(packageName_, executable)] - (Nothing, Just executables) -> Map.toList executables + sections :: Map String (Section ExecutableSection) + sections = case mExecutable of + Just executable -> Map.fromList [(packageName_, executable)] + Nothing -> executables - warnings = ignoringExecutablesWarning ++ unknownFieldWarnings - ignoringExecutablesWarning = case (packageConfigExecutable, packageConfigExecutables) of - (Just _, Just _) -> ["Ignoring field \"executables\" in favor of \"executable\""] + warning = case mExecutable of + Just _ | not (null executables) -> ["Ignoring field \"executables\" in favor of \"executable\""] _ -> [] - unknownFieldWarnings = formatUnknownSectionFields (isJust packageConfigExecutables) "executable" sections - mLibrary :: Maybe (Section Library) - mLibrary = fmap snd libraryResult + executables = toSections packageConfigExecutables - libraryWarnings :: [String] - libraryWarnings = maybe [] fst libraryResult + mExecutable :: Maybe (Section ExecutableSection) + mExecutable = toSectionI <$> packageConfigExecutable - (executablesWarnings, executables) <- toExecutables dir packageName_ globalOptions executableSections - (testsWarnings, tests) <- toExecutables dir packageName_ globalOptions (map (fmap captureUnknownFieldsValue) testsSections) - (benchmarksWarnings, benchmarks) <- toExecutables dir packageName_ globalOptions (map (fmap captureUnknownFieldsValue) benchmarkSections) + internalLibraries <- toInternalLibraries dir packageName_ globalOptions internalLibrariesSections + executables <- toExecutables dir packageName_ globalOptions executableSections + tests <- toExecutables dir packageName_ globalOptions testSections + benchmarks <- toExecutables dir packageName_ globalOptions benchmarkSections licenseFileExists <- doesFileExist (dir "LICENSE") missingSourceDirs <- nub . sort <$> filterM (fmap not <$> doesDirectoryExist . (dir )) ( maybe [] sectionSourceDirs mLibrary + ++ concatMap sectionSourceDirs internalLibraries ++ concatMap sectionSourceDirs executables ++ concatMap sectionSourceDirs tests ++ concatMap sectionSourceDirs benchmarks @@ -558,25 +623,17 @@ , packageSourceRepository = sourceRepository , packageCustomSetup = mCustomSetup , packageLibrary = mLibrary + , packageInternalLibraries = internalLibraries , packageExecutables = executables , packageTests = tests , packageBenchmarks = benchmarks } warnings = - formatUnknownFields "package description" unknownFields + packageWarnings ++ nameWarnings - ++ flagWarnings - ++ maybe [] (formatUnknownFields "custom-setup section") (captureUnknownFieldsFields <$> packageConfigCustomSetup) - ++ maybe [] (formatUnknownFields "library section") (captureUnknownFieldsFields <$> packageConfigLibrary) - ++ formatUnknownSectionFields True "test" testsSections - ++ formatUnknownSectionFields True "benchmark" benchmarkSections ++ formatMissingSourceDirs missingSourceDirs - ++ libraryWarnings - ++ executableWarnings - ++ executablesWarnings - ++ testsWarnings - ++ benchmarksWarnings + ++ executableWarning ++ extraSourceFilesWarnings ++ dataFilesWarnings @@ -590,44 +647,27 @@ Just n -> ([], n) mCustomSetup :: Maybe CustomSetup - mCustomSetup = toCustomSetup <$> mCustomSetupSection - - testsSections :: [(String, CaptureUnknownFields (Section ExecutableSection))] - testsSections = toList packageConfigTests - - benchmarkSections :: [(String, CaptureUnknownFields (Section ExecutableSection))] - benchmarkSections = toList packageConfigBenchmarks + mCustomSetup = toCustomSetup . runIdentity <$> packageConfigCustomSetup - (flagWarnings, flags) = (concatMap formatUnknownFlagFields xs, map (toFlag . fmap captureUnknownFieldsValue) xs) - where - xs :: [(String, CaptureUnknownFields FlagSection)] - xs = toList packageConfigFlags + mLibrarySection :: Maybe (Section LibrarySection) + mLibrarySection = toSectionI <$> packageConfigLibrary - formatUnknownFlagFields :: (String, CaptureUnknownFields a) -> [String] - formatUnknownFlagFields (name, fields) = map f (captureUnknownFieldsFields fields) - where f field = "Ignoring unknown field " ++ show field ++ " for flag " ++ show name + toSections :: Maybe (Map String (Identity (WithCommonOptions a Identity CSources JsSources))) -> Map String (Section a) + toSections = fmap toSectionI . fromMaybe mempty - toList :: Maybe (Map String a) -> [(String, a)] - toList = Map.toList . fromMaybe mempty + internalLibrariesSections :: Map String (Section LibrarySection) + internalLibrariesSections = toSections packageConfigInternalLibraries - mCustomSetupSection :: Maybe CustomSetupSection - mCustomSetupSection = captureUnknownFieldsValue <$> packageConfigCustomSetup + testSections :: Map String (Section ExecutableSection) + testSections = toSections packageConfigTests - mLibrarySection :: Maybe (Section LibrarySection) - mLibrarySection = captureUnknownFieldsValue <$> packageConfigLibrary + benchmarkSections :: Map String (Section ExecutableSection) + benchmarkSections = toSections packageConfigBenchmarks - formatUnknownFields :: String -> [FieldName] -> [String] - formatUnknownFields name = map f . sort - where - f field = "Ignoring unknown field " ++ show field ++ " in " ++ name + flags = map (toFlag . fmap runIdentity) $ toList packageConfigFlags - formatUnknownSectionFields :: Bool -> String -> [(String, CaptureUnknownFields a)] -> [String] - formatUnknownSectionFields showSect sectionType = concatMap f . map (fmap captureUnknownFieldsFields) - where - f :: (String, [String]) -> [String] - f (sect, fields) = formatUnknownFields - (sectionType ++ " section" ++ if showSect then " " ++ show sect else "") - fields + toList :: Maybe (Map String a) -> [(String, a)] + toList = Map.toList . fromMaybe mempty formatMissingSourceDirs = map f where @@ -659,73 +699,173 @@ where fromGithub = (++ "/issues") . sourceRepositoryUrl <$> github -expandCSources :: FilePath -> Section a -> IO ([String], Section a) -expandCSources dir sect@Section{..} = do - (warnings, files) <- expandGlobs "c-sources" dir sectionCSources - return (warnings, sect {sectionCSources = files}) +type Warnings m = WriterT [String] m -expandJsSources :: FilePath -> Section a -> IO ([String], Section a) -expandJsSources dir sect@Section{..} = do - (warnings, files) <- expandGlobs "js-sources" dir sectionJsSources - return (warnings, sect {sectionJsSources = files}) +extractUnknownFieldWarnings :: forall m. Monad m => ParseConfig -> Warnings m (Config Identity ParseCSources ParseJsSources) +extractUnknownFieldWarnings = warnGlobal >=> bitraverse return warnSections + where + t :: Monad capture => Traverse capture capture Identity cSources cSources jsSources jsSources + t = Traverse (fmap Identity) return return -expandForeignSources :: FilePath -> Section a -> IO ([String], Section a) -expandForeignSources dir sect = do - (cWarnings, sect_) <- expandCSources dir sect - (jsWarnings, sect__) <- expandJsSources dir sect_ - return (cWarnings ++ jsWarnings, sect__) + warnGlobal c = warnUnknownFields In "package description" (c >>= bitraverse (traverseCommonOptions t) return) + warnSections :: ParsePackageConfig -> Warnings m (PackageConfig Identity ParseCSources ParseJsSources) + warnSections p@PackageConfig{..} = do + flags <- traverse (warnNamed For "flag" . fmap (traverseCapture t)) packageConfigFlags + customSetup <- warnUnknownFields In "custom-setup section" (traverse (traverseCapture t) packageConfigCustomSetup) + library <- warnUnknownFields In "library section" (traverse (traverseSectionConfig t) packageConfigLibrary) + internalLibraries <- warnNamedSection "internal-libraries" packageConfigInternalLibraries + executable <- warnUnknownFields In "executable section" (traverse (traverseSectionConfig t) packageConfigExecutable) + executables <- warnNamedSection "executable" packageConfigExecutables + tests <- warnNamedSection "test" packageConfigTests + benchmarks <- warnNamedSection "benchmark" packageConfigBenchmarks + return p { + packageConfigFlags = flags + , packageConfigCustomSetup = customSetup + , packageConfigLibrary = library + , packageConfigInternalLibraries = internalLibraries + , packageConfigExecutable = executable + , packageConfigExecutables = executables + , packageConfigTests = tests + , packageConfigBenchmarks = benchmarks + } + + warnNamedSection + :: String + -> Maybe (Map String (SectionConfig a CaptureUnknownFields cSources jsSources)) + -> Warnings m (Maybe (Map String (SectionConfig a Identity cSources jsSources))) + warnNamedSection sectionType = traverse (warnNamed In (sectionType ++ " section") . fmap (traverseSectionConfig t)) + + warnNamed :: Preposition -> String -> Map String (CaptureUnknownFields a) -> Warnings m (Map String a) + warnNamed preposition sect = fmap Map.fromList . mapM f . Map.toList + where + f (name, fields) = (,) name <$> (warnUnknownFields preposition (sect ++ " " ++ show name) fields) + + warnUnknownFields :: Preposition -> String -> CaptureUnknownFields a -> Warnings m a + warnUnknownFields preposition name = fmap snd . bitraverse tell return . formatUnknownFields preposition name + +expandForeignSources + :: FilePath + -> Config Identity ParseCSources ParseJsSources + -> Warnings IO (Config Identity CSources JsSources) +expandForeignSources dir = traverseConfig t + where + t = Traverse { + traverseCapture = return + , traverseCSources = expand "c-sources" + , traverseJsSources = expand "js-sources" + } + + expand fieldName xs = do + (warnings, files) <- liftIO $ expandGlobs fieldName dir (fromMaybeList xs) + tell warnings + return files + toCustomSetup :: CustomSetupSection -> CustomSetup toCustomSetup CustomSetupSection{..} = CustomSetup { customSetupDependencies = fromMaybe mempty customSetupSectionDependencies } -toLibrary :: FilePath -> String -> Section global -> Section LibrarySection -> IO ([String], Section Library) -toLibrary dir name globalOptions library = traverse fromLibrarySection sect >>= expandForeignSources dir +traverseSectionAndConditionals :: Applicative m => (Section a -> m b) -> (Section a -> m b) -> Section a -> m (Section b) +traverseSectionAndConditionals fData fConditionals sect@Section{..} = + update <$> fData sect <*> traverseConditionals sectionConditionals where - sect :: Section LibrarySection - sect = mergeSections globalOptions library - - sourceDirs :: [FilePath] - sourceDirs = sectionSourceDirs sect + update x xs = sect{sectionData = x, sectionConditionals = xs} + traverseConditionals = traverse $ traverse $ traverseSectionAndConditionals fConditionals fConditionals - fromLibrarySection :: LibrarySection -> IO Library - fromLibrarySection LibrarySection{..} = do - modules <- concat <$> mapM (getModules dir) sourceDirs - let (exposedModules, otherModules) = determineModules name modules librarySectionExposedModules librarySectionOtherModules - reexportedModules = fromMaybeList librarySectionReexportedModules - return (Library librarySectionExposed exposedModules otherModules reexportedModules) +getMentionedLibraryModules :: Section LibrarySection -> [String] +getMentionedLibraryModules = concatMap $ \ LibrarySection{..} -> + fromMaybeList librarySectionExposedModules ++ fromMaybeList librarySectionOtherModules -toExecutables :: FilePath -> String -> Section global -> [(String, Section ExecutableSection)] -> IO ([String], [Section Executable]) -toExecutables dir packageName_ globalOptions executables = do - result <- mapM toExecutable sections >>= mapM (expandForeignSources dir) - let (warnings, xs) = unzip result - return (concat warnings, xs) +toLibrary :: FilePath -> String -> Section global -> Section LibrarySection -> IO (Section Library) +toLibrary dir name globalOptions = + traverseSectionAndConditionals (fromLibrarySection True) (fromLibrarySection False) + . mergeSections emptyLibrarySection globalOptions where - sections :: [(String, Section ExecutableSection)] - sections = map (fmap $ mergeSections globalOptions) executables + fromLibrarySection topLevel sect@Section{..} = do + modules <- concat <$> mapM (getModules dir) sectionSourceDirs + let + mentionedModules = getMentionedLibraryModules sect + inferableModules = modules \\ mentionedModules + return $ action inferableModules sectionData + where + action + | topLevel = fromLibrarySectionTopLevel + | otherwise = fromLibrarySectionInConditional - toExecutable :: (String, Section ExecutableSection) -> IO (Section Executable) - toExecutable (name, sect@Section{..}) = do - (executable, ghcOptions) <- fromExecutableSection sectionData - return (sect {sectionData = executable, sectionGhcOptions = sectionGhcOptions ++ ghcOptions}) + fromLibrarySectionTopLevel inferableModules LibrarySection{..} = + Library librarySectionExposed exposedModules otherModules reexportedModules where - fromExecutableSection :: ExecutableSection -> IO (Executable, [GhcOption]) - fromExecutableSection ExecutableSection{..} = do - modules <- maybe inferModules (return . fromList) executableSectionOtherModules - return (Executable name mainSrcFile modules, ghcOptions) - where - inferModules :: IO [String] - inferModules = filterMain . (++ [pathsModule]) . concat <$> mapM (getModules dir) sectionSourceDirs + (exposedModules, otherModules) = + determineModules name inferableModules librarySectionExposedModules librarySectionOtherModules + reexportedModules = fromMaybeList librarySectionReexportedModules - pathsModule = pathsModuleFromPackageName packageName_ +fromLibrarySectionInConditional :: [String] -> LibrarySection -> Library +fromLibrarySectionInConditional inferableModules lib@(LibrarySection _ exposedModules otherModules _) = do + case (exposedModules, otherModules) of + (Nothing, Nothing) -> (fromLibrarySectionPlain lib) {libraryOtherModules = inferableModules} + _ -> fromLibrarySectionPlain lib - filterMain :: [String] -> [String] - filterMain = maybe id (filter . (/=)) (toModule $ splitDirectories executableSectionMain) +fromLibrarySectionPlain :: LibrarySection -> Library +fromLibrarySectionPlain LibrarySection{..} = Library { + libraryExposed = librarySectionExposed + , libraryExposedModules = fromMaybeList librarySectionExposedModules + , libraryOtherModules = fromMaybeList librarySectionOtherModules + , libraryReexportedModules = fromMaybeList librarySectionReexportedModules + } - (mainSrcFile, ghcOptions) = parseMain executableSectionMain +toInternalLibraries :: FilePath -> String -> Section global -> Map String (Section LibrarySection) -> IO (Map String (Section Library)) +toInternalLibraries dir packageName_ globalOptions = traverse (toLibrary dir packageName_ globalOptions) -mergeSections :: Section global -> Section a -> Section a -mergeSections globalOptions options +toExecutables :: FilePath -> String -> Section global -> Map String (Section ExecutableSection) -> IO (Map String (Section Executable)) +toExecutables dir packageName_ globalOptions = traverse (toExecutable dir packageName_ globalOptions) + +getMentionedExecutableModules :: Section ExecutableSection -> [String] +getMentionedExecutableModules = concatMap $ \ ExecutableSection{..} -> + fromMaybeList executableSectionOtherModules ++ maybe [] return (executableSectionMain >>= toModule . splitDirectories) + +toExecutable :: FilePath -> String -> Section global -> Section ExecutableSection -> IO (Section Executable) +toExecutable dir packageName_ globalOptions = + traverseSectionAndConditionals (fromExecutableSection True) (fromExecutableSection False) + . expandMain + . mergeSections emptyExecutableSection globalOptions + where + fromExecutableSection :: Bool -> Section ExecutableSection -> IO Executable + fromExecutableSection inferPathsModule sect@Section{sectionData = ExecutableSection main_ otherModules, ..} = do + modules <- maybe inferModules (return . fromList) otherModules + return (Executable main_ modules) + where + mentionedModules = getMentionedExecutableModules sect + + inferModules :: IO [String] + inferModules + | null sectionSourceDirs = return [] + | otherwise = (\\ mentionedModules) . (++ pathsModule) . concat <$> mapM (getModules dir) sectionSourceDirs + + pathsModule = case inferPathsModule of + True -> [pathsModuleFromPackageName packageName_] + False -> [] + +expandMain :: Section ExecutableSection -> Section ExecutableSection +expandMain = flatten . expand + where + expand :: Section ExecutableSection -> Section ([GhcOption], ExecutableSection) + expand = fmap go + where + go exec@ExecutableSection{..} = + let + (mainSrcFile, ghcOptions) = maybe (Nothing, []) (first Just . parseMain) executableSectionMain + in + (ghcOptions, exec{executableSectionMain = mainSrcFile}) + + flatten :: Section ([GhcOption], ExecutableSection) -> Section ExecutableSection + flatten sect@Section{sectionData = (ghcOptions, exec), ..} = sect{ + sectionData = exec + , sectionGhcOptions = sectionGhcOptions ++ ghcOptions + , sectionConditionals = map (fmap flatten) sectionConditionals + } + +mergeSections :: a -> Section global -> Section a -> Section a +mergeSections a globalOptions options = Section { sectionData = sectionData options , sectionSourceDirs = sectionSourceDirs globalOptions ++ sectionSourceDirs options @@ -747,14 +887,15 @@ , sectionLdOptions = sectionLdOptions globalOptions ++ sectionLdOptions options , sectionBuildable = sectionBuildable options <|> sectionBuildable globalOptions , sectionDependencies = sectionDependencies options <> sectionDependencies globalOptions - , sectionConditionals = sectionConditionals globalOptions ++ sectionConditionals options + , sectionConditionals = map (fmap (a <$)) (sectionConditionals globalOptions) ++ sectionConditionals options , sectionBuildTools = sectionBuildTools options <> sectionBuildTools globalOptions } -toSection :: a -> CommonOptions -> ([FieldName], Section a) -toSection a CommonOptions{..} - = ( concat unknownFields - , Section { +toSectionI :: Identity (WithCommonOptions a Identity CSources JsSources) -> Section a +toSectionI = toSection . runIdentity + +toSection :: WithCommonOptions a Identity CSources JsSources -> Section a +toSection (Product CommonOptions{..} a) = Section { sectionData = a , sectionSourceDirs = fromMaybeList commonOptionsSourceDirs , sectionDefaultExtensions = fromMaybeList commonOptionsDefaultExtensions @@ -764,8 +905,8 @@ , sectionGhcjsOptions = fromMaybeList commonOptionsGhcjsOptions , sectionCppOptions = fromMaybeList commonOptionsCppOptions , sectionCcOptions = fromMaybeList commonOptionsCcOptions - , sectionCSources = fromMaybeList commonOptionsCSources - , sectionJsSources = fromMaybeList commonOptionsJsSources + , sectionCSources = commonOptionsCSources + , sectionJsSources = commonOptionsJsSources , sectionExtraLibDirs = fromMaybeList commonOptionsExtraLibDirs , sectionExtraLibraries = fromMaybeList commonOptionsExtraLibraries , sectionExtraFrameworksDirs = fromMaybeList commonOptionsExtraFrameworksDirs @@ -778,15 +919,13 @@ , sectionConditionals = conditionals , sectionBuildTools = fromMaybe mempty commonOptionsBuildTools } - ) where - (unknownFields, conditionals) = unzip (map toConditional $ fromMaybeList commonOptionsWhen) + conditionals = map toConditional (fromMaybeList commonOptionsWhen) -toConditional :: ConditionalSection -> ([FieldName], Conditional) -toConditional x = case x of - ThenElseConditional (CaptureUnknownFields fields (ThenElse condition (CaptureUnknownFields fieldsThen then_) (CaptureUnknownFields fieldsElse else_))) -> - (fields ++ fieldsThen ++ fieldsElse, Conditional condition (() <$ then_) (Just (() <$ else_))) - FlatConditional (CaptureUnknownFields fields sect) -> (fields, Conditional (conditionCondition $ sectionData sect) (() <$ sect) Nothing) + toConditional :: ConditionalSection a Identity CSources JsSources -> Conditional (Section a) + toConditional x = case x of + FlatConditional (Identity (Product sect c)) -> Conditional (conditionCondition c) (toSection sect) Nothing + ThenElseConditional (Identity (ThenElse condition then_ else_)) -> Conditional condition (toSectionI then_) (Just $ toSectionI else_) pathsModuleFromPackageName :: String -> String pathsModuleFromPackageName name = "Paths_" ++ map f name diff --git a/src/Hpack/Dependency.hs b/src/Hpack/Dependency.hs --- a/src/Hpack/Dependency.hs +++ b/src/Hpack/Dependency.hs @@ -11,9 +11,6 @@ , githubBaseUrl ) where -import Prelude () -import Prelude.Compat - import qualified Data.Text as T import Text.PrettyPrint (renderStyle, Style(..), Mode(..)) import Control.Monad diff --git a/src/Hpack/FormattingHints.hs b/src/Hpack/FormattingHints.hs --- a/src/Hpack/FormattingHints.hs +++ b/src/Hpack/FormattingHints.hs @@ -15,16 +15,12 @@ #endif ) where -import Prelude () -import Prelude.Compat - import Data.Char import Data.Maybe -import Data.List.Compat +import Data.List import Control.Applicative import Hpack.Render --- import Hpack.Util data FormattingHints = FormattingHints { formattingHintsFieldOrder :: [String] diff --git a/src/Hpack/Options.hs b/src/Hpack/Options.hs --- a/src/Hpack/Options.hs +++ b/src/Hpack/Options.hs @@ -1,8 +1,5 @@ module Hpack.Options where -import Prelude () -import Prelude.Compat - data ParseResult = Help | PrintVersion | Run Options | ParseError deriving (Eq, Show) diff --git a/src/Hpack/Render.hs b/src/Hpack/Render.hs --- a/src/Hpack/Render.hs +++ b/src/Hpack/Render.hs @@ -24,11 +24,8 @@ #endif ) where -import Prelude () -import Prelude.Compat - import Data.String -import Data.List.Compat +import Data.List data Value = Literal String diff --git a/src/Hpack/Run.hs b/src/Hpack/Run.hs --- a/src/Hpack/Run.hs +++ b/src/Hpack/Run.hs @@ -12,6 +12,8 @@ , defaultRenderSettings #ifdef TEST , renderConditional +, renderLibraryFields +, renderExecutableFields , renderFlag , renderSourceRepository , renderDirectories @@ -19,15 +21,13 @@ #endif ) where -import Prelude () -import Prelude.Compat - import Control.Monad import Data.Char import Data.Maybe -import Data.List.Compat -import System.Exit.Compat +import Data.List +import System.Exit import System.FilePath +import Data.Map.Lazy (Map) import qualified Data.Map.Lazy as Map import Hpack.Util @@ -88,6 +88,7 @@ customSetup , map renderFlag packageFlags , library + , renderInternalLibraries packageInternalLibraries , renderExecutables packageExecutables , renderTests packageTests , renderBenchmarks packageBenchmarks @@ -123,15 +124,25 @@ cabalVersion :: Maybe String cabalVersion = maximum [ Just ">= 1.10" - , packageLibrary >>= libCabalVersion + , packageCabalVersion + , packageLibrary >>= libraryCabalVersion + , internalLibsCabalVersion packageInternalLibraries ] where - libCabalVersion :: Section Library -> Maybe String - libCabalVersion sect = ">= 1.21" <$ guard (hasReexportedModules sect) + packageCabalVersion :: Maybe String + packageCabalVersion + | isJust packageCustomSetup = Just ">= 1.24" + | otherwise = Nothing + libraryCabalVersion :: Section Library -> Maybe String + libraryCabalVersion sect = ">= 1.22" <$ guard (hasReexportedModules sect) + hasReexportedModules :: Section Library -> Bool hasReexportedModules = not . null . libraryReexportedModules . sectionData + internalLibsCabalVersion :: Map String (Section Library) -> Maybe String + internalLibsCabalVersion internalLibraries = ">= 2.0" <$ guard (not (Map.null internalLibraries)) + sortSectionFields :: [(String, [String])] -> [Element] -> [Element] sortSectionFields sectionsFieldOrder = go where @@ -169,34 +180,43 @@ where description = maybe [] (return . Field "description" . Literal) flagDescription -renderExecutables :: [Section Executable] -> [Element] -renderExecutables = map renderExecutable +renderInternalLibraries :: Map String (Section Library) -> [Element] +renderInternalLibraries = map renderInternalLibrary . Map.toList -renderExecutable :: Section Executable -> Element -renderExecutable sect@(sectionData -> Executable{..}) = - Stanza ("executable " ++ executableName) (renderExecutableSection sect) +renderInternalLibrary :: (String, Section Library) -> Element +renderInternalLibrary (name, sect) = + Stanza ("library " ++ name) (renderLibrarySection sect) -renderTests :: [Section Executable] -> [Element] -renderTests = map renderTest +renderExecutables :: Map String (Section Executable) -> [Element] +renderExecutables = map renderExecutable . Map.toList -renderTest :: Section Executable -> Element -renderTest sect@(sectionData -> Executable{..}) = - Stanza ("test-suite " ++ executableName) +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) (Field "type" "exitcode-stdio-1.0" : renderExecutableSection sect) -renderBenchmarks :: [Section Executable] -> [Element] -renderBenchmarks = map renderBenchmark +renderBenchmarks :: Map String (Section Executable) -> [Element] +renderBenchmarks = map renderBenchmark . Map.toList -renderBenchmark :: Section Executable -> Element -renderBenchmark sect@(sectionData -> Executable{..}) = - Stanza ("benchmark " ++ executableName) +renderBenchmark :: (String, Section Executable) -> Element +renderBenchmark (name, sect) = + Stanza ("benchmark " ++ name) (Field "type" "exitcode-stdio-1.0" : renderExecutableSection sect) renderExecutableSection :: Section Executable -> [Element] -renderExecutableSection sect@(sectionData -> Executable{..}) = - mainIs : renderSection sect ++ [otherModules, defaultLanguage] +renderExecutableSection sect = renderSection renderExecutableFields sect ++ [defaultLanguage] + +renderExecutableFields :: Executable -> [Element] +renderExecutableFields Executable{..} = mainIs ++ [otherModules] where - mainIs = Field "main-is" (Literal executableMain) + mainIs = maybe [] (return . Field "main-is" . Literal) executableMain otherModules = renderOtherModules executableOtherModules renderCustomSetup :: CustomSetup -> Element @@ -204,20 +224,25 @@ Stanza "custom-setup" [renderDependencies "setup-depends" customSetupDependencies] renderLibrary :: Section Library -> Element -renderLibrary sect@(sectionData -> Library{..}) = Stanza "library" $ - renderSection sect ++ +renderLibrary sect = Stanza "library" $ renderLibrarySection sect + +renderLibrarySection :: Section Library -> [Element] +renderLibrarySection sect = renderSection renderLibraryFields sect ++ [defaultLanguage] + +renderLibraryFields :: Library -> [Element] +renderLibraryFields Library{..} = maybe [] (return . renderExposed) libraryExposed ++ [ renderExposedModules libraryExposedModules , renderOtherModules libraryOtherModules , renderReexportedModules libraryReexportedModules - , defaultLanguage ] renderExposed :: Bool -> Element renderExposed = Field "exposed" . Literal . show -renderSection :: Section a -> [Element] -renderSection Section{..} = [ +renderSection :: (a -> [Element]) -> Section a -> [Element] +renderSection renderSectionData Section{..} = + renderSectionData sectionData ++ [ renderDirectories "hs-source-dirs" sectionSourceDirs , renderDefaultExtensions sectionDefaultExtensions , renderOtherExtensions sectionOtherExtensions @@ -239,14 +264,14 @@ , renderDependencies "build-tools" sectionBuildTools ] ++ maybe [] (return . renderBuildable) sectionBuildable - ++ map renderConditional sectionConditionals + ++ map (renderConditional renderSectionData) sectionConditionals -renderConditional :: Conditional -> Element -renderConditional (Conditional condition sect mElse) = case mElse of +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 else_) + Just else_ -> Group if_ (Stanza "else" $ renderSection renderSectionData else_) where - if_ = Stanza ("if " ++ condition) (renderSection sect) + if_ = Stanza ("if " ++ condition) (renderSection renderSectionData sect) defaultLanguage :: Element defaultLanguage = Field "default-language" "Haskell2010" diff --git a/src/Hpack/UnknownFields.hs b/src/Hpack/UnknownFields.hs new file mode 100644 --- /dev/null +++ b/src/Hpack/UnknownFields.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +module Hpack.UnknownFields ( + FieldName +, HasFieldNames(..) +, hyphenize + +, CaptureUnknownFields +, Preposition(..) +, formatUnknownFields +) where + +import Control.Monad +import Data.Aeson.Types +import Data.Data +import qualified Data.HashMap.Lazy as HashMap +import Data.List +import qualified Data.Text as T +import GHC.Generics + +import Hpack.GenericsUtil + +newtype FieldName = FieldName {unFieldName :: String} + +class HasFieldNames a where + fieldNames :: Proxy a -> [FieldName] + + default fieldNames :: (HasTypeName a d m, Selectors (Rep a)) => Proxy a -> [FieldName] + fieldNames proxy = map (FieldName . hyphenize (typeName proxy)) (selectors proxy) + + ignoreUnderscoredUnknownFields :: Proxy a -> Bool + ignoreUnderscoredUnknownFields _ = False + +hyphenize :: String -> String -> String +hyphenize name = +#if MIN_VERSION_aeson(0,10,0) + camelTo2 +#else + camelTo +#endif + '-' . drop (length name) . dropWhile (== '_') + +data CaptureUnknownFields a = CaptureUnknownFields [FieldName] a + deriving Functor + +instance Applicative CaptureUnknownFields where + pure = return + (<*>) = ap + +instance Monad CaptureUnknownFields where + return = CaptureUnknownFields mempty + (CaptureUnknownFields xs x) >>= f = CaptureUnknownFields (xs `mappend` ys) y + where + CaptureUnknownFields ys y = f x + +captureUnknownFields :: forall a. (HasFieldNames a, FromJSON a) => Value -> Parser (CaptureUnknownFields a) +captureUnknownFields v = CaptureUnknownFields unknown <$> parseJSON v + where + unknown = getUnknownFields v (Proxy :: Proxy a) + +instance (HasFieldNames a, FromJSON a) => FromJSON (CaptureUnknownFields a) where + parseJSON = captureUnknownFields + +getUnknownFields :: forall a. HasFieldNames a => Value -> Proxy a -> [FieldName] +getUnknownFields v _ = case v of + Object o -> map FieldName (ignoreUnderscored unknown) + where + unknown = keys \\ fields + keys = map T.unpack (HashMap.keys o) + fields = map unFieldName $ fieldNames (Proxy :: Proxy a) + ignoreUnderscored + | ignoreUnderscoredUnknownFields (Proxy :: Proxy a) = filter (not . isPrefixOf "_") + | otherwise = id + _ -> [] + +data Preposition = In | For + +formatUnknownFields :: Preposition -> String -> CaptureUnknownFields a -> ([String], a) +formatUnknownFields p name (CaptureUnknownFields unknownFields a) = (formatUnknownFields_ preposition name unknownFields, a) + where + preposition = case p of + In -> "in" + For -> "for" + +formatUnknownFields_ :: String -> String -> [FieldName] -> [String] +formatUnknownFields_ preposition name = map f + where + f (FieldName field) = "Ignoring unknown field " ++ show field ++ " " ++ preposition ++ " " ++ name diff --git a/src/Hpack/Utf8.hs b/src/Hpack/Utf8.hs new file mode 100644 --- /dev/null +++ b/src/Hpack/Utf8.hs @@ -0,0 +1,61 @@ +module Hpack.Utf8 ( + encodeUtf8 +, readFile +, writeFile +, putStr +, hPutStr +, hPutStrLn +) where + +import Prelude hiding (readFile, writeFile, putStr) + +import qualified Data.Text as T +import qualified Data.Text.Encoding as Encoding +import Data.Text.Encoding.Error (lenientDecode) +import qualified Data.ByteString as B +import System.IO (Handle, stdout, IOMode(..), withFile, Newline(..), nativeNewline) + +encodeUtf8 :: String -> B.ByteString +encodeUtf8 = Encoding.encodeUtf8 . T.pack + +decodeUtf8 :: B.ByteString -> String +decodeUtf8 = T.unpack . Encoding.decodeUtf8With lenientDecode + +encodeText :: String -> B.ByteString +encodeText = encodeUtf8 . encodeNewlines + +decodeText :: B.ByteString -> String +decodeText = decodeNewlines . decodeUtf8 + +encodeNewlines :: String -> String +encodeNewlines = case nativeNewline of + LF -> id + CRLF -> go + where + go xs = case xs of + '\n' : ys -> '\r' : '\n' : ys + y : ys -> y : go ys + [] -> [] + +decodeNewlines :: String -> String +decodeNewlines = go + where + go xs = case xs of + '\r' : '\n' : ys -> '\n' : go ys + y : ys -> y : go ys + [] -> [] + +readFile :: FilePath -> IO String +readFile = fmap decodeText . B.readFile + +writeFile :: FilePath -> String -> IO () +writeFile name xs = withFile name WriteMode (`hPutStr` xs) + +putStr :: String -> IO () +putStr = hPutStr stdout + +hPutStrLn :: Handle -> String -> IO () +hPutStrLn h xs = hPutStr h xs >> hPutStr h "\n" + +hPutStr :: Handle -> String -> IO () +hPutStr h = B.hPutStr h . encodeText diff --git a/src/Hpack/Util.hs b/src/Hpack/Util.hs --- a/src/Hpack/Util.hs +++ b/src/Hpack/Util.hs @@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} module Hpack.Util ( List(..) , GhcOption @@ -15,25 +17,16 @@ , expandGlobs , sort , lexicographically -, encodeUtf8 , Hash , sha256 ) where -import Prelude () -import Prelude.Compat - import Control.Exception -import Control.Monad.Compat +import Control.Monad import Data.Aeson.Types -import qualified Data.ByteString as B import Data.Char -import Data.Data -import Data.List.Compat hiding (sort) +import Data.List hiding (sort) import Data.Ord -import qualified Data.Text as T -import qualified Data.Text.Encoding as Encoding -import Data.Text.Encoding.Error (lenientDecode) import System.IO.Error import System.Directory import System.FilePath @@ -42,6 +35,7 @@ import Crypto.Hash import Hpack.Haskell +import Hpack.Utf8 as Utf8 sort :: [String] -> [String] sort = sortBy (comparing lexicographically) @@ -50,7 +44,7 @@ lexicographically x = (map toLower x, x) newtype List a = List {fromList :: [a]} - deriving (Eq, Show, Data, Typeable) + deriving (Eq, Show, Functor, Foldable, Traversable) instance FromJSON a => FromJSON (List a) where parseJSON v = List <$> case v of @@ -113,8 +107,8 @@ tryReadFile :: FilePath -> IO (Maybe String) tryReadFile file = do - r <- tryJust (guard . isDoesNotExistError) (B.readFile file) - return $ either (const Nothing) (Just . T.unpack . Encoding.decodeUtf8With lenientDecode) r + r <- tryJust (guard . isDoesNotExistError) (Utf8.readFile file) + return $ either (const Nothing) Just r toPosixFilePath :: FilePath -> FilePath toPosixFilePath = Posix.joinPath . splitDirectories @@ -154,10 +148,7 @@ , errorRecovery = True } -encodeUtf8 :: String -> B.ByteString -encodeUtf8 = Encoding.encodeUtf8 . T.pack - type Hash = String sha256 :: String -> Hash -sha256 c = show (hash (encodeUtf8 c) :: Digest SHA256) +sha256 c = show (hash (Utf8.encodeUtf8 c) :: Digest SHA256) diff --git a/test/EndToEndSpec.hs b/test/EndToEndSpec.hs new file mode 100644 --- /dev/null +++ b/test/EndToEndSpec.hs @@ -0,0 +1,737 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ConstraintKinds #-} +module EndToEndSpec (spec) where + +import Helper + +import System.Exit +import Data.Maybe +import Data.List +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) + +spec :: Spec +spec = around_ (inTempDirectoryNamed "foo") $ do + describe "hpack" $ do + describe "dependencies" $ do + it "accepts single dependency" $ do + [i| + executable: + dependencies: base + |] `shouldRenderTo` executable "foo" [i| + build-depends: + base + |] + + it "accepts list of dependencies" $ do + [i| + executable: + dependencies: + - base + - transformers + |] `shouldRenderTo` executable "foo" [i| + build-depends: + base + , transformers + |] + + context "with both global and section specific dependencies" $ do + it "combines dependencies" $ do + [i| + dependencies: + - base + executable: + dependencies: hspec + |] `shouldRenderTo` executable "foo" [i| + build-depends: + base + , hspec + |] + + it "gives section specific dependencies precedence" $ do + [i| + dependencies: + - base + executable: + dependencies: base >= 2 + |] `shouldRenderTo` executable "foo" [i| + build-depends: + base >=2 + |] + + describe "include-dirs" $ do + it "accepts include-dirs" $ do + [i| + include-dirs: + - foo + - bar + executable: {} + |] `shouldRenderTo` executable "foo" [i| + include-dirs: + foo + bar + |] + + describe "install-includes" $ do + it "accepts install-includes" $ do + [i| + install-includes: + - foo.h + - bar.h + executable: {} + |] `shouldRenderTo` executable "foo" [i| + install-includes: + foo.h + bar.h + |] + + describe "js-sources" $ before_ (touch "foo.js" >> touch "jsbits/bar.js") $ do + it "accepts js-sources" $ do + [i| + executable: + js-sources: + - foo.js + - jsbits/*.js + |] `shouldRenderTo` executable "foo" [i| + js-sources: + foo.js + jsbits/bar.js + |] + + it "accepts global js-sources" $ do + [i| + js-sources: + - foo.js + - jsbits/*.js + executable: {} + |] `shouldRenderTo` executable "foo" [i| + js-sources: + foo.js + jsbits/bar.js + |] + describe "extra-lib-dirs" $ do + it "accepts extra-lib-dirs" $ do + [i| + extra-lib-dirs: + - foo + - bar + executable: {} + |] `shouldRenderTo` executable "foo" [i| + extra-lib-dirs: + foo + bar + |] + + describe "extra-libraries" $ do + it "accepts extra-libraries" $ do + [i| + extra-libraries: + - foo + - bar + executable: {} + |] `shouldRenderTo` executable "foo" [i| + extra-libraries: + foo + bar + |] + + describe "extra-frameworks-dirs" $ do + it "accepts extra-frameworks-dirs" $ do + [i| + extra-frameworks-dirs: + - foo + - bar + executable: {} + |] `shouldRenderTo` executable "foo" [i| + extra-frameworks-dirs: + foo + bar + |] + + describe "frameworks" $ do + it "accepts frameworks" $ do + [i| + frameworks: + - foo + - bar + executable: {} + |] `shouldRenderTo` executable "foo" [i| + frameworks: + foo + bar + |] + + describe "c-sources" $ before_ (touch "cbits/foo.c" >> touch "cbits/bar.c") $ do + context "with internal-libraries" $ do + it "warns when a glob pattern does not match any files" $ do + [i| + name: foo + internal-libraries: + bar: + c-sources: foo/*.c + |] `shouldWarn` pure "Specified pattern \"foo/*.c\" for c-sources does not match any files" + + context "with library" $ do + it "accepts global c-sources" $ do + [i| + c-sources: cbits/*.c + library: {} + |] `shouldRenderTo` library [i| + other-modules: + Paths_foo + c-sources: + cbits/bar.c + cbits/foo.c + |] + + it "accepts c-sources" $ do + [i| + library: + c-sources: cbits/*.c + |] `shouldRenderTo` library [i| + other-modules: + Paths_foo + c-sources: + cbits/bar.c + cbits/foo.c + |] + + it "accepts c-sources in conditional" $ do + [i| + library: + when: + condition: os(windows) + c-sources: cbits/*.c + |] `shouldRenderTo` library [i| + other-modules: + Paths_foo + if os(windows) + c-sources: + cbits/bar.c + cbits/foo.c + |] + + context "with executables" $ do + it "accepts global c-sources" $ do + [i| + c-sources: cbits/*.c + executables: + foo: {} + |] `shouldRenderTo` executable "foo" [i| + c-sources: + cbits/bar.c + cbits/foo.c + |] + + it "accepts c-sources" $ do + [i| + executables: + foo: + c-sources: cbits/*.c + |] `shouldRenderTo` executable "foo" [i| + c-sources: + cbits/bar.c + cbits/foo.c + |] + + context "with custom-setup" $ do + it "warns on unknown fields" $ do + [i| + name: foo + custom-setup: + foo: 1 + bar: 2 + |] `shouldWarn` [ + "Ignoring unknown field \"bar\" in custom-setup section" + , "Ignoring unknown field \"foo\" in custom-setup section" + ] + + it "accepts dependencies" $ do + [i| + custom-setup: + dependencies: + - base + |] `shouldRenderTo` customSetup [i| + setup-depends: + base + |] + + it "leaves build-type alone, if it exists" $ do + [i| + build-type: Make + custom-setup: + dependencies: + - base + |] `shouldRenderTo` (customSetup [i| + setup-depends: + base + |]) {packageBuildType = "Make"} + + context "with library" $ do + it "accepts reexported-modules" $ do + [i| + library: + reexported-modules: Baz + |] `shouldRenderTo` (library [i| + reexported-modules: + Baz + other-modules: + Paths_foo + |]) {packageCabalVersion = ">= 1.22"} + + context "when inferring modules" $ do + context "with exposed-modules" $ do + it "infers other-modules" $ do + touch "src/Foo.hs" + touch "src/Bar.hs" + [i| + library: + source-dirs: src + exposed-modules: Foo + |] `shouldRenderTo` library [i| + hs-source-dirs: + src + exposed-modules: + Foo + other-modules: + Bar + Paths_foo + |] + + context "with other-modules" $ do + it "infers exposed-modules" $ do + touch "src/Foo.hs" + touch "src/Bar.hs" + [i| + library: + source-dirs: src + other-modules: Bar + |] `shouldRenderTo` library [i| + hs-source-dirs: + src + exposed-modules: + Foo + other-modules: + Bar + |] + + context "with both exposed-modules and other-modules" $ do + it "doesn't infer any modules" $ do + touch "src/Foo.hs" + touch "src/Bar.hs" + [i| + library: + source-dirs: src + exposed-modules: Foo + other-modules: Bar + |] `shouldRenderTo` library [i| + hs-source-dirs: + src + exposed-modules: + Foo + other-modules: + Bar + |] + + context "with neither exposed-modules nor other-modules" $ do + it "infers exposed-modules" $ do + touch "src/Foo.hs" + touch "src/Bar.hs" + [i| + library: + source-dirs: src + |] `shouldRenderTo` library [i| + hs-source-dirs: + src + exposed-modules: + Bar + Foo + other-modules: + Paths_foo + |] + + context "with a conditional" $ do + it "doesn't infer any modules mentioned in that conditional" $ do + touch "src/Foo.hs" + touch "src/Bar.hs" + [i| + library: + source-dirs: src + when: + condition: os(windows) + exposed-modules: Foo + |] `shouldRenderTo` library [i| + hs-source-dirs: + src + if os(windows) + exposed-modules: + Foo + exposed-modules: + Bar + other-modules: + Paths_foo + |] + + context "with a source-dir inside the conditional" $ do + it "infers other-modules" $ do + touch "windows/Foo.hs" + [i| + library: + when: + condition: os(windows) + source-dirs: windows + |] `shouldRenderTo` library [i| + other-modules: + Paths_foo + if os(windows) + other-modules: + Foo + hs-source-dirs: + windows + |] + + context "with internal-libraries" $ do + it "accepts internal-libraries" $ do + touch "src/Foo.hs" + [i| + internal-libraries: + bar: + source-dirs: src + |] `shouldRenderTo` internalLibrary "bar" [i| + exposed-modules: + Foo + other-modules: + Paths_foo + hs-source-dirs: + src + |] + + it "warns on unknown fields" $ do + [i| + name: foo + internal-libraries: + bar: + baz: 42 + |] `shouldWarn` pure "Ignoring unknown field \"baz\" in internal-libraries section \"bar\"" + + it "warns on missing source-dirs" $ do + [i| + name: foo + internal-libraries: + bar: + source-dirs: src + |] `shouldWarn` pure "Specified source-dir \"src\" does not exist" + + context "with executables" $ do + it "accepts arbitrary entry points as main" $ do + touch "src/Foo.hs" + touch "src/Bar.hs" + [i| + executables: + foo: + source-dirs: src + main: Foo + |] `shouldRenderTo` executable "foo" [i| + main-is: Foo.hs + ghc-options: -main-is Foo + hs-source-dirs: + src + other-modules: + Bar + Paths_foo + |] + + context "when inferring modules" $ do + it "infers other-modules" $ do + touch "src/Main.hs" + touch "src/Foo.hs" + [i| + executables: + foo: + main: Main.hs + source-dirs: src + |] `shouldRenderTo` executable "foo" [i| + main-is: Main.hs + hs-source-dirs: + src + other-modules: + Foo + Paths_foo + |] + + it "allows to specify other-modules" $ do + touch "src/Foo.hs" + touch "src/Bar.hs" + [i| + executables: + foo: + main: Main.hs + source-dirs: src + other-modules: Baz + |] `shouldRenderTo` executable "foo" [i| + main-is: Main.hs + hs-source-dirs: + src + other-modules: + Baz + |] + context "with conditional" $ do + it "doesn't infer any modules mentioned in that conditional" $ do + touch "src/Foo.hs" + touch "src/Bar.hs" + [i| + executables: + foo: + source-dirs: src + when: + condition: os(windows) + other-modules: Foo + |] `shouldRenderTo` executable "foo" [i| + other-modules: + Bar + Paths_foo + hs-source-dirs: + src + if os(windows) + other-modules: + Foo + |] + + it "infers other-modules" $ do + touch "src/Foo.hs" + touch "windows/Bar.hs" + [i| + executables: + foo: + source-dirs: src + when: + condition: os(windows) + source-dirs: windows + |] `shouldRenderTo` executable "foo" [i| + other-modules: + Foo + Paths_foo + hs-source-dirs: + src + if os(windows) + other-modules: + Bar + hs-source-dirs: + windows + |] + + context "with conditional" $ do + it "does not apply global options" $ do + -- related bug: https://github.com/sol/hpack/issues/214 + [i| + ghc-options: -Wall + executables: + foo: + when: + condition: os(windows) + main: Foo.hs + |] `shouldRenderTo` executable "foo" [i| + ghc-options: -Wall + if os(windows) + main-is: Foo.hs + |] + + it "accepts executable-specific fields" $ do + [i| + executables: + foo: + when: + condition: os(windows) + main: Foo + |] `shouldRenderTo` executable "foo" [i| + if os(windows) + main-is: Foo.hs + ghc-options: -main-is Foo + |] + + describe "when" $ do + it "accepts conditionals" $ do + [i| + when: + condition: os(windows) + dependencies: Win32 + executable: {} + |] `shouldRenderTo` executable "foo" [i| + if os(windows) + build-depends: + Win32 + |] + it "warns on unknown fields" $ do + [i| + name: foo + foo: 23 + when: + - condition: os(windows) + bar: 23 + when: + condition: os(windows) + bar2: 23 + - condition: os(windows) + baz: 23 + |] `shouldWarn` [ + "Ignoring unknown field \"foo\" in package description" + , "Ignoring unknown field \"bar\" in package description" + , "Ignoring unknown field \"bar2\" in package description" + , "Ignoring unknown field \"baz\" in package description" + ] + + context "when parsing conditionals with else-branch" $ do + it "accepts conditionals with else-branch" $ do + [i| + when: + condition: os(windows) + then: + dependencies: Win32 + else: + dependencies: unix + executable: {} + |] `shouldRenderTo` executable "foo" [i| + if os(windows) + build-depends: + Win32 + else + build-depends: + unix + |] + + it "rejects invalid conditionals" $ do + [i| + when: + condition: os(windows) + then: + dependencies: Win32 + else: null + |] `shouldFailWith` "package.yaml: Error in $.when.else: expected record (:*:), encountered Null" + + it "warns on unknown fields" $ do + [i| + name: foo + when: + condition: os(windows) + foo: null + then: + bar: null + else: + when: + condition: os(windows) + then: {} + else: + baz: null + |] `shouldWarn` [ + "Ignoring unknown field \"foo\" in package description" + , "Ignoring unknown field \"bar\" in package description" + , "Ignoring unknown field \"baz\" in package description" + ] + +run :: FilePath -> String -> IO ([String], String) +run c old = run_ c old >>= either die return + +run_ :: FilePath -> String -> IO (Either String ([String], String)) +run_ c old = do + mPackage <- readPackageConfig c + return $ case mPackage of + Right (warnings, pkg) -> + let + FormattingHints{..} = sniffFormattingHints old + alignment = fromMaybe 0 formattingHintsAlignment + settings = formattingHintsRenderSettings + output = Hpack.renderPackage settings alignment formattingHintsFieldOrder formattingHintsSectionsFieldOrder pkg + in + Right (warnings, output) + Left err -> Left err + +newtype PlainString = PlainString String + deriving Eq + +instance Show PlainString where + show (PlainString xs) = xs + +shouldRenderTo :: HasCallStack => String -> Package -> Expectation +shouldRenderTo input p = do + writeFile packageConfig input + (_ , output) <- run packageConfig expected + PlainString (dropEmptyLines output) `shouldBe` PlainString expected + where + expected = dropEmptyLines (renderPackage p) + dropEmptyLines = unlines . filter (not . null) . lines + +shouldWarn :: HasCallStack => String -> [String] -> Expectation +shouldWarn input expected = do + writeFile packageConfig input + (warnings, _) <- run packageConfig "" + sort warnings `shouldBe` sort expected + +shouldFailWith :: HasCallStack => String -> String -> Expectation +shouldFailWith input expected = do + writeFile packageConfig input + run_ packageConfig "" `shouldReturn` Left expected + +customSetup :: String -> Package +customSetup a = (package content) {packageCabalVersion = ">= 1.24", packageBuildType = "Custom"} + where + content = [i| +custom-setup +#{indentBy 2 $ unindent a} +|] + +library :: String -> Package +library l = package content + where + content = [i| +library +#{indentBy 2 $ unindent l} + default-language: Haskell2010 +|] + +internalLibrary :: String -> String -> Package +internalLibrary name e = (package content) {packageCabalVersion = ">= 2.0"} + where + content = [i| +library #{name} +#{indentBy 2 $ unindent e} + default-language: Haskell2010 +|] + +executable :: String -> String -> Package +executable name e = package content + where + content = [i| +executable #{name} +#{indentBy 2 $ unindent e} + default-language: Haskell2010 +|] + +package :: String -> Package +package = Package "foo" "Simple" ">= 1.10" + +data Package = Package { + packageName :: String +, packageBuildType :: String +, packageCabalVersion :: String +, packageContent :: String +} + +renderPackage :: Package -> String +renderPackage Package{..} = unindent [i| +name: #{packageName} +version: 0.0.0 +build-type: #{packageBuildType} +cabal-version: #{packageCabalVersion} + +#{unindent packageContent} +|] + +indentBy :: Int -> String -> String +indentBy n = unlines . map (replicate n ' ' ++) . lines diff --git a/test/Hpack/CabalFileSpec.hs b/test/Hpack/CabalFileSpec.hs --- a/test/Hpack/CabalFileSpec.hs +++ b/test/Hpack/CabalFileSpec.hs @@ -3,7 +3,7 @@ import Helper import Test.QuickCheck import Data.Version (showVersion) -import Control.Monad.Compat +import Control.Monad import Paths_hpack (version) diff --git a/test/Hpack/ConfigSpec.hs b/test/Hpack/ConfigSpec.hs --- a/test/Hpack/ConfigSpec.hs +++ b/test/Hpack/ConfigSpec.hs @@ -1,6 +1,8 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Hpack.ConfigSpec ( spec @@ -14,9 +16,9 @@ import Data.Aeson.Types import Data.String.Interpolate.IsString import Control.Arrow +import GHC.Exts import System.Directory (createDirectory) -import Data.Yaml -import Data.Either.Compat +import Data.Either import qualified Data.Map.Lazy as Map import Hpack.Util @@ -24,14 +26,19 @@ import Hpack.Config hiding (package) import qualified Hpack.Config as Config +instance IsList (Maybe (List a)) where + type Item (Maybe (List a)) = a + fromList = Just . List + toList = undefined + deps :: [String] -> Dependencies deps = Dependencies . Map.fromList . map (flip (,) AnyVersion) package :: Package package = Config.package "foo" "0.0.0" -executable :: String -> String -> Executable -executable name main_ = Executable name main_ ["Paths_foo"] +executable :: String -> Executable +executable main_ = Executable (Just main_) [] library :: Library library = Library Nothing [] ["Paths_foo"] [] @@ -59,12 +66,41 @@ spec :: Spec spec = do + describe "fromLibrarySectionInConditional" $ do + let + sect = LibrarySection { + librarySectionExposed = Nothing + , librarySectionExposedModules = Nothing + , librarySectionOtherModules = Nothing + , librarySectionReexportedModules = Nothing + } + lib = Library { + libraryExposed = Nothing + , libraryExposedModules = [] + , libraryOtherModules = [] + , libraryReexportedModules = [] + } + inferableModules = ["Foo", "Bar"] + from = fromLibrarySectionInConditional inferableModules + + context "when inferring modules" $ do + it "infers other-modules" $ do + from sect `shouldBe` lib {libraryOtherModules = ["Foo", "Bar"]} + + context "with exposed-modules" $ do + it "infers nothing" $ do + from sect {librarySectionExposedModules = []} `shouldBe` lib + + context "with other-modules" $ do + it "infers nothing" $ do + from sect {librarySectionOtherModules = []} `shouldBe` lib + describe "renamePackage" $ do it "renames a package" $ do renamePackage "bar" package `shouldBe` package {packageName = "bar"} it "renames dependencies on self" $ do - let packageWithExecutable dependencies = package {packageExecutables = [(section $ executable "main" "Main.hs") {sectionDependencies = deps dependencies}]} + let packageWithExecutable dependencies = package {packageExecutables = Map.fromList [("main", (section $ executable "Main.hs") {sectionDependencies = deps dependencies})]} renamePackage "bar" (packageWithExecutable ["foo"]) `shouldBe` (packageWithExecutable ["bar"]) {packageName = "bar"} describe "renameDependencies" $ do @@ -85,162 +121,6 @@ } renameDependencies "bar" "baz" (sectionWithConditional ["foo", "bar"]) `shouldBe` sectionWithConditional ["foo", "baz"] - describe "parseJSON" $ do - context "when parsing (CaptureUnknownFields Section a)" $ do - it "accepts dependencies" $ do - let input = [i| - dependencies: hpack - |] - captureUnknownFieldsValue <$> decodeEither input - `shouldBe` Right (section Empty){sectionDependencies = deps ["hpack"]} - - it "accepts includes-dirs" $ do - let input = [i| - include-dirs: - - foo - - bar - |] - captureUnknownFieldsValue <$> decodeEither input - `shouldBe` Right (section Empty){sectionIncludeDirs = ["foo", "bar"]} - - it "accepts install-includes" $ do - let input = [i| - install-includes: - - foo.h - - bar.h - |] - captureUnknownFieldsValue <$> decodeEither input - `shouldBe` Right (section Empty){sectionInstallIncludes = ["foo.h", "bar.h"]} - - it "accepts c-sources" $ do - let input = [i| - c-sources: - - foo.c - - bar/*.c - |] - captureUnknownFieldsValue <$> decodeEither input - `shouldBe` Right (section Empty){sectionCSources = ["foo.c", "bar/*.c"]} - - it "accepts js-sources" $ do - let input = [i| - js-sources: - - foo.js - - bar/*.js - |] - captureUnknownFieldsValue <$> decodeEither input - `shouldBe` Right (section Empty){sectionJsSources = ["foo.js", "bar/*.js"]} - - it "accepts extra-lib-dirs" $ do - let input = [i| - extra-lib-dirs: - - foo - - bar - |] - captureUnknownFieldsValue <$> decodeEither input - `shouldBe` Right (section Empty){sectionExtraLibDirs = ["foo", "bar"]} - - it "accepts extra-libraries" $ do - let input = [i| - extra-libraries: - - foo - - bar - |] - captureUnknownFieldsValue <$> decodeEither input - `shouldBe` Right (section Empty){sectionExtraLibraries = ["foo", "bar"]} - - it "accepts extra-frameworks-dirs" $ do - let input = [i| - extra-frameworks-dirs: - - foo - - bar - |] - captureUnknownFieldsValue <$> decodeEither input - `shouldBe` Right (section Empty){sectionExtraFrameworksDirs = ["foo", "bar"]} - - it "accepts frameworks" $ do - let input = [i| - frameworks: - - foo - - bar - |] - captureUnknownFieldsValue <$> decodeEither input - `shouldBe` Right (section Empty){sectionFrameworks = ["foo", "bar"]} - - context "when parsing conditionals" $ do - it "accepts conditionals" $ do - let input = [i| - when: - condition: os(windows) - dependencies: Win32 - |] - conditionals = [ - Conditional "os(windows)" - (section ()){sectionDependencies = deps ["Win32"]} - Nothing - ] - captureUnknownFieldsValue <$> decodeEither input - `shouldBe` Right (section Empty){sectionConditionals = conditionals} - - it "warns on unknown fields" $ do - let input = [i| - foo: 23 - when: - - condition: os(windows) - bar: 23 - when: - condition: os(windows) - bar2: 23 - - condition: os(windows) - baz: 23 - |] - captureUnknownFieldsFields <$> (decodeEither input :: Either String (CaptureUnknownFields (Section Empty))) - `shouldBe` Right ["foo", "bar", "bar2", "baz"] - - context "when parsing conditionals with else-branch" $ do - it "accepts conditionals with else-branch" $ do - let input = [i| - when: - condition: os(windows) - then: - dependencies: Win32 - else: - dependencies: unix - |] - conditionals = [ - Conditional "os(windows)" - (section ()){sectionDependencies = deps ["Win32"]} - (Just (section ()){sectionDependencies = deps ["unix"]}) - ] - r :: Either String (Section Empty) - r = captureUnknownFieldsValue <$> decodeEither input - sectionConditionals <$> r `shouldBe` Right conditionals - - it "rejects invalid conditionals" $ do - let input = [i| - when: - condition: os(windows) - then: - dependencies: Win32 - else: null - |] - - r :: Either String (Section Empty) - r = captureUnknownFieldsValue <$> decodeEither input - sectionConditionals <$> r `shouldSatisfy` isLeft - - it "warns on unknown fields" $ do - let input = [i| - when: - condition: os(windows) - foo: null - then: - bar: null - else: - baz: null - |] - captureUnknownFieldsFields <$> (decodeEither input :: Either String (CaptureUnknownFields (Section Empty))) - `shouldBe` Right ["foo", "bar", "baz"] - describe "getModules" $ around withTempDirectory $ do it "returns Haskell modules in specified source directory" $ \dir -> do touch (dir "src/Foo.hs") @@ -262,17 +142,17 @@ describe "determineModules" $ do it "adds the Paths_* module to the other-modules" $ do - determineModules "foo" [] (Just $ List ["Foo"]) Nothing `shouldBe` (["Foo"], ["Paths_foo"]) + determineModules "foo" [] ["Foo"] Nothing `shouldBe` (["Foo"], ["Paths_foo"]) it "adds the Paths_* module to the other-modules when no modules are specified" $ do determineModules "foo" [] Nothing Nothing `shouldBe` ([], ["Paths_foo"]) it "replaces dashes with underscores in Paths_*" $ do - determineModules "foo-bar" [] (Just $ List ["Foo"]) Nothing `shouldBe` (["Foo"], ["Paths_foo_bar"]) + determineModules "foo-bar" [] ["Foo"] Nothing `shouldBe` (["Foo"], ["Paths_foo_bar"]) context "when the Paths_* module is part of the exposed-modules" $ do it "does not add the Paths_* module to the other-modules" $ do - determineModules "foo" [] (Just $ List ["Foo", "Paths_foo"]) Nothing `shouldBe` (["Foo", "Paths_foo"], []) + determineModules "foo" [] ["Foo", "Paths_foo"] Nothing `shouldBe` (["Foo", "Paths_foo"], []) describe "readPackageConfig" $ do it "warns on unknown fields" $ do @@ -282,7 +162,7 @@ baz: 42 _qux: 66 |] - (`shouldBe` [ + (`shouldMatchList` [ "Ignoring unknown field \"bar\" in package description" , "Ignoring unknown field \"baz\" in package description" ] @@ -297,7 +177,7 @@ baz: 42 _qux: 66 |] - (`shouldBe` [ + (`shouldMatchList` [ "Ignoring unknown field \"_qux\" in package description" , "Ignoring unknown field \"bar\" in package description" , "Ignoring unknown field \"baz\" in package description" @@ -313,12 +193,40 @@ dependencies: ghc-prim baz: 42 |] - (`shouldBe` [ + (`shouldMatchList` [ "Ignoring unknown field \"baz\" in package description" , "Ignoring unknown field \"github\" in package description" ] ) + it "warns on unknown fields in when block in library section" $ do + withPackageWarnings_ [i| + name: foo + library: + when: + condition: impl(ghc) + baz: 42 + |] + (`shouldBe` [ + "Ignoring unknown field \"baz\" in library section" + ] + ) + + it "warns on unknown fields in when block in executable section" $ do + withPackageWarnings_ [i| + name: foo + executables: + foo: + main: Main.hs + when: + condition: impl(ghc) + baz: 42 + |] + (`shouldBe` [ + "Ignoring unknown field \"baz\" in executable section \"foo\"" + ] + ) + it "warns on missing name" $ do withPackageWarnings_ [i| {} @@ -567,8 +475,8 @@ |] (`shouldBe` package { packageLibrary = Just (section library) {sectionCppOptions = ["-DFOO", "-DLIB"]} - , packageExecutables = [(section $ executable "foo" "Main.hs") {sectionCppOptions = ["-DFOO", "-DFOO"]}] - , packageTests = [(section $ executable "spec" "Spec.hs") {sectionCppOptions = ["-DFOO", "-DTEST"]}] + , packageExecutables = Map.fromList [("foo", (section $ executable "Main.hs") {sectionCppOptions = ["-DFOO", "-DFOO"]})] + , packageTests = Map.fromList [("spec", (section $ executable "Spec.hs") {sectionCppOptions = ["-DFOO", "-DTEST"]})] } ) @@ -591,8 +499,8 @@ |] (`shouldBe` package { packageLibrary = Just (section library) {sectionCcOptions = ["-Wall", "-fLIB"]} - , packageExecutables = [(section $ executable "foo" "Main.hs") {sectionCcOptions = ["-Wall", "-O2"]}] - , packageTests = [(section $ executable "spec" "Spec.hs") {sectionCcOptions = ["-Wall", "-O0"]}] + , packageExecutables = Map.fromList [("foo", (section $ executable "Main.hs") {sectionCcOptions = ["-Wall", "-O2"]})] + , packageTests = Map.fromList [("spec", (section $ executable "Spec.hs") {sectionCcOptions = ["-Wall", "-O0"]})] } ) @@ -615,8 +523,8 @@ |] (`shouldBe` package { packageLibrary = Just (section library) {sectionGhcjsOptions = ["-dedupe", "-ghcjs1"]} - , packageExecutables = [(section $ executable "foo" "Main.hs") {sectionGhcjsOptions = ["-dedupe", "-ghcjs2"]}] - , packageTests = [(section $ executable "spec" "Spec.hs") {sectionGhcjsOptions = ["-dedupe", "-ghcjs3"]}] + , packageExecutables = Map.fromList [("foo", (section $ executable "Main.hs") {sectionGhcjsOptions = ["-dedupe", "-ghcjs2"]})] + , packageTests = Map.fromList [("spec", (section $ executable "Spec.hs") {sectionGhcjsOptions = ["-dedupe", "-ghcjs3"]})] } ) @@ -642,54 +550,10 @@ |] (`shouldBe` package { packageLibrary = Just (section library) {sectionBuildable = Just True} - , packageExecutables = [(section $ executable "foo" "Main.hs") {sectionBuildable = Just False}] + , packageExecutables = Map.fromList [("foo", (section $ executable "Main.hs") {sectionBuildable = Just False})] } ) - context "when reading custom-setup section" $ do - it "warns on unknown fields" $ do - withPackageWarnings_ [i| - name: foo - custom-setup: - foo: 1 - bar: 2 - |] - (`shouldBe` [ - "Ignoring unknown field \"bar\" in custom-setup section" - , "Ignoring unknown field \"foo\" in custom-setup section" - ]) - - it "sets build-type: Custom, if missing" $ do - withPackageConfig_ [i| - custom-setup: - dependencies: - - base - |] - (packageBuildType >>> (`shouldBe` Custom)) - - it "leaves build-type alone, if it exists" $ do - withPackageConfig_ [i| - name: foo - build-type: Make - custom-setup: - dependencies: - - base - |] - (packageBuildType >>> (`shouldBe` Make)) - - it "accepts dependencies" $ do - withPackageConfig_ [i| - custom-setup: - dependencies: - - foo > 1.0 - - bar == 2.0 - |] - (packageCustomSetup >>> fmap customSetupDependencies >>> fmap unDependencies >>> fmap Map.toList >>> (`shouldBe` Just [ - ("bar", VersionRange "==2.0") - , ("foo", VersionRange ">1.0") - ]) - ) - it "allows yaml merging and overriding fields" $ do withPackageConfig_ [i| _common: &common @@ -708,7 +572,7 @@ bar: 23 baz: 42 |] - (`shouldBe` [ + (`shouldMatchList` [ "Ignoring unknown field \"bar\" in library section" , "Ignoring unknown field \"baz\" in library section" ] @@ -768,54 +632,6 @@ |] (packageLibrary >>> (`shouldBe` Just (section library) {sectionBuildTools = deps ["alex", "happy"]})) - it "accepts c-sources" $ do - withPackageConfig [i| - library: - c-sources: - - cbits/*.c - |] - (do - touch "cbits/foo.c" - touch "cbits/bar.c" - ) - (packageLibrary >>> (`shouldBe` Just (section library) {sectionCSources = ["cbits/bar.c", "cbits/foo.c"]})) - - it "accepts global c-sources" $ do - withPackageConfig [i| - c-sources: - - cbits/*.c - library: {} - |] - (do - touch "cbits/foo.c" - touch "cbits/bar.c" - ) - (packageLibrary >>> (`shouldBe` Just (section library) {sectionCSources = ["cbits/bar.c", "cbits/foo.c"]})) - - it "accepts js-sources" $ do - withPackageConfig [i| - library: - js-sources: - - jsbits/*.js - |] - (do - touch "jsbits/foo.js" - touch "jsbits/bar.js" - ) - (packageLibrary >>> (`shouldBe` Just (section library) {sectionJsSources = ["jsbits/bar.js", "jsbits/foo.js"]})) - - it "accepts global js-sources" $ do - withPackageConfig [i| - js-sources: - - jsbits/*.js - library: {} - |] - (do - touch "jsbits/foo.js" - touch "jsbits/bar.js" - ) - (packageLibrary >>> (`shouldBe` Just (section library) {sectionJsSources = ["jsbits/bar.js", "jsbits/foo.js"]})) - it "allows to specify exposed" $ do withPackageConfig_ [i| library: @@ -823,61 +639,6 @@ |] (packageLibrary >>> (`shouldBe` Just (section library{libraryExposed = Just False}))) - it "allows to specify exposed-modules" $ do - withPackageConfig [i| - library: - source-dirs: src - exposed-modules: Foo - |] - (do - touch "src/Foo.hs" - touch "src/Bar.hs" - ) - (packageLibrary >>> (`shouldBe` Just (section library{libraryExposedModules = ["Foo"], libraryOtherModules = ["Bar", "Paths_foo"]}) {sectionSourceDirs = ["src"]})) - - it "allows to specify other-modules" $ do - withPackageConfig [i| - library: - source-dirs: src - other-modules: Bar - |] - (do - touch "src/Foo.hs" - touch "src/Bar.hs" - ) - (packageLibrary >>> (`shouldBe` Just (section library{libraryExposedModules = ["Foo"], libraryOtherModules = ["Bar"]}) {sectionSourceDirs = ["src"]})) - - it "allows to specify reexported-modules" $ do - withPackageConfig_ [i| - library: - reexported-modules: Baz - |] - (packageLibrary >>> (`shouldBe` Just (section library{libraryReexportedModules = ["Baz"]}))) - - it "allows to specify both exposed-modules and other-modules" $ do - withPackageConfig [i| - library: - source-dirs: src - exposed-modules: Foo - other-modules: Bar - |] - (do - touch "src/Baz.hs" - ) - (packageLibrary >>> (`shouldBe` Just (section library{libraryExposedModules = ["Foo"], libraryOtherModules = ["Bar"]}) {sectionSourceDirs = ["src"]})) - - context "when neither exposed-modules nor other-modules are specified" $ do - it "exposes all modules" $ do - withPackageConfig [i| - library: - source-dirs: src - |] - (do - touch "src/Foo.hs" - touch "src/Bar.hs" - ) - (packageLibrary >>> (`shouldBe` Just (section library{libraryExposedModules = ["Bar", "Foo"]}) {sectionSourceDirs = ["src"]})) - context "when reading executable section" $ do it "warns on unknown fields" $ do withPackageWarnings_ [i| @@ -888,7 +649,7 @@ bar: 42 baz: 23 |] - (`shouldBe` [ + (`shouldMatchList` [ "Ignoring unknown field \"bar\" in executable section \"foo\"" , "Ignoring unknown field \"baz\" in executable section \"foo\"" ] @@ -900,14 +661,14 @@ foo: main: driver/Main.hs |] - (packageExecutables >>> (`shouldBe` [section $ executable "foo" "driver/Main.hs"])) + (packageExecutables >>> (`shouldBe` Map.fromList [("foo", section $ executable "driver/Main.hs")])) it "reads executable section" $ do withPackageConfig_ [i| executable: main: driver/Main.hs |] - (packageExecutables >>> (`shouldBe` [section $ executable "foo" "driver/Main.hs"])) + (packageExecutables >>> (`shouldBe` Map.fromList [("foo", section $ executable "driver/Main.hs")])) it "warns on unknown executable fields" $ do withPackageWarnings_ [i| @@ -927,7 +688,7 @@ foo2: main: driver/Main2.hs |] - (packageExecutables >>> (`shouldBe` [section $ executable "foo" "driver/Main1.hs"])) + (packageExecutables >>> (`shouldBe` Map.fromList [("foo", section $ executable "driver/Main1.hs")])) it "warns" $ do withPackageWarnings_ [i| @@ -940,17 +701,6 @@ |] (`shouldBe` ["Ignoring field \"executables\" in favor of \"executable\""]) - it "accepts arbitrary entry points as main" $ do - withPackageConfig_ [i| - executables: - foo: - main: Foo - |] - (packageExecutables >>> (`shouldBe` [ - (section $ executable "foo" "Foo.hs") {sectionGhcOptions = ["-main-is Foo"]} - ] - )) - it "accepts source-dirs" $ do withPackageConfig_ [i| executables: @@ -960,7 +710,7 @@ - foo - bar |] - (packageExecutables >>> (`shouldBe` [(section $ executable "foo" "Main.hs") {sectionSourceDirs = ["foo", "bar"]}])) + (packageExecutables >>> (`shouldBe` Map.fromList [("foo", (section (executable "Main.hs") {executableOtherModules = ["Paths_foo"]}) {sectionSourceDirs = ["foo", "bar"]})])) it "accepts build-tools" $ do withPackageConfig_ [i| @@ -971,7 +721,7 @@ - alex - happy |] - (packageExecutables >>> (`shouldBe` [(section $ executable "foo" "Main.hs") {sectionBuildTools = deps ["alex", "happy"]}])) + (packageExecutables >>> (`shouldBe` Map.fromList [("foo", (section $ executable "Main.hs") {sectionBuildTools = deps ["alex", "happy"]})])) it "accepts global source-dirs" $ do withPackageConfig_ [i| @@ -982,7 +732,7 @@ foo: main: Main.hs |] - (packageExecutables >>> (`shouldBe` [(section $ executable "foo" "Main.hs") {sectionSourceDirs = ["foo", "bar"]}])) + (packageExecutables >>> (`shouldBe` Map.fromList [("foo", (section (executable "Main.hs") {executableOtherModules = ["Paths_foo"]}) {sectionSourceDirs = ["foo", "bar"]})])) it "accepts global build-tools" $ do withPackageConfig_ [i| @@ -993,34 +743,7 @@ foo: main: Main.hs |] - (packageExecutables >>> (`shouldBe` [(section $ executable "foo" "Main.hs") {sectionBuildTools = deps ["alex", "happy"]}])) - - it "infers other-modules" $ do - withPackageConfig [i| - executables: - foo: - main: Main.hs - source-dirs: src - |] - (do - touch "src/Main.hs" - touch "src/Foo.hs" - ) - (map (executableOtherModules . sectionData) . packageExecutables >>> (`shouldBe` [["Foo", "Paths_foo"]])) - - it "allows to specify other-modules" $ do - withPackageConfig [i| - executables: - foo: - main: Main.hs - source-dirs: src - other-modules: Baz - |] - (do - touch "src/Foo.hs" - touch "src/Bar.hs" - ) - (map (executableOtherModules . sectionData) . packageExecutables >>> (`shouldBe` [["Baz"]])) + (packageExecutables >>> (`shouldBe` Map.fromList [("foo", (section $ executable "Main.hs") {sectionBuildTools = deps ["alex", "happy"]})])) it "accepts default-extensions" $ do withPackageConfig_ [i| @@ -1031,7 +754,7 @@ - Foo - Bar |] - (packageExecutables >>> (`shouldBe` [(section $ executable "foo" "driver/Main.hs") {sectionDefaultExtensions = ["Foo", "Bar"]}])) + (packageExecutables >>> (`shouldBe` Map.fromList [("foo", (section $ executable "driver/Main.hs") {sectionDefaultExtensions = ["Foo", "Bar"]})])) it "accepts global default-extensions" $ do withPackageConfig_ [i| @@ -1042,7 +765,7 @@ foo: main: driver/Main.hs |] - (packageExecutables >>> (`shouldBe` [(section $ executable "foo" "driver/Main.hs") {sectionDefaultExtensions = ["Foo", "Bar"]}])) + (packageExecutables >>> (`shouldBe` Map.fromList [("foo", (section $ executable "driver/Main.hs") {sectionDefaultExtensions = ["Foo", "Bar"]})])) it "accepts GHC options" $ do withPackageConfig_ [i| @@ -1051,7 +774,7 @@ main: driver/Main.hs ghc-options: -Wall |] - (`shouldBe` package {packageExecutables = [(section $ executable "foo" "driver/Main.hs") {sectionGhcOptions = ["-Wall"]}]}) + (`shouldBe` package {packageExecutables = Map.fromList [("foo", (section $ executable "driver/Main.hs") {sectionGhcOptions = ["-Wall"]})]}) it "accepts global GHC options" $ do withPackageConfig_ [i| @@ -1060,7 +783,7 @@ foo: main: driver/Main.hs |] - (`shouldBe` package {packageExecutables = [(section $ executable "foo" "driver/Main.hs") {sectionGhcOptions = ["-Wall"]}]}) + (`shouldBe` package {packageExecutables = Map.fromList [("foo", (section $ executable "driver/Main.hs") {sectionGhcOptions = ["-Wall"]})]}) it "accepts GHC profiling options" $ do withPackageConfig_ [i| @@ -1069,7 +792,7 @@ main: driver/Main.hs ghc-prof-options: -fprof-auto |] - (`shouldBe` package {packageExecutables = [(section $ executable "foo" "driver/Main.hs") {sectionGhcProfOptions = ["-fprof-auto"]}]}) + (`shouldBe` package {packageExecutables = Map.fromList [("foo", (section $ executable "driver/Main.hs") {sectionGhcProfOptions = ["-fprof-auto"]})]}) it "accepts global GHC profiling options" $ do withPackageConfig_ [i| @@ -1078,63 +801,7 @@ foo: main: driver/Main.hs |] - (`shouldBe` package {packageExecutables = [(section $ executable "foo" "driver/Main.hs") {sectionGhcProfOptions = ["-fprof-auto"]}]}) - - it "accepts c-sources" $ do - withPackageConfig [i| - executables: - foo: - main: driver/Main.hs - c-sources: - - cbits/*.c - |] - (do - touch "cbits/foo.c" - touch "cbits/bar.c" - ) - (`shouldBe` package {packageExecutables = [(section $ executable "foo" "driver/Main.hs") {sectionCSources = ["cbits/bar.c", "cbits/foo.c"]}]}) - - it "accepts global c-sources" $ do - withPackageConfig [i| - c-sources: - - cbits/*.c - executables: - foo: - main: driver/Main.hs - |] - (do - touch "cbits/foo.c" - touch "cbits/bar.c" - ) - (`shouldBe` package {packageExecutables = [(section $ executable "foo" "driver/Main.hs") {sectionCSources = ["cbits/bar.c", "cbits/foo.c"]}]}) - - it "accepts js-sources" $ do - withPackageConfig [i| - executables: - foo: - main: driver/Main.hs - js-sources: - - jsbits/*.js - |] - (do - touch "jsbits/foo.js" - touch "jsbits/bar.js" - ) - (`shouldBe` package {packageExecutables = [(section $ executable "foo" "driver/Main.hs") {sectionJsSources = ["jsbits/bar.js", "jsbits/foo.js"]}]}) - - it "accepts global js-sources" $ do - withPackageConfig [i| - js-sources: - - jsbits/*.js - executables: - foo: - main: driver/Main.hs - |] - (do - touch "jsbits/foo.js" - touch "jsbits/bar.js" - ) - (`shouldBe` package {packageExecutables = [(section $ executable "foo" "driver/Main.hs") {sectionJsSources = ["jsbits/bar.js", "jsbits/foo.js"]}]}) + (`shouldBe` package {packageExecutables = Map.fromList [("foo", (section $ executable "driver/Main.hs") {sectionGhcProfOptions = ["-fprof-auto"]})]}) context "when reading benchmark section" $ do it "warns on unknown fields" $ do @@ -1146,7 +813,7 @@ bar: 42 baz: 23 |] - (`shouldBe` [ + (`shouldMatchList` [ "Ignoring unknown field \"bar\" in benchmark section \"foo\"" , "Ignoring unknown field \"baz\" in benchmark section \"foo\"" ] @@ -1162,7 +829,7 @@ bar: 42 baz: 23 |] - (`shouldBe` [ + (`shouldMatchList` [ "Ignoring unknown field \"bar\" in test section \"foo\"" , "Ignoring unknown field \"baz\" in test section \"foo\"" ] @@ -1174,52 +841,7 @@ spec: main: test/Spec.hs |] - (`shouldBe` package {packageTests = [section $ executable "spec" "test/Spec.hs"]}) - - it "accepts single dependency" $ do - withPackageConfig_ [i| - tests: - spec: - main: test/Spec.hs - dependencies: hspec - |] - (`shouldBe` package {packageTests = [(section $ executable "spec" "test/Spec.hs") {sectionDependencies = deps ["hspec"]}]}) - - it "accepts list of dependencies" $ do - withPackageConfig_ [i| - tests: - spec: - main: test/Spec.hs - dependencies: - - hspec - - QuickCheck - |] - (`shouldBe` package {packageTests = [(section $ executable "spec" "test/Spec.hs") {sectionDependencies = deps ["hspec", "QuickCheck"]}]}) - - context "when both global and section specific dependencies are specified" $ do - it "combines dependencies" $ do - withPackageConfig_ [i| - dependencies: - - base - - tests: - spec: - main: test/Spec.hs - dependencies: hspec - |] - (`shouldBe` package {packageTests = [(section $ executable "spec" "test/Spec.hs") {sectionDependencies = deps ["base", "hspec"]}]}) - - it "gives section specific dependencies precedence" $ do - withPackageConfig_ [i| - dependencies: - - base - - tests: - spec: - main: test/Spec.hs - dependencies: base >= 2 - |] - (packageTests >>> map (Map.toList . unDependencies . sectionDependencies) >>> (`shouldBe` [[("base", VersionRange ">=2")]])) + (`shouldBe` package {packageTests = Map.fromList [("spec", section $ executable "test/Spec.hs")]}) context "when a specified source directory does not exist" $ do it "warns" $ do @@ -1264,9 +886,8 @@ it "returns an error" $ \dir -> do let file = dir "package.yaml" writeFile file [i| - executables: - foo: - ain: driver/Main.hs + - one + - two |] readPackageConfig file >>= (`shouldSatisfy` isLeft) diff --git a/test/Hpack/OptionsSpec.hs b/test/Hpack/OptionsSpec.hs --- a/test/Hpack/OptionsSpec.hs +++ b/test/Hpack/OptionsSpec.hs @@ -2,9 +2,6 @@ import Helper -import Prelude () -import Prelude.Compat - import Hpack.Options spec :: Spec diff --git a/test/Hpack/RenderSpec.hs b/test/Hpack/RenderSpec.hs --- a/test/Hpack/RenderSpec.hs +++ b/test/Hpack/RenderSpec.hs @@ -1,12 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} module Hpack.RenderSpec where -import Prelude () -import Prelude.Compat - import Test.Hspec import Test.QuickCheck -import Data.List.Compat +import Data.List import Data.Maybe import Hpack.Render diff --git a/test/Hpack/RunSpec.hs b/test/Hpack/RunSpec.hs --- a/test/Hpack/RunSpec.hs +++ b/test/Hpack/RunSpec.hs @@ -2,7 +2,7 @@ module Hpack.RunSpec (spec) where import Helper -import Data.List.Compat +import Data.List import qualified Data.Map.Lazy as Map import Hpack.ConfigSpec hiding (spec) @@ -13,6 +13,9 @@ library :: Library library = Library Nothing [] [] [] +renderEmptySection :: Empty -> [Element] +renderEmptySection Empty = [] + spec :: Spec spec = do describe "renderPackage" $ do @@ -126,22 +129,6 @@ , " default-language: Haskell2010" ] - context "when rendering custom-setup section" $ do - it "includes setup-depends" $ do - let setup = CustomSetup - { customSetupDependencies = deps ["foo", "bar"] } - renderPackage_ package {packageCustomSetup = Just setup} `shouldBe` unlines [ - "name: foo" - , "version: 0.0.0" - , "build-type: Simple" - , "cabal-version: >= 1.10" - , "" - , "custom-setup" - , " setup-depends:" - , " bar" - , " , foo" - ] - context "when rendering library section" $ do it "renders library section" $ do renderPackage_ package {packageLibrary = Just $ section library} `shouldBe` unlines [ @@ -154,45 +141,6 @@ , " default-language: Haskell2010" ] - it "includes exposed-modules" $ do - renderPackage_ package {packageLibrary = Just (section library{libraryExposedModules = ["Foo"]})} `shouldBe` unlines [ - "name: foo" - , "version: 0.0.0" - , "build-type: Simple" - , "cabal-version: >= 1.10" - , "" - , "library" - , " exposed-modules:" - , " Foo" - , " default-language: Haskell2010" - ] - - it "includes other-modules" $ do - renderPackage_ package {packageLibrary = Just (section library{libraryOtherModules = ["Bar"]})} `shouldBe` unlines [ - "name: foo" - , "version: 0.0.0" - , "build-type: Simple" - , "cabal-version: >= 1.10" - , "" - , "library" - , " other-modules:" - , " Bar" - , " default-language: Haskell2010" - ] - - it "includes reexported-modules and bumps cabal version" $ do - renderPackage_ package {packageLibrary = Just (section library{libraryReexportedModules = ["Baz"]})} `shouldBe` unlines [ - "name: foo" - , "version: 0.0.0" - , "build-type: Simple" - , "cabal-version: >= 1.21" - , "" - , "library" - , " reexported-modules:" - , " Baz" - , " 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 [ @@ -211,7 +159,7 @@ ] it "retains section field order" $ do - renderPackage defaultRenderSettings 0 [] [("executable foo", ["default-language", "main-is", "ghc-options"])] package {packageExecutables = [(section $ Executable "foo" "Main.hs" []) {sectionGhcOptions = ["-Wall", "-Werror"]}]} `shouldBe` unlines [ + renderPackage defaultRenderSettings 0 [] [("executable foo", ["default-language", "main-is", "ghc-options"])] package {packageExecutables = Map.fromList [("foo", (section $ Executable (Just "Main.hs") []) {sectionGhcOptions = ["-Wall", "-Werror"]})]} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" @@ -226,8 +174,8 @@ context "when rendering executable section" $ do it "includes dependencies" $ do - renderPackage_ package {packageExecutables = [(section $ Executable "foo" "Main.hs" []) {sectionDependencies = Dependencies $ Map.fromList - [("foo", VersionRange "== 0.1.0"), ("bar", AnyVersion)]}]} `shouldBe` unlines [ + renderPackage_ package {packageExecutables = Map.fromList [("foo", (section $ Executable (Just "Main.hs") []) {sectionDependencies = Dependencies $ Map.fromList + [("foo", VersionRange "== 0.1.0"), ("bar", AnyVersion)]})]} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" @@ -242,7 +190,7 @@ ] it "includes GHC options" $ do - renderPackage_ package {packageExecutables = [(section $ Executable "foo" "Main.hs" []) {sectionGhcOptions = ["-Wall", "-Werror"]}]} `shouldBe` unlines [ + renderPackage_ package {packageExecutables = Map.fromList [("foo", (section $ Executable (Just "Main.hs") []) {sectionGhcOptions = ["-Wall", "-Werror"]})]} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" @@ -255,7 +203,7 @@ ] it "includes frameworks" $ do - renderPackage_ package {packageExecutables = [(section $ Executable "foo" "Main.hs" []) {sectionFrameworks = ["foo", "bar"]}]} `shouldBe` unlines [ + renderPackage_ package {packageExecutables = Map.fromList [("foo", (section $ Executable (Just "Main.hs") []) {sectionFrameworks = ["foo", "bar"]})]} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" @@ -270,7 +218,7 @@ ] it "includes extra-framework-dirs" $ do - renderPackage_ package {packageExecutables = [(section $ Executable "foo" "Main.hs" []) {sectionExtraFrameworksDirs = ["foo", "bar"]}]} `shouldBe` unlines [ + renderPackage_ package {packageExecutables = Map.fromList [("foo", (section $ Executable (Just "Main.hs") []) {sectionExtraFrameworksDirs = ["foo", "bar"]})]} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" @@ -285,7 +233,7 @@ ] it "includes GHC profiling options" $ do - renderPackage_ package {packageExecutables = [(section $ Executable "foo" "Main.hs" []) {sectionGhcProfOptions = ["-fprof-auto", "-rtsopts"]}]} `shouldBe` unlines [ + renderPackage_ package {packageExecutables = Map.fromList [("foo", (section $ Executable (Just "Main.hs") []) {sectionGhcProfOptions = ["-fprof-auto", "-rtsopts"]})]} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" @@ -299,16 +247,16 @@ describe "renderConditional" $ do it "renders conditionals" $ do - let conditional = Conditional "os(windows)" (section ()) {sectionDependencies = deps ["Win32"]} Nothing - render defaultRenderSettings 0 (renderConditional conditional) `shouldBe` [ + 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 ()) {sectionDependencies = deps ["Win32"]} (Just $ (section ()) {sectionDependencies = deps ["unix"]}) - render defaultRenderSettings 0 (renderConditional conditional) `shouldBe` [ + 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" @@ -318,9 +266,9 @@ ] it "renders nested conditionals" $ do - let conditional = Conditional "arch(i386)" (section ()) {sectionGhcOptions = ["-threaded"], sectionConditionals = [innerConditional]} Nothing - innerConditional = Conditional "os(windows)" (section ()) {sectionDependencies = deps ["Win32"]} Nothing - render defaultRenderSettings 0 (renderConditional conditional) `shouldBe` [ + 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)" diff --git a/test/Hpack/Utf8Spec.hs b/test/Hpack/Utf8Spec.hs new file mode 100644 --- /dev/null +++ b/test/Hpack/Utf8Spec.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE OverloadedStrings #-} +module Hpack.Utf8Spec (spec) where + +import Helper + +import qualified Data.ByteString as B + +import qualified Hpack.Utf8 as Utf8 + +spec :: Spec +spec = do + describe "readFile" $ do + context "with a file that uses CRLF newlines" $ do + it "applies newline conversion" $ do + inTempDirectory $ do + let + name = "foo.txt" + B.writeFile name "foo\r\nbar" + Utf8.readFile name `shouldReturn` "foo\nbar" + + describe "writeFile" $ do + it "uses system specific newline encoding" $ do + inTempDirectory $ do + let + name = "foo.txt" + c = "foo\nbar" + + writeFile name c + systemSpecific <- B.readFile name + + Utf8.writeFile name c + B.readFile name `shouldReturn` systemSpecific diff --git a/test/HpackSpec.hs b/test/HpackSpec.hs --- a/test/HpackSpec.hs +++ b/test/HpackSpec.hs @@ -2,9 +2,8 @@ import Helper -import Prelude () -import Prelude.Compat hiding (readFile) -import qualified Prelude.Compat as Prelude +import Prelude hiding (readFile) +import qualified Prelude as Prelude import Control.DeepSeq