diff --git a/driver/Main.hs b/driver/Main.hs --- a/driver/Main.hs +++ b/driver/Main.hs @@ -9,13 +9,18 @@ import Data.List.Compat import Data.Version (showVersion) import Control.DeepSeq +import System.Environment import Paths_hpack (version) -import Run +import Hpack.Config +import Hpack.Run +programVersion :: String +programVersion = "hpack version " ++ showVersion version + header :: String header = unlines [ - "-- This file has been generated from " ++ configFile ++ " by hpack version " ++ showVersion version ++ "." + "-- This file has been generated from " ++ packageConfig ++ " by " ++ programVersion ++ "." , "--" , "-- see: https://github.com/sol/hpack" , "" @@ -23,10 +28,14 @@ main :: IO () main = do - (warnings, name, new) <- run - forM_ warnings $ \warning -> hPutStrLn stderr ("WARNING: " ++ warning) - old <- force . either (const Nothing) (Just . stripHeader) <$> tryJust (guard . isDoesNotExistError) (readFile name) - unless (old == Just (lines new)) (writeFile name $ header ++ new) - where - stripHeader :: String -> [String] - stripHeader = dropWhile null . dropWhile ("--" `isPrefixOf`) . lines + args <- getArgs + if "--version" `elem` args + then putStrLn programVersion + else do + (warnings, name, new) <- run + forM_ warnings $ \warning -> hPutStrLn stderr ("WARNING: " ++ warning) + old <- force . either (const Nothing) (Just . stripHeader) <$> tryJust (guard . isDoesNotExistError) (readFile name) + unless (old == Just (lines new)) (writeFile name $ header ++ new) + where + stripHeader :: String -> [String] + stripHeader = dropWhile null . dropWhile ("--" `isPrefixOf`) . lines diff --git a/hpack.cabal b/hpack.cabal --- a/hpack.cabal +++ b/hpack.cabal @@ -1,12 +1,12 @@ --- This file has been generated from package.yaml by hpack version 0.3.0. +-- This file has been generated from package.yaml by hpack version 0.4.0. -- -- see: https://github.com/sol/hpack name: hpack -version: 0.3.2 +version: 0.4.0 synopsis: An alternative format for Haskell packages -homepage: https://github.com/haskell-tinc/hpack#readme -bug-reports: https://github.com/haskell-tinc/hpack/issues +homepage: https://github.com/sol/hpack#readme +bug-reports: https://github.com/sol/hpack/issues maintainer: Simon Hengel license: MIT license-file: LICENSE @@ -15,18 +15,34 @@ source-repository head type: git - location: https://github.com/haskell-tinc/hpack + location: https://github.com/sol/hpack +library + hs-source-dirs: src + exposed-modules: + Hpack.Config + Hpack.Run + other-modules: + Hpack.Util + build-depends: + aeson >= 0.8 + , base >= 4.7 && < 5 + , base-compat >= 0.8 + , deepseq + , directory + , filepath + , text + , unordered-containers + , yaml + ghc-options: -Wall + default-language: Haskell2010 + executable hpack - hs-source-dirs: src, driver + hs-source-dirs: driver main-is: Main.hs - other-modules: - Config - Run - Util build-depends: aeson >= 0.8 - , base == 4.* + , base >= 4.7 && < 5 , base-compat >= 0.8 , deepseq , directory @@ -34,24 +50,26 @@ , text , unordered-containers , yaml + + , hpack ghc-options: -Wall default-language: Haskell2010 test-suite spec type: exitcode-stdio-1.0 - hs-source-dirs: src, test + hs-source-dirs: test, src main-is: Spec.hs other-modules: - Config - Run - Util - ConfigSpec Helper - RunSpec - UtilSpec + Hpack.ConfigSpec + Hpack.RunSpec + Hpack.UtilSpec + Hpack.Config + Hpack.Run + Hpack.Util build-depends: aeson >= 0.8 - , base == 4.* + , base >= 4.7 && < 5 , base-compat >= 0.8 , deepseq , directory @@ -63,5 +81,6 @@ , hspec == 2.* , mockery >= 0.3 , interpolate + , aeson-qq ghc-options: -Wall default-language: Haskell2010 diff --git a/src/Config.hs b/src/Config.hs deleted file mode 100644 --- a/src/Config.hs +++ /dev/null @@ -1,330 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Config ( - readPackageConfig -, Package(..) -, Dependency -, GhcOption -, Library(..) -, Executable(..) -) where - -import Prelude () -import Prelude.Compat -import Control.Applicative -import Control.Monad.Compat -import Data.List (nub, sort, (\\)) -import Data.String -import Data.Maybe -import Data.Yaml -import GHC.Generics -import Data.HashMap.Lazy (HashMap) -import qualified Data.HashMap.Lazy as Map -import qualified Data.Text as T -import System.FilePath -import System.Directory -import Data.Data -import Data.Aeson.Types - -import Util - -genericParseJSON_ :: forall a. (Typeable a, Generic a, GFromJSON (Rep a)) => Value -> Parser a -genericParseJSON_ = genericParseJSON defaultOptions {fieldLabelModifier = hyphenize name} - where - name = (tyConName . typeRepTyCon . typeRep) (Proxy :: Proxy a) - -hyphenize :: String -> String -> String -hyphenize name = camelTo '-' . drop (length name) - -data CaptureUnknownFields a = CaptureUnknownFields { - captureUnknownFieldsFields :: [String] -, captureUnknownFieldsValue :: a -} deriving (Eq, Show, Generic, Data, Typeable) - -instance (Data a, FromJSON a) => FromJSON (CaptureUnknownFields a) where - parseJSON v = captureUnknownFields <$> parseJSON v - where - captureUnknownFields a = case v of - Object o -> CaptureUnknownFields unknown a - where - unknown = keys \\ fields - keys = map T.unpack (Map.keys o) - constr = toConstr a - name = showConstr constr - fields = map (hyphenize name) (constrFields constr) - _ -> CaptureUnknownFields [] a - -data LibrarySection = LibrarySection { - librarySectionSourceDirs :: Maybe (List FilePath) -, librarySectionExposedModules :: Maybe (List String) -, librarySectionOtherModules :: Maybe (List String) -, librarySectionDependencies :: Maybe (List Dependency) -, librarySectionDefaultExtensions :: Maybe (List String) -, librarySectionGhcOptions :: Maybe (List GhcOption) -, librarySectionCppOptions :: Maybe (List CppOption) -} deriving (Eq, Show, Generic, Data, Typeable) - -instance FromJSON LibrarySection where - parseJSON = genericParseJSON_ - -data ExecutableSection = ExecutableSection { - executableSectionMain :: FilePath -, executableSectionSourceDirs :: Maybe (List FilePath) -, executableSectionOtherModules :: Maybe (List String) -, executableSectionDependencies :: Maybe (List Dependency) -, executableSectionDefaultExtensions :: Maybe (List String) -, executableSectionGhcOptions :: Maybe (List GhcOption) -, executableSectionCppOptions :: Maybe (List CppOption) -} deriving (Eq, Show, Generic, Data, Typeable) - -instance FromJSON ExecutableSection where - parseJSON = genericParseJSON_ - -data PackageConfig = PackageConfig { - packageConfigName :: Maybe String -, packageConfigVersion :: Maybe String -, packageConfigSynopsis :: Maybe String -, packageConfigDescription :: Maybe String -, packageConfigHomepage :: Maybe (Maybe String) -, packageConfigBugReports :: Maybe (Maybe String) -, packageConfigCategory :: Maybe String -, packageConfigStability :: Maybe String -, packageConfigAuthor :: Maybe (List String) -, packageConfigMaintainer :: Maybe (List String) -, packageConfigCopyright :: Maybe (List String) -, packageConfigLicense :: Maybe String -, packageConfigExtraSourceFiles :: Maybe (List FilePath) -, packageConfigGithub :: Maybe String -, packageConfigSourceDirs :: Maybe (List FilePath) -, packageConfigDependencies :: Maybe (List Dependency) -, packageConfigDefaultExtensions :: Maybe (List String) -, packageConfigGhcOptions :: Maybe (List GhcOption) -, packageConfigCppOptions :: Maybe (List CppOption) -, packageConfigLibrary :: Maybe (CaptureUnknownFields LibrarySection) -, packageConfigExecutables :: Maybe (HashMap String (CaptureUnknownFields ExecutableSection)) -, packageConfigTests :: Maybe (HashMap String (CaptureUnknownFields ExecutableSection)) -} deriving (Eq, Show, Generic, Data, Typeable) - -instance FromJSON PackageConfig where - parseJSON value = handleNullValues <$> genericParseJSON_ value - where - handleNullValues :: PackageConfig -> PackageConfig - handleNullValues = - ifNull "homepage" (\p -> p {packageConfigHomepage = Just Nothing}) - . ifNull "bug-reports" (\p -> p {packageConfigBugReports = Just Nothing}) - - ifNull :: String -> (a -> a) -> a -> a - ifNull name f - | isNull name value = f - | otherwise = id - -isNull :: String -> Value -> Bool -isNull name value = case parseMaybe p value of - Just Null -> True - _ -> False - where - p = parseJSON >=> (.: fromString name) - -readPackageConfig :: FilePath -> IO (Either String ([String], Package)) -readPackageConfig file = do - config <- decodeFileEither file - either (return . Left . errToString) (fmap Right . mkPackage) config - where - errToString err = file ++ case err of - AesonException e -> ": " ++ e - InvalidYaml (Just (YamlException s)) -> ": " ++ s - InvalidYaml (Just (YamlParseException{..})) -> ":" ++ show yamlLine ++ ":" ++ show yamlColumn ++ ": " ++ yamlProblem ++ " " ++ yamlContext - where YamlMark{..} = yamlProblemMark - _ -> ": " ++ show err - -type Dependency = String -type GhcOption = String -type CppOption = String - -data Package = Package { - packageName :: String -, packageVersion :: String -, packageSynopsis :: Maybe String -, packageDescription :: Maybe String -, packageHomepage :: Maybe String -, packageBugReports :: Maybe String -, packageCategory :: Maybe String -, packageStability :: Maybe String -, packageAuthor :: [String] -, packageMaintainer :: [String] -, packageCopyright :: [String] -, packageLicense :: Maybe String -, packageLicenseFile :: Maybe FilePath -, packageExtraSourceFiles :: [FilePath] -, packageSourceRepository :: Maybe String -, packageLibrary :: Maybe Library -, packageExecutables :: [Executable] -, packageTests :: [Executable] -} deriving (Eq, Show) - -data Library = Library { - librarySourceDirs :: [FilePath] -, libraryExposedModules :: [String] -, libraryOtherModules :: [String] -, libraryDependencies :: [[Dependency]] -, libraryDefaultExtensions :: [String] -, libraryGhcOptions :: [GhcOption] -, libraryCppOptions :: [CppOption] -} deriving (Eq, Show) - -data Executable = Executable { - executableName :: String -, executableMain :: FilePath -, executableSourceDirs :: [FilePath] -, executableOtherModules :: [String] -, executableDependencies :: [[Dependency]] -, executableDefaultExtensions :: [String] -, executableGhcOptions :: [GhcOption] -, executableCppOptions :: [CppOption] -} deriving (Eq, Show) - -mkPackage :: (CaptureUnknownFields PackageConfig) -> IO ([String], Package) -mkPackage (CaptureUnknownFields unknownFields PackageConfig{..}) = do - let dependencies = fromMaybeList packageConfigDependencies - sourceDirs = fromMaybeList packageConfigSourceDirs - defaultExtensions = fromMaybeList packageConfigDefaultExtensions - ghcOptions = fromMaybeList packageConfigGhcOptions - cppOptions = fromMaybeList packageConfigCppOptions - convert f = f sourceDirs dependencies defaultExtensions ghcOptions cppOptions - - mLibrary <- mapM (convert toLibrary) mLibrarySection - executables <- convert toExecutables mExecutableSections - tests <- convert toExecutables mTestSections - - name <- maybe (takeBaseName <$> getCurrentDirectory) return packageConfigName - - licenseFileExists <- doesFileExist "LICENSE" - - missingSourceDirs <- nub . sort <$> filterM (fmap not <$> doesDirectoryExist) ( - maybe [] librarySourceDirs mLibrary - ++ concatMap executableSourceDirs executables - ++ concatMap executableSourceDirs tests - ) - - let package = Package { - packageName = name - , packageVersion = fromMaybe "0.0.0" packageConfigVersion - , packageSynopsis = packageConfigSynopsis - , packageDescription = packageConfigDescription - , packageHomepage = homepage - , packageBugReports = bugReports - , packageCategory = packageConfigCategory - , packageStability = packageConfigStability - , packageAuthor = fromMaybeList packageConfigAuthor - , packageMaintainer = fromMaybeList packageConfigMaintainer - , packageCopyright = fromMaybeList packageConfigCopyright - , packageLicense = packageConfigLicense - , packageLicenseFile = guard licenseFileExists >> Just "LICENSE" - , packageExtraSourceFiles = fromMaybeList packageConfigExtraSourceFiles - , packageSourceRepository = github - , packageLibrary = mLibrary - , packageExecutables = executables - , packageTests = tests - } - - warnings = - formatUnknownFields "package description" unknownFields - ++ maybe [] (formatUnknownFields "library section") (captureUnknownFieldsFields <$> packageConfigLibrary) - ++ formatUnknownSectionFields "executable" packageConfigExecutables - ++ formatUnknownSectionFields "test" packageConfigTests - ++ formatMissingSourceDirs missingSourceDirs - - return (warnings, package) - where - mLibrarySection :: Maybe LibrarySection - mLibrarySection = captureUnknownFieldsValue <$> packageConfigLibrary - - mExecutableSections :: Maybe (HashMap String ExecutableSection) - mExecutableSections = fmap captureUnknownFieldsValue <$> packageConfigExecutables - - mTestSections :: Maybe (HashMap String ExecutableSection) - mTestSections = fmap captureUnknownFieldsValue <$> packageConfigTests - - formatUnknownFields name = map f . sort - where - f field = "Ignoring unknown field " ++ show field ++ " in " ++ name - - formatUnknownSectionFields sectionType = maybe [] (concatMap f . Map.toList . fmap captureUnknownFieldsFields) - where - f :: (String, [String]) -> [String] - f (section, fields) = formatUnknownFields (sectionType ++ " section " ++ show section) fields - - formatMissingSourceDirs = map f - where - f name = "Specified source-dir " ++ show name ++ " does not exist" - - github = ("https://github.com/" ++) <$> packageConfigGithub - - homepage :: Maybe String - homepage = case packageConfigHomepage of - Just Nothing -> Nothing - _ -> join packageConfigHomepage <|> fromGithub - where - fromGithub = ((++ "#readme") <$> github) - - bugReports :: Maybe String - bugReports = case packageConfigBugReports of - Just Nothing -> Nothing - _ -> join packageConfigBugReports <|> fromGithub - where - fromGithub = ((++ "/issues") <$> github) - -toLibrary :: [FilePath] -> [Dependency] -> [String] -> [GhcOption] -> [CppOption] -> LibrarySection -> IO Library -toLibrary globalSourceDirs globalDependencies globalDefaultExtensions globalGhcOptions globalCppOptions LibrarySection{..} = do - modules <- concat <$> mapM getModules sourceDirs - - let (exposedModules, otherModules) = determineModules modules librarySectionExposedModules librarySectionOtherModules - - return (Library sourceDirs exposedModules otherModules dependencies defaultExtensions ghcOptions cppOptions) - where - sourceDirs = globalSourceDirs ++ fromMaybeList librarySectionSourceDirs - dependencies = filter (not . null) [globalDependencies, fromMaybeList librarySectionDependencies] - defaultExtensions = globalDefaultExtensions ++ fromMaybeList librarySectionDefaultExtensions - ghcOptions = globalGhcOptions ++ fromMaybeList librarySectionGhcOptions - cppOptions = globalCppOptions ++ fromMaybeList librarySectionCppOptions - -determineModules :: [String] -> Maybe (List String) -> Maybe (List String) -> ([String], [String]) -determineModules modules mExposedModules mOtherModules = case (mExposedModules, mOtherModules) of - (Nothing, Nothing) -> (modules, []) - _ -> (exposedModules, otherModules) - where - otherModules = maybe (modules \\ exposedModules) fromList mOtherModules - exposedModules = maybe (modules \\ otherModules) fromList mExposedModules - -getModules :: FilePath -> IO [String] -getModules src = do - exits <- doesDirectoryExist src - if exits - then toModules <$> getFilesRecursive src - else return [] - where - toModules :: [[FilePath]] -> [String] - toModules = catMaybes . map toModule - -toExecutables :: [FilePath] -> [Dependency] -> [String] -> [GhcOption] -> [CppOption] -> Maybe (HashMap String ExecutableSection) -> IO [Executable] -toExecutables globalSourceDirs globalDependencies globalDefaultExtensions globalGhcOptions globalCppOptions executables = - (mapM toExecutable . Map.toList) (fromMaybe mempty executables) - where - toExecutable (name, ExecutableSection{..}) = do - modules <- maybe (filterMain . concat <$> mapM getModules sourceDirs) (return . fromList) executableSectionOtherModules - return $ Executable name executableSectionMain sourceDirs modules dependencies defaultExtensions ghcOptions cppOptions - where - dependencies = filter (not . null) [globalDependencies, fromMaybeList executableSectionDependencies] - sourceDirs = globalSourceDirs ++ fromMaybeList executableSectionSourceDirs - defaultExtensions = globalDefaultExtensions ++ fromMaybeList executableSectionDefaultExtensions - ghcOptions = globalGhcOptions ++ fromMaybeList executableSectionGhcOptions - cppOptions = globalCppOptions ++ fromMaybeList executableSectionCppOptions - - filterMain :: [String] -> [String] - filterMain = maybe id (filter . (/=)) (toModule $ splitDirectories executableSectionMain) - -fromMaybeList :: Maybe (List a) -> [a] -fromMaybeList = maybe [] fromList diff --git a/src/Hpack/Config.hs b/src/Hpack/Config.hs new file mode 100644 --- /dev/null +++ b/src/Hpack/Config.hs @@ -0,0 +1,395 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +module Hpack.Config ( + packageConfig +, readPackageConfig +, Package(..) +, Dependency(..) +, GitRef(..) +, packageDependencies +, GhcOption +, Library(..) +, Executable(..) +, SourceRepository(..) +) where + +import Prelude () +import Prelude.Compat +import Control.Applicative +import Control.Monad.Compat +import Data.List (nub, sort, (\\)) +import Data.String +import Data.Maybe +import Data.Yaml +import GHC.Generics +import Data.HashMap.Lazy (HashMap) +import qualified Data.HashMap.Lazy as Map +import Data.Text (Text) +import qualified Data.Text as T +import System.FilePath +import System.Directory +import Data.Data +import Data.Aeson.Types + +import Hpack.Util + +packageConfig :: FilePath +packageConfig = "package.yaml" + +githubBaseUrl :: String +githubBaseUrl = "https://github.com/" + +genericParseJSON_ :: forall a. (Typeable a, Generic a, GFromJSON (Rep a)) => Value -> Parser a +genericParseJSON_ = genericParseJSON defaultOptions {fieldLabelModifier = hyphenize name} + where + name = (tyConName . typeRepTyCon . typeRep) (Proxy :: Proxy a) + +hyphenize :: String -> String -> String +hyphenize name = camelTo '-' . drop (length name) + +data CaptureUnknownFields a = CaptureUnknownFields { + captureUnknownFieldsFields :: [String] +, captureUnknownFieldsValue :: a +} deriving (Eq, Show, Generic, Data, Typeable) + +instance (Data a, FromJSON a) => FromJSON (CaptureUnknownFields a) where + parseJSON v = captureUnknownFields <$> parseJSON v + where + captureUnknownFields a = case v of + Object o -> CaptureUnknownFields unknown a + where + unknown = keys \\ fields + keys = map T.unpack (Map.keys o) + constr = toConstr a + name = showConstr constr + fields = map (hyphenize name) (constrFields constr) + _ -> CaptureUnknownFields [] a + +data LibrarySection = LibrarySection { + librarySectionSourceDirs :: Maybe (List FilePath) +, librarySectionExposedModules :: Maybe (List String) +, librarySectionOtherModules :: Maybe (List String) +, librarySectionDependencies :: Maybe (List Dependency) +, librarySectionDefaultExtensions :: Maybe (List String) +, librarySectionGhcOptions :: Maybe (List GhcOption) +, librarySectionCppOptions :: Maybe (List CppOption) +} deriving (Eq, Show, Generic, Data, Typeable) + +instance FromJSON LibrarySection where + parseJSON = genericParseJSON_ + +data ExecutableSection = ExecutableSection { + executableSectionMain :: FilePath +, executableSectionSourceDirs :: Maybe (List FilePath) +, executableSectionOtherModules :: Maybe (List String) +, executableSectionDependencies :: Maybe (List Dependency) +, executableSectionDefaultExtensions :: Maybe (List String) +, executableSectionGhcOptions :: Maybe (List GhcOption) +, executableSectionCppOptions :: Maybe (List CppOption) +} deriving (Eq, Show, Generic, Data, Typeable) + +instance FromJSON ExecutableSection where + parseJSON = genericParseJSON_ + +data PackageConfig = PackageConfig { + packageConfigName :: Maybe String +, packageConfigVersion :: Maybe String +, packageConfigSynopsis :: Maybe String +, packageConfigDescription :: Maybe String +, packageConfigHomepage :: Maybe (Maybe String) +, packageConfigBugReports :: Maybe (Maybe String) +, packageConfigCategory :: Maybe String +, packageConfigStability :: Maybe String +, packageConfigAuthor :: Maybe (List String) +, packageConfigMaintainer :: Maybe (List String) +, packageConfigCopyright :: Maybe (List String) +, packageConfigLicense :: Maybe String +, packageConfigExtraSourceFiles :: Maybe (List FilePath) +, packageConfigGithub :: Maybe Text +, packageConfigSourceDirs :: Maybe (List FilePath) +, packageConfigDependencies :: Maybe (List Dependency) +, packageConfigDefaultExtensions :: Maybe (List String) +, packageConfigGhcOptions :: Maybe (List GhcOption) +, packageConfigCppOptions :: Maybe (List CppOption) +, packageConfigLibrary :: Maybe (CaptureUnknownFields LibrarySection) +, packageConfigExecutables :: Maybe (HashMap String (CaptureUnknownFields ExecutableSection)) +, packageConfigTests :: Maybe (HashMap String (CaptureUnknownFields ExecutableSection)) +} deriving (Eq, Show, Generic, Data, Typeable) + +packageDependencies :: Package -> [Dependency] +packageDependencies Package{..} = nub . sort $ + (concat $ concatMap executableDependencies packageExecutables) + ++ (concat $ concatMap executableDependencies packageTests) + ++ maybe [] (concat . libraryDependencies) packageLibrary + +instance FromJSON PackageConfig where + parseJSON value = handleNullValues <$> genericParseJSON_ value + where + handleNullValues :: PackageConfig -> PackageConfig + handleNullValues = + ifNull "homepage" (\p -> p {packageConfigHomepage = Just Nothing}) + . ifNull "bug-reports" (\p -> p {packageConfigBugReports = Just Nothing}) + + ifNull :: String -> (a -> a) -> a -> a + ifNull name f + | isNull name value = f + | otherwise = id + +isNull :: String -> Value -> Bool +isNull name value = case parseMaybe p value of + Just Null -> True + _ -> False + where + p = parseJSON >=> (.: fromString name) + +readPackageConfig :: FilePath -> IO (Either String ([String], Package)) +readPackageConfig file = do + config <- decodeFileEither file + either (return . Left . errToString) (fmap Right . mkPackage) config + where + errToString err = file ++ case err of + AesonException e -> ": " ++ e + InvalidYaml (Just (YamlException s)) -> ": " ++ s + InvalidYaml (Just (YamlParseException{..})) -> ":" ++ show yamlLine ++ ":" ++ show yamlColumn ++ ": " ++ yamlProblem ++ " " ++ yamlContext + where YamlMark{..} = yamlProblemMark + _ -> ": " ++ show err + +data Dependency = Dependency { + dependencyName :: String +, dependencyGitRef :: Maybe GitRef +} deriving (Eq, Show, Ord, Generic, Data, Typeable) + +instance IsString Dependency where + fromString name = Dependency name Nothing + +instance FromJSON Dependency where + parseJSON v = case v of + String _ -> fromString <$> parseJSON v + Object o -> gitDependency o + _ -> typeMismatch "String or an Object" v + where + gitDependency o = Dependency <$> name <*> (Just <$> git) + where + name :: Parser String + name = o .: "name" + + git :: Parser GitRef + git = GitRef <$> url <*> ref + + url :: Parser String + url = + ((githubBaseUrl ++) <$> o .: "github") + <|> (o .: "git") + <|> fail "neither key \"git\" nor key \"github\" present" + + ref :: Parser String + ref = o .: "ref" + +data GitRef = GitRef { + gitRefUrl :: String +, gitRefRef :: String +} deriving (Eq, Show, Ord, Generic, Data, Typeable) + +type GhcOption = String +type CppOption = String + +data Package = Package { + packageName :: String +, packageVersion :: String +, packageSynopsis :: Maybe String +, packageDescription :: Maybe String +, packageHomepage :: Maybe String +, packageBugReports :: Maybe String +, packageCategory :: Maybe String +, packageStability :: Maybe String +, packageAuthor :: [String] +, packageMaintainer :: [String] +, packageCopyright :: [String] +, packageLicense :: Maybe String +, packageLicenseFile :: Maybe FilePath +, packageExtraSourceFiles :: [FilePath] +, packageSourceRepository :: Maybe SourceRepository +, packageLibrary :: Maybe Library +, packageExecutables :: [Executable] +, packageTests :: [Executable] +} deriving (Eq, Show) + +data Library = Library { + librarySourceDirs :: [FilePath] +, libraryExposedModules :: [String] +, libraryOtherModules :: [String] +, libraryDependencies :: [[Dependency]] +, libraryDefaultExtensions :: [String] +, libraryGhcOptions :: [GhcOption] +, libraryCppOptions :: [CppOption] +} deriving (Eq, Show) + +data Executable = Executable { + executableName :: String +, executableMain :: FilePath +, executableSourceDirs :: [FilePath] +, executableOtherModules :: [String] +, executableDependencies :: [[Dependency]] +, executableDefaultExtensions :: [String] +, executableGhcOptions :: [GhcOption] +, executableCppOptions :: [CppOption] +} deriving (Eq, Show) + +data SourceRepository = SourceRepository { + sourceRepositoryUrl :: String +, sourceRepositorySubdir :: Maybe String +} deriving (Eq, Show) + +mkPackage :: (CaptureUnknownFields PackageConfig) -> IO ([String], Package) +mkPackage (CaptureUnknownFields unknownFields PackageConfig{..}) = do + let dependencies = fromMaybeList packageConfigDependencies + sourceDirs = fromMaybeList packageConfigSourceDirs + defaultExtensions = fromMaybeList packageConfigDefaultExtensions + ghcOptions = fromMaybeList packageConfigGhcOptions + cppOptions = fromMaybeList packageConfigCppOptions + convert f = f sourceDirs dependencies defaultExtensions ghcOptions cppOptions + + mLibrary <- mapM (convert toLibrary) mLibrarySection + executables <- convert toExecutables mExecutableSections + tests <- convert toExecutables mTestSections + + name <- maybe (takeBaseName <$> getCurrentDirectory) return packageConfigName + + licenseFileExists <- doesFileExist "LICENSE" + + missingSourceDirs <- nub . sort <$> filterM (fmap not <$> doesDirectoryExist) ( + maybe [] librarySourceDirs mLibrary + ++ concatMap executableSourceDirs executables + ++ concatMap executableSourceDirs tests + ) + + let package = Package { + packageName = name + , packageVersion = fromMaybe "0.0.0" packageConfigVersion + , packageSynopsis = packageConfigSynopsis + , packageDescription = packageConfigDescription + , packageHomepage = homepage + , packageBugReports = bugReports + , packageCategory = packageConfigCategory + , packageStability = packageConfigStability + , packageAuthor = fromMaybeList packageConfigAuthor + , packageMaintainer = fromMaybeList packageConfigMaintainer + , packageCopyright = fromMaybeList packageConfigCopyright + , packageLicense = packageConfigLicense + , packageLicenseFile = guard licenseFileExists >> Just "LICENSE" + , packageExtraSourceFiles = fromMaybeList packageConfigExtraSourceFiles + , packageSourceRepository = sourceRepository + , packageLibrary = mLibrary + , packageExecutables = executables + , packageTests = tests + } + + warnings = + formatUnknownFields "package description" unknownFields + ++ maybe [] (formatUnknownFields "library section") (captureUnknownFieldsFields <$> packageConfigLibrary) + ++ formatUnknownSectionFields "executable" packageConfigExecutables + ++ formatUnknownSectionFields "test" packageConfigTests + ++ formatMissingSourceDirs missingSourceDirs + + return (warnings, package) + where + mLibrarySection :: Maybe LibrarySection + mLibrarySection = captureUnknownFieldsValue <$> packageConfigLibrary + + mExecutableSections :: Maybe (HashMap String ExecutableSection) + mExecutableSections = fmap captureUnknownFieldsValue <$> packageConfigExecutables + + mTestSections :: Maybe (HashMap String ExecutableSection) + mTestSections = fmap captureUnknownFieldsValue <$> packageConfigTests + + formatUnknownFields name = map f . sort + where + f field = "Ignoring unknown field " ++ show field ++ " in " ++ name + + formatUnknownSectionFields sectionType = maybe [] (concatMap f . Map.toList . fmap captureUnknownFieldsFields) + where + f :: (String, [String]) -> [String] + f (section, fields) = formatUnknownFields (sectionType ++ " section " ++ show section) fields + + formatMissingSourceDirs = map f + where + f name = "Specified source-dir " ++ show name ++ " does not exist" + + sourceRepository :: Maybe SourceRepository + sourceRepository = parseGithub <$> packageConfigGithub + where + parseGithub :: Text -> SourceRepository + parseGithub input = case map T.unpack $ T.splitOn "/" input of + [user, repo, subdir] -> + SourceRepository (githubBaseUrl ++ user ++ "/" ++ repo) (Just subdir) + _ -> SourceRepository (githubBaseUrl ++ T.unpack input) Nothing + + homepage :: Maybe String + homepage = case packageConfigHomepage of + Just Nothing -> Nothing + _ -> join packageConfigHomepage <|> fromGithub + where + fromGithub = (++ "#readme") . sourceRepositoryUrl <$> sourceRepository + + bugReports :: Maybe String + bugReports = case packageConfigBugReports of + Just Nothing -> Nothing + _ -> join packageConfigBugReports <|> fromGithub + where + fromGithub = (++ "/issues") . sourceRepositoryUrl <$> sourceRepository + +toLibrary :: [FilePath] -> [Dependency] -> [String] -> [GhcOption] -> [CppOption] -> LibrarySection -> IO Library +toLibrary globalSourceDirs globalDependencies globalDefaultExtensions globalGhcOptions globalCppOptions LibrarySection{..} = do + modules <- concat <$> mapM getModules sourceDirs + + let (exposedModules, otherModules) = determineModules modules librarySectionExposedModules librarySectionOtherModules + + return (Library sourceDirs exposedModules otherModules dependencies defaultExtensions ghcOptions cppOptions) + where + sourceDirs = globalSourceDirs ++ fromMaybeList librarySectionSourceDirs + dependencies = filter (not . null) [globalDependencies, fromMaybeList librarySectionDependencies] + defaultExtensions = globalDefaultExtensions ++ fromMaybeList librarySectionDefaultExtensions + ghcOptions = globalGhcOptions ++ fromMaybeList librarySectionGhcOptions + cppOptions = globalCppOptions ++ fromMaybeList librarySectionCppOptions + +determineModules :: [String] -> Maybe (List String) -> Maybe (List String) -> ([String], [String]) +determineModules modules mExposedModules mOtherModules = case (mExposedModules, mOtherModules) of + (Nothing, Nothing) -> (modules, []) + _ -> (exposedModules, otherModules) + where + otherModules = maybe (modules \\ exposedModules) fromList mOtherModules + exposedModules = maybe (modules \\ otherModules) fromList mExposedModules + +getModules :: FilePath -> IO [String] +getModules src = do + exits <- doesDirectoryExist src + if exits + then toModules <$> getFilesRecursive src + else return [] + where + toModules :: [[FilePath]] -> [String] + toModules = catMaybes . map toModule + +toExecutables :: [FilePath] -> [Dependency] -> [String] -> [GhcOption] -> [CppOption] -> Maybe (HashMap String ExecutableSection) -> IO [Executable] +toExecutables globalSourceDirs globalDependencies globalDefaultExtensions globalGhcOptions globalCppOptions executables = + (mapM toExecutable . Map.toList) (fromMaybe mempty executables) + where + toExecutable (name, ExecutableSection{..}) = do + modules <- maybe (filterMain . concat <$> mapM getModules sourceDirs) (return . fromList) executableSectionOtherModules + return $ Executable name executableSectionMain sourceDirs modules dependencies defaultExtensions ghcOptions cppOptions + where + dependencies = filter (not . null) [globalDependencies, fromMaybeList executableSectionDependencies] + sourceDirs = globalSourceDirs ++ fromMaybeList executableSectionSourceDirs + defaultExtensions = globalDefaultExtensions ++ fromMaybeList executableSectionDefaultExtensions + ghcOptions = globalGhcOptions ++ fromMaybeList executableSectionGhcOptions + cppOptions = globalCppOptions ++ fromMaybeList executableSectionCppOptions + + filterMain :: [String] -> [String] + filterMain = maybe id (filter . (/=)) (toModule $ splitDirectories executableSectionMain) + +fromMaybeList :: Maybe (List a) -> [a] +fromMaybeList = maybe [] fromList diff --git a/src/Hpack/Run.hs b/src/Hpack/Run.hs new file mode 100644 --- /dev/null +++ b/src/Hpack/Run.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE QuasiQuotes, RecordWildCards #-} +module Hpack.Run ( + run +-- exported for testing +, renderPackage +, renderSourceRepository +) where + +import Control.Applicative +import Control.Monad +import Data.Maybe +import Data.List +import System.Exit.Compat + +import Hpack.Util +import Hpack.Config + +run :: IO ([String], FilePath, String) +run = do + mPackage <- readPackageConfig packageConfig + case mPackage of + Right (warnings, package) -> do + let cabalFile = packageName package ++ ".cabal" + + old <- tryReadFile cabalFile + + let alignment = fromMaybe 16 (old >>= sniffAlignment) + output = renderPackage alignment (maybe [] extractFieldOrderHint old) package + return (warnings, cabalFile, output) + Left err -> die err + +renderPackage :: Int -> [String] -> Package -> String +renderPackage alignment existingFieldOrder Package{..} = intercalate "\n" sections + where + sections :: [String] + sections = catMaybes [ + header + , extraSourceFiles + , sourceRepository + , library + ] ++ renderExecutables packageExecutables ++ renderTests packageTests + + header = Just (unlines $ map formatField sortedFields) + + extraSourceFiles = guard (not . null $ packageExtraSourceFiles) >> Just (unlines $ "extra-source-files:" : map (" " ++) packageExtraSourceFiles) + + sourceRepository = renderSourceRepository <$> packageSourceRepository + + library = renderLibrary <$> packageLibrary + + padding name = replicate (alignment - length name - 2) ' ' + + formatField :: (String, String) -> String + formatField (name, value) = name ++ ": " ++ padding name ++ value + + sortedFields :: [(String, String)] + sortedFields = foldr insertByDefaultFieldOrder (sortBy orderingForExistingFields existing) new + where + (existing, new) = partition ((`elem` existingFieldOrder) . fst) fields + + insertByDefaultFieldOrder :: (String, a) -> [(String, a)] -> [(String, a)] + insertByDefaultFieldOrder x@(key1, _) xs = case xs of + [] -> [x] + y@(key2, _) : ys -> if index key1 < index key2 then x : y : ys else y : insertByDefaultFieldOrder x ys + where + index :: String -> Maybe Int + index = (`elemIndex` defaultFieldOrder) + + orderingForExistingFields :: (String, a) -> (String, a) -> Ordering + orderingForExistingFields (key1, _) (key2, _) = index key1 `compare` index key2 + where + index :: String -> Maybe Int + index = (`elemIndex` existingFieldOrder) + + fields :: [(String, String)] + fields = mapMaybe (\(name, value) -> (,) name <$> value) $ [ + ("name", Just packageName) + , ("version", Just packageVersion) + , ("synopsis", packageSynopsis) + , ("description", (formatDescription <$> packageDescription)) + , ("category", packageCategory) + , ("stability", packageStability) + , ("homepage", packageHomepage) + , ("bug-reports", packageBugReports) + , ("author", formatList packageAuthor) + , ("maintainer", formatList packageMaintainer) + , ("copyright", formatList packageCopyright) + , ("license", packageLicense) + , ("license-file", packageLicenseFile) + , ("build-type", Just "Simple") + , ("cabal-version", Just ">= 1.10") + ] + + formatList :: [String] -> Maybe String + formatList xs = guard (not $ null xs) >> (Just $ intercalate separator xs) + where + separator = ",\n" ++ replicate alignment ' ' + + defaultFieldOrder :: [String] + defaultFieldOrder = map fst fields + + formatDescription = intercalate separator . intersperse "." . lines + where + n = max alignment $ length ("description: ") + separator = "\n" ++ replicate n ' ' + +renderSourceRepository :: SourceRepository -> String +renderSourceRepository SourceRepository{..} = concat [ + "source-repository head\n" + , " type: git\n" + , " location: " ++ sourceRepositoryUrl ++ "\n" + , maybe "" ((" subdir: " ++) . (++ "\n")) sourceRepositorySubdir + ] + +renderExecutables :: [Executable] -> [String] +renderExecutables = map renderExecutable + +renderExecutable :: Executable -> String +renderExecutable executable@Executable{..} = + "executable " + ++ executableName ++ "\n" + ++ renderExecutableSection executable + +renderTests :: [Executable] -> [String] +renderTests = map renderTest + +renderTest :: Executable -> String +renderTest executable@Executable{..} = + "test-suite " ++ executableName ++ "\n" + ++ " type: exitcode-stdio-1.0\n" + ++ renderExecutableSection executable + +renderExecutableSection :: Executable -> String +renderExecutableSection Executable{..} = + renderSourceDirs executableSourceDirs + ++ " main-is: " ++ executableMain ++ "\n" + ++ renderOtherModules executableOtherModules + ++ renderDependencies executableDependencies + ++ renderDefaultExtensions executableDefaultExtensions + ++ renderGhcOptions executableGhcOptions + ++ renderCppOptions executableCppOptions + ++ " default-language: Haskell2010\n" + +renderLibrary :: Library -> String +renderLibrary Library{..} = + "library\n" + ++ renderSourceDirs librarySourceDirs + ++ renderExposedModules libraryExposedModules + ++ renderOtherModules libraryOtherModules + ++ renderDependencies libraryDependencies + ++ renderDefaultExtensions libraryDefaultExtensions + ++ renderGhcOptions libraryGhcOptions + ++ renderCppOptions libraryCppOptions + ++ " default-language: Haskell2010\n" + + +renderSourceDirs :: [String] -> String +renderSourceDirs dirs + | null dirs = "" + | otherwise = " hs-source-dirs: " ++ intercalate ", " dirs ++ "\n" + +renderExposedModules :: [String] -> String +renderExposedModules modules + | null modules = "" + | otherwise = " exposed-modules:\n" ++ (unlines $ map (" " ++) modules) + +renderOtherModules :: [String] -> String +renderOtherModules modules + | null modules = "" + | otherwise = " other-modules:\n" ++ (unlines $ map (" " ++) modules) + +renderDependencies :: [[Dependency]] -> String +renderDependencies dependencies + | null dependencies = "" + | otherwise = concatMap render $ zip (True : repeat False) (map (map dependencyName) dependencies) + where + render (isFirst, xs) + | isFirst = " build-depends:\n " ++ intercalate "\n , " xs ++ "\n" + | otherwise = "\n , " ++ intercalate "\n , " xs ++ "\n" + +renderGhcOptions :: [GhcOption] -> String +renderGhcOptions = renderOptions "ghc-options" + +renderCppOptions :: [GhcOption] -> String +renderCppOptions = renderOptions "cpp-options" + +renderDefaultExtensions :: [String] -> String +renderDefaultExtensions = renderOptions "default-extensions" + +renderOptions :: String -> [String] -> String +renderOptions field options + | null options = "" + | otherwise = " " ++ field ++ ": " ++ unwords options ++ "\n" diff --git a/src/Hpack/Util.hs b/src/Hpack/Util.hs new file mode 100644 --- /dev/null +++ b/src/Hpack/Util.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module Hpack.Util ( + List(..) +, toModule +, getFilesRecursive +, tryReadFile +, sniffAlignment +, extractFieldOrderHint + +-- exported for testing +, splitField +) where + +import Control.Applicative +import Control.Monad +import Control.Exception +import Control.DeepSeq +import Data.Char +import Data.Maybe +import Data.List +import System.Directory +import System.FilePath +import Data.Data + +import Data.Aeson.Types + +newtype List a = List {fromList :: [a]} + deriving (Eq, Show, Data, Typeable) + +instance FromJSON a => FromJSON (List a) where + parseJSON v = List <$> (parseJSON v <|> (return <$> parseJSON v)) + +toModule :: [FilePath] -> Maybe String +toModule path = case reverse path of + [] -> Nothing + x : xs -> do + m <- stripSuffix ".hs" x <|> stripSuffix ".lhs" x + let name = reverse (m : xs) + guard (all isValidModuleName name) >> return (intercalate "." name) + where + stripSuffix :: String -> String -> Maybe String + stripSuffix suffix x = reverse <$> stripPrefix (reverse suffix) (reverse x) + +-- See `Cabal.Distribution.ModuleName` (http://git.io/bj34) +isValidModuleName :: String -> Bool +isValidModuleName [] = False +isValidModuleName (c:cs) = isUpper c && all isValidModuleChar cs + +isValidModuleChar :: Char -> Bool +isValidModuleChar c = isAlphaNum c || c == '_' || c == '\'' + +getFilesRecursive :: FilePath -> IO [[FilePath]] +getFilesRecursive baseDir = sort <$> go [] + where + go :: [FilePath] -> IO [[FilePath]] + go dir = do + c <- map ((dir ++) . return) . filter (`notElem` [".", ".."]) <$> getDirectoryContents (pathTo dir) + subdirsFiles <- filterM (doesDirectoryExist . pathTo) c >>= mapM go + files <- filterM (doesFileExist . pathTo) c + return (files ++ concat subdirsFiles) + where + pathTo :: [FilePath] -> FilePath + pathTo p = baseDir joinPath p + +tryReadFile :: FilePath -> IO (Maybe String) +tryReadFile file = do + r <- try (readFile file) :: IO (Either IOException String) + return $!! either (const Nothing) Just r + +extractFieldOrderHint :: String -> [String] +extractFieldOrderHint = map fst . catMaybes . map splitField . lines + +sniffAlignment :: String -> Maybe Int +sniffAlignment input = case nub . catMaybes . map indentation . catMaybes . map splitField $ lines input of + [n] -> Just n + _ -> Nothing + where + + indentation :: (String, String) -> Maybe Int + indentation (name, value) = case span isSpace value of + (_, "") -> Nothing + (xs, _) -> (Just . succ . length $ name ++ xs) + +splitField :: String -> Maybe (String, String) +splitField field = case span isNameChar field of + (xs, ':':ys) -> Just (xs, ys) + _ -> Nothing + where + isNameChar = (`elem` nameChars) + nameChars = ['a'..'z'] ++ ['A'..'Z'] ++ "-" diff --git a/src/Run.hs b/src/Run.hs deleted file mode 100644 --- a/src/Run.hs +++ /dev/null @@ -1,191 +0,0 @@ -{-# LANGUAGE QuasiQuotes, RecordWildCards #-} -module Run ( - run -, configFile --- exported for testing -, renderPackage -) where - -import Control.Applicative -import Control.Monad -import Data.Maybe -import Data.List -import System.Exit.Compat - -import Util -import Config - -configFile :: FilePath -configFile = "package.yaml" - -run :: IO ([String], FilePath, String) -run = do - mPackage <- readPackageConfig configFile - case mPackage of - Right (warnings, package) -> do - let cabalFile = packageName package ++ ".cabal" - - old <- tryReadFile cabalFile - - let alignment = fromMaybe 16 (old >>= sniffAlignment) - output = renderPackage alignment (maybe [] extractFieldOrderHint old) package - return (warnings, cabalFile, output) - Left err -> die err - -renderPackage :: Int -> [String] -> Package -> String -renderPackage alignment existingFieldOrder Package{..} = intercalate "\n" sections - where - sections :: [String] - sections = catMaybes [ - header - , extraSourceFiles - , sourceRepository - , library - ] ++ renderExecutables packageExecutables ++ renderTests packageTests - - header = Just (unlines $ map formatField sortedFields) - - extraSourceFiles = guard (not . null $ packageExtraSourceFiles) >> Just (unlines $ "extra-source-files:" : map (" " ++) packageExtraSourceFiles) - - sourceRepository = renderSourceRepository <$> packageSourceRepository - - library = renderLibrary <$> packageLibrary - - padding name = replicate (alignment - length name - 2) ' ' - - formatField :: (String, String) -> String - formatField (name, value) = name ++ ": " ++ padding name ++ value - - sortedFields :: [(String, String)] - sortedFields = foldr insertByDefaultFieldOrder (sortBy orderingForExistingFields existing) new - where - (existing, new) = partition ((`elem` existingFieldOrder) . fst) fields - - insertByDefaultFieldOrder :: (String, a) -> [(String, a)] -> [(String, a)] - insertByDefaultFieldOrder x@(key1, _) xs = case xs of - [] -> [x] - y@(key2, _) : ys -> if index key1 < index key2 then x : y : ys else y : insertByDefaultFieldOrder x ys - where - index :: String -> Maybe Int - index = (`elemIndex` defaultFieldOrder) - - orderingForExistingFields :: (String, a) -> (String, a) -> Ordering - orderingForExistingFields (key1, _) (key2, _) = index key1 `compare` index key2 - where - index :: String -> Maybe Int - index = (`elemIndex` existingFieldOrder) - - fields :: [(String, String)] - fields = mapMaybe (\(name, value) -> (,) name <$> value) $ [ - ("name", Just packageName) - , ("version", Just packageVersion) - , ("synopsis", packageSynopsis) - , ("description", (formatDescription <$> packageDescription)) - , ("category", packageCategory) - , ("stability", packageStability) - , ("homepage", packageHomepage) - , ("bug-reports", packageBugReports) - , ("author", formatList packageAuthor) - , ("maintainer", formatList packageMaintainer) - , ("copyright", formatList packageCopyright) - , ("license", packageLicense) - , ("license-file", packageLicenseFile) - , ("build-type", Just "Simple") - , ("cabal-version", Just ">= 1.10") - ] - - formatList :: [String] -> Maybe String - formatList xs = guard (not $ null xs) >> (Just $ intercalate separator xs) - where - separator = ",\n" ++ replicate alignment ' ' - - defaultFieldOrder :: [String] - defaultFieldOrder = map fst fields - - formatDescription = intercalate separator . intersperse "." . lines - where - n = max alignment $ length ("description: ") - separator = "\n" ++ replicate n ' ' - - renderSourceRepository :: String -> String - renderSourceRepository url = "source-repository head\n type: git\n location: " ++ url ++ "\n" - -renderExecutables :: [Executable] -> [String] -renderExecutables = map renderExecutable - -renderExecutable :: Executable -> String -renderExecutable executable@Executable{..} = - "executable " - ++ executableName ++ "\n" - ++ renderExecutableSection executable - -renderTests :: [Executable] -> [String] -renderTests = map renderTest - -renderTest :: Executable -> String -renderTest executable@Executable{..} = - "test-suite " ++ executableName ++ "\n" - ++ " type: exitcode-stdio-1.0\n" - ++ renderExecutableSection executable - -renderExecutableSection :: Executable -> String -renderExecutableSection Executable{..} = - renderSourceDirs executableSourceDirs - ++ " main-is: " ++ executableMain ++ "\n" - ++ renderOtherModules executableOtherModules - ++ renderDependencies executableDependencies - ++ renderDefaultExtensions executableDefaultExtensions - ++ renderGhcOptions executableGhcOptions - ++ renderCppOptions executableCppOptions - ++ " default-language: Haskell2010\n" - -renderLibrary :: Library -> String -renderLibrary Library{..} = - "library\n" - ++ renderSourceDirs librarySourceDirs - ++ renderExposedModules libraryExposedModules - ++ renderOtherModules libraryOtherModules - ++ renderDependencies libraryDependencies - ++ renderDefaultExtensions libraryDefaultExtensions - ++ renderGhcOptions libraryGhcOptions - ++ renderCppOptions libraryCppOptions - ++ " default-language: Haskell2010\n" - - -renderSourceDirs :: [String] -> String -renderSourceDirs dirs - | null dirs = "" - | otherwise = " hs-source-dirs: " ++ intercalate ", " dirs ++ "\n" - -renderExposedModules :: [String] -> String -renderExposedModules modules - | null modules = "" - | otherwise = " exposed-modules:\n" ++ (unlines $ map (" " ++) modules) - -renderOtherModules :: [String] -> String -renderOtherModules modules - | null modules = "" - | otherwise = " other-modules:\n" ++ (unlines $ map (" " ++) modules) - -renderDependencies :: [[Dependency]] -> String -renderDependencies dependencies - | null dependencies = "" - | otherwise = concatMap render $ zip (True : repeat False) dependencies - where - render (isFirst, xs) - | isFirst = " build-depends:\n " ++ intercalate "\n , " xs ++ "\n" - | otherwise = "\n , " ++ intercalate "\n , " xs ++ "\n" - -renderGhcOptions :: [GhcOption] -> String -renderGhcOptions = renderOptions "ghc-options" - -renderCppOptions :: [GhcOption] -> String -renderCppOptions = renderOptions "cpp-options" - -renderDefaultExtensions :: [String] -> String -renderDefaultExtensions = renderOptions "default-extensions" - -renderOptions :: String -> [String] -> String -renderOptions field options - | null options = "" - | otherwise = " " ++ field ++ ": " ++ unwords options ++ "\n" diff --git a/src/Util.hs b/src/Util.hs deleted file mode 100644 --- a/src/Util.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -module Util ( - List(..) -, toModule -, getFilesRecursive -, tryReadFile -, sniffAlignment -, extractFieldOrderHint - --- exported for testing -, splitField -) where - -import Control.Applicative -import Control.Monad -import Control.Exception -import Control.DeepSeq -import Data.Char -import Data.Maybe -import Data.List -import System.Directory -import System.FilePath -import Data.Data - -import Data.Aeson.Types - -newtype List a = List {fromList :: [a]} - deriving (Eq, Show, Data, Typeable) - -instance FromJSON a => FromJSON (List a) where - parseJSON v = List <$> (parseJSON v <|> (return <$> parseJSON v)) - -toModule :: [FilePath] -> Maybe String -toModule path = case reverse path of - [] -> Nothing - x : xs -> do - m <- stripSuffix ".hs" x <|> stripSuffix ".lhs" x - let name = reverse (m : xs) - guard (all isValidModuleName name) >> return (intercalate "." name) - where - stripSuffix :: String -> String -> Maybe String - stripSuffix suffix x = reverse <$> stripPrefix (reverse suffix) (reverse x) - --- See `Cabal.Distribution.ModuleName` (http://git.io/bj34) -isValidModuleName :: String -> Bool -isValidModuleName [] = False -isValidModuleName (c:cs) = isUpper c && all isValidModuleChar cs - -isValidModuleChar :: Char -> Bool -isValidModuleChar c = isAlphaNum c || c == '_' || c == '\'' - -getFilesRecursive :: FilePath -> IO [[FilePath]] -getFilesRecursive baseDir = sort <$> go [] - where - go :: [FilePath] -> IO [[FilePath]] - go dir = do - c <- map ((dir ++) . return) . filter (`notElem` [".", ".."]) <$> getDirectoryContents (pathTo dir) - subdirsFiles <- filterM (doesDirectoryExist . pathTo) c >>= mapM go - files <- filterM (doesFileExist . pathTo) c - return (files ++ concat subdirsFiles) - where - pathTo :: [FilePath] -> FilePath - pathTo p = baseDir joinPath p - -tryReadFile :: FilePath -> IO (Maybe String) -tryReadFile file = do - r <- try (readFile file) :: IO (Either IOException String) - return $!! either (const Nothing) Just r - -extractFieldOrderHint :: String -> [String] -extractFieldOrderHint = map fst . catMaybes . map splitField . lines - -sniffAlignment :: String -> Maybe Int -sniffAlignment input = case nub . catMaybes . map indentation . catMaybes . map splitField $ lines input of - [n] -> Just n - _ -> Nothing - where - - indentation :: (String, String) -> Maybe Int - indentation (name, value) = case span isSpace value of - (_, "") -> Nothing - (xs, _) -> (Just . succ . length $ name ++ xs) - -splitField :: String -> Maybe (String, String) -splitField field = case span isNameChar field of - (xs, ':':ys) -> Just (xs, ys) - _ -> Nothing - where - isNameChar = (`elem` nameChars) - nameChars = ['a'..'z'] ++ ['A'..'Z'] ++ "-" diff --git a/test/ConfigSpec.hs b/test/ConfigSpec.hs deleted file mode 100644 --- a/test/ConfigSpec.hs +++ /dev/null @@ -1,526 +0,0 @@ -{-# LANGUAGE QuasiQuotes, OverloadedLists #-} -module ConfigSpec ( - main -, spec - -, package -, executable -, library -) where - -import Helper - -import Data.String.Interpolate - -import Config - -main :: IO () -main = hspec spec - -package :: Package -package = Package "foo" "0.0.0" Nothing Nothing Nothing Nothing Nothing Nothing [] [] [] Nothing Nothing [] Nothing Nothing [] [] - -executable :: String -> String -> Executable -executable name main_ = Executable name main_ [] [] [] [] [] [] - -library :: Library -library = Library [] [] [] [] [] [] [] - -spec :: Spec -spec = around_ (inTempDirectoryNamed "foo") $ do - describe "readPackageConfig" $ do - it "warns on unknown fields" $ do - writeFile "package.yml" [i| - bar: 23 - baz: 42 - |] - fmap fst <$> readPackageConfig "package.yml" `shouldReturn` Right [ - "Ignoring unknown field \"bar\" in package description" - , "Ignoring unknown field \"baz\" in package description" - ] - - it "accepts name" $ do - writeFile "package.yml" [i| - name: bar - |] - Right (_, c) <- readPackageConfig "package.yml" - c `shouldBe` package {packageName = "bar"} - - it "accepts version" $ do - writeFile "package.yml" [i| - version: 0.1.0 - |] - Right (_, c) <- readPackageConfig "package.yml" - c `shouldBe` package {packageVersion = "0.1.0"} - - it "accepts synopsis" $ do - writeFile "package.yml" [i| - synopsis: some synopsis - |] - Right (_, c) <- readPackageConfig "package.yml" - c `shouldBe` package {packageSynopsis = Just "some synopsis"} - - it "accepts description" $ do - writeFile "package.yml" [i| - description: some description - |] - Right (_, c) <- readPackageConfig "package.yml" - c `shouldBe` package {packageDescription = Just "some description"} - - it "accepts category" $ do - writeFile "package.yml" [i| - category: Data - |] - Right (_, c) <- readPackageConfig "package.yml" - c `shouldBe` package {packageCategory = Just "Data"} - - it "accepts author" $ do - writeFile "package.yml" [i| - author: John Doe - |] - Right (_, c) <- readPackageConfig "package.yml" - c `shouldBe` package {packageAuthor = ["John Doe"]} - - it "accepts maintainer" $ do - writeFile "package.yml" [i| - maintainer: John Doe - |] - Right (_, c) <- readPackageConfig "package.yml" - c `shouldBe` package {packageMaintainer = ["John Doe "]} - - it "accepts copyright" $ do - writeFile "package.yml" [i| - copyright: (c) 2015 John Doe - |] - Right (_, c) <- readPackageConfig "package.yml" - c `shouldBe` package {packageCopyright = ["(c) 2015 John Doe"]} - - it "accepts stability" $ do - writeFile "package.yml" [i| - stability: experimental - |] - Right (_, c) <- readPackageConfig "package.yml" - packageStability c `shouldBe` Just "experimental" - - it "accepts homepage URL" $ do - writeFile "package.yml" [i| - github: hspec/hspec - homepage: https://example.com/ - |] - Right (_, c) <- readPackageConfig "package.yml" - packageHomepage c `shouldBe` Just "https://example.com/" - - it "infers homepage URL from github" $ do - writeFile "package.yml" [i| - github: hspec/hspec - |] - Right (_, c) <- readPackageConfig "package.yml" - packageHomepage c `shouldBe` Just "https://github.com/hspec/hspec#readme" - - it "omits homepage URL if it is null" $ do - writeFile "package.yml" [i| - github: hspec/hspec - homepage: null - |] - Right (_, c) <- readPackageConfig "package.yml" - packageHomepage c `shouldBe` Nothing - - it "accepts bug-reports URL" $ do - writeFile "package.yml" [i| - github: hspec/hspec - bug-reports: https://example.com/issues - |] - Right (_, c) <- readPackageConfig "package.yml" - packageBugReports c `shouldBe` Just "https://example.com/issues" - - it "infers bug-reports URL from github" $ do - writeFile "package.yml" [i| - github: hspec/hspec - |] - Right (_, c) <- readPackageConfig "package.yml" - packageBugReports c `shouldBe` Just "https://github.com/hspec/hspec/issues" - - it "omits bug-reports URL if it is null" $ do - writeFile "package.yml" [i| - github: hspec/hspec - bug-reports: null - |] - Right (_, c) <- readPackageConfig "package.yml" - packageBugReports c `shouldBe` Nothing - - it "accepts license" $ do - writeFile "package.yml" [i| - license: MIT - |] - Right (_, c) <- readPackageConfig "package.yml" - c `shouldBe` package {packageLicense = Just "MIT"} - - it "infers license file" $ do - writeFile "package.yml" [i| - name: foo - |] - touch "LICENSE" - Right (_, c) <- readPackageConfig "package.yml" - c `shouldBe` package {packageLicenseFile = Just "LICENSE"} - - it "accepts extra-source-files" $ do - writeFile "package.yml" [i| - extra-source-files: - - CHANGES.markdown - - README.markdown - |] - Right (_, c) <- readPackageConfig "package.yml" - packageExtraSourceFiles c `shouldBe` ["CHANGES.markdown", "README.markdown"] - - it "accepts github" $ do - writeFile "package.yml" [i| - github: hspec/hspec - |] - Right (_, c) <- readPackageConfig "package.yml" - packageSourceRepository c `shouldBe` Just "https://github.com/hspec/hspec" - - it "accepts CPP options" $ do - writeFile "package.yml" [i| - cpp-options: -DFOO - library: - cpp-options: -DLIB - - executables: - foo: - main: Main.hs - cpp-options: -DFOO - - - tests: - spec: - main: Spec.hs - cpp-options: -DTEST - |] - Right (_, c) <- readPackageConfig "package.yml" - c `shouldBe` package { - packageLibrary = Just library {libraryCppOptions = ["-DFOO", "-DLIB"]} - , packageExecutables = [(executable "foo" "Main.hs") {executableCppOptions = ["-DFOO", "-DFOO"]}] - , packageTests = [(executable "spec" "Spec.hs") {executableCppOptions = ["-DFOO", "-DTEST"]}] - } - - context "when reading library section" $ do - it "warns on unknown fields" $ do - writeFile "package.yml" [i| - library: - bar: 23 - baz: 42 - |] - - fmap fst <$> readPackageConfig "package.yml" `shouldReturn` Right [ - "Ignoring unknown field \"bar\" in library section" - , "Ignoring unknown field \"baz\" in library section" - ] - - it "accepts source-dirs" $ do - writeFile "package.yml" [i| - library: - source-dirs: - - foo - - bar - |] - Right (_, c) <- readPackageConfig "package.yml" - packageLibrary c `shouldBe` Just library {librarySourceDirs = ["foo", "bar"]} - - it "accepts default-extensions" $ do - writeFile "package.yml" [i| - library: - default-extensions: - - Foo - - Bar - |] - Right (_, c) <- readPackageConfig "package.yml" - packageLibrary c `shouldBe` Just library {libraryDefaultExtensions = ["Foo", "Bar"]} - - it "accepts global default-extensions" $ do - writeFile "package.yml" [i| - default-extensions: - - Foo - - Bar - library: {} - |] - Right (_, c) <- readPackageConfig "package.yml" - packageLibrary c `shouldBe` Just library {libraryDefaultExtensions = ["Foo", "Bar"]} - - it "accepts global source-dirs" $ do - writeFile "package.yml" [i| - source-dirs: - - foo - - bar - library: {} - |] - Right (_, c) <- readPackageConfig "package.yml" - packageLibrary c `shouldBe` Just library {librarySourceDirs = ["foo", "bar"]} - - it "allows to specify exposed-modules" $ do - writeFile "package.yml" [i| - library: - source-dirs: src - exposed-modules: Foo - |] - touch "src/Foo.hs" - touch "src/Bar.hs" - Right (_, c) <- readPackageConfig "package.yml" - packageLibrary c `shouldBe` Just library {librarySourceDirs = ["src"], libraryExposedModules = ["Foo"], libraryOtherModules = ["Bar"]} - - it "allows to specify other-modules" $ do - writeFile "package.yml" [i| - library: - source-dirs: src - other-modules: Bar - |] - touch "src/Foo.hs" - touch "src/Bar.hs" - Right (_, c) <- readPackageConfig "package.yml" - packageLibrary c `shouldBe` Just library {librarySourceDirs = ["src"], libraryExposedModules = ["Foo"], libraryOtherModules = ["Bar"]} - - it "allows to specify both exposed-modules and other-modules" $ do - writeFile "package.yml" [i| - library: - source-dirs: src - exposed-modules: Foo - other-modules: Bar - |] - touch "src/Baz.hs" - Right (_, c) <- readPackageConfig "package.yml" - packageLibrary c `shouldBe` Just library {librarySourceDirs = ["src"], libraryExposedModules = ["Foo"], libraryOtherModules = ["Bar"]} - - context "when neither exposed-module nor other-module are specified" $ do - it "exposes all modules" $ do - writeFile "package.yml" [i| - library: - source-dirs: src - |] - touch "src/Foo.hs" - touch "src/Bar.hs" - Right (_, c) <- readPackageConfig "package.yml" - packageLibrary c `shouldBe` Just library {librarySourceDirs = ["src"], libraryExposedModules = ["Bar", "Foo"]} - - context "when reading executable section" $ do - it "warns on unknown fields" $ do - writeFile "package.yml" [i| - executables: - foo: - main: Main.hs - bar: 42 - baz: 23 - |] - - fmap fst <$> readPackageConfig "package.yml" `shouldReturn` Right [ - "Ignoring unknown field \"bar\" in executable section \"foo\"" - , "Ignoring unknown field \"baz\" in executable section \"foo\"" - ] - - it "reads executable section" $ do - writeFile "package.yml" [i| - executables: - foo: - main: driver/Main.hs - |] - Right (_, c) <- readPackageConfig "package.yml" - packageExecutables c `shouldBe` [executable "foo" "driver/Main.hs"] - - it "accepts source-dirs" $ do - writeFile "package.yml" [i| - executables: - foo: - main: Main.hs - source-dirs: - - foo - - bar - |] - Right (_, c) <- readPackageConfig "package.yml" - packageExecutables c `shouldBe` [(executable "foo" "Main.hs") {executableSourceDirs = ["foo", "bar"]}] - - it "accepts global source-dirs" $ do - writeFile "package.yml" [i| - source-dirs: - - foo - - bar - executables: - foo: - main: Main.hs - |] - Right (_, c) <- readPackageConfig "package.yml" - packageExecutables c `shouldBe` [(executable "foo" "Main.hs") {executableSourceDirs = ["foo", "bar"]}] - - it "infers other-modules" $ do - touch "src/Main.hs" - touch "src/Foo.hs" - touch "src/Bar.hs" - touch "src/Baz.lhs" - writeFile "package.yml" [i| - executables: - foo: - main: Main.hs - source-dirs: src - |] - Right (_, [r]) <- (fmap . fmap) packageExecutables <$> readPackageConfig "package.yml" - executableOtherModules r `shouldBe` ["Bar", "Baz", "Foo"] - - it "allows to specify other-modules" $ do - touch "src/Foo.hs" - touch "src/Bar.hs" - writeFile "package.yml" [i| - executables: - foo: - main: Main.hs - source-dirs: src - other-modules: Baz - |] - Right (_, [r]) <- (fmap . fmap) packageExecutables <$> readPackageConfig "package.yml" - executableOtherModules r `shouldBe` ["Baz"] - - it "accepts default-extensions" $ do - writeFile "package.yml" [i| - executables: - foo: - main: driver/Main.hs - default-extensions: - - Foo - - Bar - |] - Right (_, c) <- readPackageConfig "package.yml" - packageExecutables c `shouldBe` [(executable "foo" "driver/Main.hs") {executableDefaultExtensions = ["Foo", "Bar"]}] - - it "accepts global default-extensions" $ do - writeFile "package.yml" [i| - default-extensions: - - Foo - - Bar - executables: - foo: - main: driver/Main.hs - |] - Right (_, c) <- readPackageConfig "package.yml" - packageExecutables c `shouldBe` [(executable "foo" "driver/Main.hs") {executableDefaultExtensions = ["Foo", "Bar"]}] - - it "accepts GHC options" $ do - writeFile "package.yml" [i| - executables: - foo: - main: driver/Main.hs - ghc-options: -Wall - |] - Right (_, c) <- readPackageConfig "package.yml" - c `shouldBe` package {packageExecutables = [(executable "foo" "driver/Main.hs") {executableGhcOptions = ["-Wall"]}]} - - it "accepts global GHC options" $ do - writeFile "package.yml" [i| - ghc-options: -Wall - executables: - foo: - main: driver/Main.hs - |] - Right (_, c) <- readPackageConfig "package.yml" - c `shouldBe` package {packageExecutables = [(executable "foo" "driver/Main.hs") {executableGhcOptions = ["-Wall"]}]} - - context "when reading test section" $ do - it "warns on unknown fields" $ do - writeFile "package.yml" [i| - tests: - foo: - main: Main.hs - bar: 42 - baz: 23 - |] - - fmap fst <$> readPackageConfig "package.yml" `shouldReturn` Right [ - "Ignoring unknown field \"bar\" in test section \"foo\"" - , "Ignoring unknown field \"baz\" in test section \"foo\"" - ] - - it "reads test section" $ do - writeFile "package.yml" [i| - tests: - spec: - main: test/Spec.hs - |] - Right (_, c) <- readPackageConfig "package.yml" - c `shouldBe` package {packageTests = [executable "spec" "test/Spec.hs"]} - - it "accepts single dependency" $ do - writeFile "package.yml" [i| - tests: - spec: - main: test/Spec.hs - dependencies: hspec - |] - Right (_, c) <- readPackageConfig "package.yml" - c `shouldBe` package {packageTests = [(executable "spec" "test/Spec.hs") {executableDependencies = [["hspec"]]}]} - - it "accepts list of dependencies" $ do - writeFile "package.yml" [i| - tests: - spec: - main: test/Spec.hs - dependencies: - - hspec - - QuickCheck - |] - Right (_, c) <- readPackageConfig "package.yml" - c `shouldBe` package {packageTests = [(executable "spec" "test/Spec.hs") {executableDependencies = [["hspec", "QuickCheck"]]}]} - - context "when both global and section specific dependencies are specified" $ do - it "combines dependencies" $ do - writeFile "package.yml" [i| - dependencies: - - base - - tests: - spec: - main: test/Spec.hs - dependencies: hspec - |] - Right (_, c) <- readPackageConfig "package.yml" - c `shouldBe` package {packageTests = [(executable "spec" "test/Spec.hs") {executableDependencies = [["base"], ["hspec"]]}]} - - context "when a specified source directory does not exist" $ do - it "warns" $ do - writeFile "package.yml" [i| - source-dirs: - - some-dir - - some-existing-dir - library: - source-dirs: some-lib-dir - executables: - main: - main: Main.hs - source-dirs: some-exec-dir - tests: - spec: - main: Main.hs - source-dirs: some-test-dir - |] - touch "some-existing-dir/foo" - fmap fst <$> readPackageConfig "package.yml" `shouldReturn` Right [ - "Specified source-dir " ++ show "some-dir" ++ " does not exist" - , "Specified source-dir " ++ show "some-exec-dir" ++ " does not exist" - , "Specified source-dir " ++ show "some-lib-dir" ++ " does not exist" - , "Specified source-dir " ++ show "some-test-dir" ++ " does not exist" - ] - - context "when package.yml can not be parsed" $ do - it "returns an error" $ do - writeFile "package.yml" [i| - foo: bar - foo baz - |] - readPackageConfig "package.yml" `shouldReturn` Left "package.yml:3:10: could not find expected ':' while scanning a simple key" - - context "when package.yml is invalid" $ do - it "returns an error" $ do - writeFile "package.yml" [i| - executables: - foo: - ain: driver/Main.hs - |] - readPackageConfig "package.yml" `shouldReturn` Left "package.yml: The key \"main\" was not found" - - context "when package.yml does not exist" $ do - it "returns an error" $ - readPackageConfig "package.yml" `shouldReturn` Left "package.yml: Yaml file not found: package.yml" diff --git a/test/Hpack/ConfigSpec.hs b/test/Hpack/ConfigSpec.hs new file mode 100644 --- /dev/null +++ b/test/Hpack/ConfigSpec.hs @@ -0,0 +1,585 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +module Hpack.ConfigSpec ( + main +, spec + +, package +, executable +, library +) where + +import Helper + +import Data.Aeson.Types +import Data.Aeson.QQ +import Data.String.Interpolate + +import Hpack.Config + +main :: IO () +main = hspec spec + +package :: Package +package = Package "foo" "0.0.0" Nothing Nothing Nothing Nothing Nothing Nothing [] [] [] Nothing Nothing [] Nothing Nothing [] [] + +executable :: String -> String -> Executable +executable name main_ = Executable name main_ [] [] [] [] [] [] + +library :: Library +library = Library [] [] [] [] [] [] [] + +spec :: Spec +spec = do + describe "parseJSON" $ do + context "when parsing a Dependency" $ do + it "accepts simple dependencies" $ do + parseEither parseJSON "hpack" `shouldBe` Right (Dependency "hpack" Nothing) + + it "accepts git dependencies" $ do + let value = [aesonQQ|{ + name: "hpack", + git: "https://github.com/sol/hpack", + ref: "master" + }|] + git = GitRef "https://github.com/sol/hpack" "master" + parseEither parseJSON value `shouldBe` Right (Dependency "hpack" (Just git)) + + it "accepts github dependencies" $ do + let value = [aesonQQ|{ + name: "hpack", + github: "sol/hpack", + ref: "master" + }|] + git = GitRef "https://github.com/sol/hpack" "master" + parseEither parseJSON value `shouldBe` Right (Dependency "hpack" (Just git)) + + context "when parsing fails" $ do + it "returns an error message" $ do + let value = Number 23 + parseEither parseJSON value `shouldBe` (Left "when expecting a String or an Object, encountered Number instead" :: Either String Dependency) + + context "when ref is missing" $ do + it "produces accurate error messages" $ do + let value = [aesonQQ|{ + name: "hpack", + git: "sol/hpack", + ef: "master" + }|] + parseEither parseJSON value `shouldBe` (Left "key \"ref\" not present" :: Either String Dependency) + + context "when both git and github are missing" $ do + it "produces accurate error messages" $ do + let value = [aesonQQ|{ + name: "hpack", + gi: "sol/hpack", + ref: "master" + }|] + parseEither parseJSON value `shouldBe` (Left "neither key \"git\" nor key \"github\" present" :: Either String Dependency) + + describe "readPackageConfig" $ around_ (inTempDirectoryNamed "foo") $ do + it "warns on unknown fields" $ do + writeFile "package.yaml" [i| + bar: 23 + baz: 42 + |] + fmap fst <$> readPackageConfig "package.yaml" `shouldReturn` Right [ + "Ignoring unknown field \"bar\" in package description" + , "Ignoring unknown field \"baz\" in package description" + ] + + it "accepts name" $ do + writeFile "package.yaml" [i| + name: bar + |] + Right (_, c) <- readPackageConfig "package.yaml" + c `shouldBe` package {packageName = "bar"} + + it "accepts version" $ do + writeFile "package.yaml" [i| + version: 0.1.0 + |] + Right (_, c) <- readPackageConfig "package.yaml" + c `shouldBe` package {packageVersion = "0.1.0"} + + it "accepts synopsis" $ do + writeFile "package.yaml" [i| + synopsis: some synopsis + |] + Right (_, c) <- readPackageConfig "package.yaml" + c `shouldBe` package {packageSynopsis = Just "some synopsis"} + + it "accepts description" $ do + writeFile "package.yaml" [i| + description: some description + |] + Right (_, c) <- readPackageConfig "package.yaml" + c `shouldBe` package {packageDescription = Just "some description"} + + it "accepts category" $ do + writeFile "package.yaml" [i| + category: Data + |] + Right (_, c) <- readPackageConfig "package.yaml" + c `shouldBe` package {packageCategory = Just "Data"} + + it "accepts author" $ do + writeFile "package.yaml" [i| + author: John Doe + |] + Right (_, c) <- readPackageConfig "package.yaml" + c `shouldBe` package {packageAuthor = ["John Doe"]} + + it "accepts maintainer" $ do + writeFile "package.yaml" [i| + maintainer: John Doe + |] + Right (_, c) <- readPackageConfig "package.yaml" + c `shouldBe` package {packageMaintainer = ["John Doe "]} + + it "accepts copyright" $ do + writeFile "package.yaml" [i| + copyright: (c) 2015 John Doe + |] + Right (_, c) <- readPackageConfig "package.yaml" + c `shouldBe` package {packageCopyright = ["(c) 2015 John Doe"]} + + it "accepts stability" $ do + writeFile "package.yaml" [i| + stability: experimental + |] + Right (_, c) <- readPackageConfig "package.yaml" + packageStability c `shouldBe` Just "experimental" + + it "accepts homepage URL" $ do + writeFile "package.yaml" [i| + github: hspec/hspec + homepage: https://example.com/ + |] + Right (_, c) <- readPackageConfig "package.yaml" + packageHomepage c `shouldBe` Just "https://example.com/" + + it "infers homepage URL from github" $ do + writeFile "package.yaml" [i| + github: hspec/hspec + |] + Right (_, c) <- readPackageConfig "package.yaml" + packageHomepage c `shouldBe` Just "https://github.com/hspec/hspec#readme" + + it "omits homepage URL if it is null" $ do + writeFile "package.yaml" [i| + github: hspec/hspec + homepage: null + |] + Right (_, c) <- readPackageConfig "package.yaml" + packageHomepage c `shouldBe` Nothing + + it "accepts bug-reports URL" $ do + writeFile "package.yaml" [i| + github: hspec/hspec + bug-reports: https://example.com/issues + |] + Right (_, c) <- readPackageConfig "package.yaml" + packageBugReports c `shouldBe` Just "https://example.com/issues" + + it "infers bug-reports URL from github" $ do + writeFile "package.yaml" [i| + github: hspec/hspec + |] + Right (_, c) <- readPackageConfig "package.yaml" + packageBugReports c `shouldBe` Just "https://github.com/hspec/hspec/issues" + + it "omits bug-reports URL if it is null" $ do + writeFile "package.yaml" [i| + github: hspec/hspec + bug-reports: null + |] + Right (_, c) <- readPackageConfig "package.yaml" + packageBugReports c `shouldBe` Nothing + + it "accepts license" $ do + writeFile "package.yaml" [i| + license: MIT + |] + Right (_, c) <- readPackageConfig "package.yaml" + c `shouldBe` package {packageLicense = Just "MIT"} + + it "infers license file" $ do + writeFile "package.yaml" [i| + name: foo + |] + touch "LICENSE" + Right (_, c) <- readPackageConfig "package.yaml" + c `shouldBe` package {packageLicenseFile = Just "LICENSE"} + + it "accepts extra-source-files" $ do + writeFile "package.yaml" [i| + extra-source-files: + - CHANGES.markdown + - README.markdown + |] + Right (_, c) <- readPackageConfig "package.yaml" + packageExtraSourceFiles c `shouldBe` ["CHANGES.markdown", "README.markdown"] + + it "accepts github" $ do + writeFile "package.yaml" [i| + github: hspec/hspec + |] + Right (_, c) <- readPackageConfig "package.yaml" + packageSourceRepository c `shouldBe` + Just (SourceRepository "https://github.com/hspec/hspec" Nothing) + + it "accepts third part of github URL as subdir" $ do + writeFile "package.yaml" [i| + github: hspec/hspec/hspec-core + |] + Right (_, c) <- readPackageConfig "package.yaml" + packageSourceRepository c `shouldBe` + Just (SourceRepository "https://github.com/hspec/hspec" (Just "hspec-core")) + + it "accepts CPP options" $ do + writeFile "package.yaml" [i| + cpp-options: -DFOO + library: + cpp-options: -DLIB + + executables: + foo: + main: Main.hs + cpp-options: -DFOO + + + tests: + spec: + main: Spec.hs + cpp-options: -DTEST + |] + Right (_, c) <- readPackageConfig "package.yaml" + c `shouldBe` package { + packageLibrary = Just library {libraryCppOptions = ["-DFOO", "-DLIB"]} + , packageExecutables = [(executable "foo" "Main.hs") {executableCppOptions = ["-DFOO", "-DFOO"]}] + , packageTests = [(executable "spec" "Spec.hs") {executableCppOptions = ["-DFOO", "-DTEST"]}] + } + + context "when reading library section" $ do + it "warns on unknown fields" $ do + writeFile "package.yaml" [i| + library: + bar: 23 + baz: 42 + |] + + fmap fst <$> readPackageConfig "package.yaml" `shouldReturn` Right [ + "Ignoring unknown field \"bar\" in library section" + , "Ignoring unknown field \"baz\" in library section" + ] + + it "accepts source-dirs" $ do + writeFile "package.yaml" [i| + library: + source-dirs: + - foo + - bar + |] + Right (_, c) <- readPackageConfig "package.yaml" + packageLibrary c `shouldBe` Just library {librarySourceDirs = ["foo", "bar"]} + + it "accepts default-extensions" $ do + writeFile "package.yaml" [i| + library: + default-extensions: + - Foo + - Bar + |] + Right (_, c) <- readPackageConfig "package.yaml" + packageLibrary c `shouldBe` Just library {libraryDefaultExtensions = ["Foo", "Bar"]} + + it "accepts global default-extensions" $ do + writeFile "package.yaml" [i| + default-extensions: + - Foo + - Bar + library: {} + |] + Right (_, c) <- readPackageConfig "package.yaml" + packageLibrary c `shouldBe` Just library {libraryDefaultExtensions = ["Foo", "Bar"]} + + it "accepts global source-dirs" $ do + writeFile "package.yaml" [i| + source-dirs: + - foo + - bar + library: {} + |] + Right (_, c) <- readPackageConfig "package.yaml" + packageLibrary c `shouldBe` Just library {librarySourceDirs = ["foo", "bar"]} + + it "allows to specify exposed-modules" $ do + writeFile "package.yaml" [i| + library: + source-dirs: src + exposed-modules: Foo + |] + touch "src/Foo.hs" + touch "src/Bar.hs" + Right (_, c) <- readPackageConfig "package.yaml" + packageLibrary c `shouldBe` Just library {librarySourceDirs = ["src"], libraryExposedModules = ["Foo"], libraryOtherModules = ["Bar"]} + + it "allows to specify other-modules" $ do + writeFile "package.yaml" [i| + library: + source-dirs: src + other-modules: Bar + |] + touch "src/Foo.hs" + touch "src/Bar.hs" + Right (_, c) <- readPackageConfig "package.yaml" + packageLibrary c `shouldBe` Just library {librarySourceDirs = ["src"], libraryExposedModules = ["Foo"], libraryOtherModules = ["Bar"]} + + it "allows to specify both exposed-modules and other-modules" $ do + writeFile "package.yaml" [i| + library: + source-dirs: src + exposed-modules: Foo + other-modules: Bar + |] + touch "src/Baz.hs" + Right (_, c) <- readPackageConfig "package.yaml" + packageLibrary c `shouldBe` Just library {librarySourceDirs = ["src"], libraryExposedModules = ["Foo"], libraryOtherModules = ["Bar"]} + + context "when neither exposed-module nor other-module are specified" $ do + it "exposes all modules" $ do + writeFile "package.yaml" [i| + library: + source-dirs: src + |] + touch "src/Foo.hs" + touch "src/Bar.hs" + Right (_, c) <- readPackageConfig "package.yaml" + packageLibrary c `shouldBe` Just library {librarySourceDirs = ["src"], libraryExposedModules = ["Bar", "Foo"]} + + context "when reading executable section" $ do + it "warns on unknown fields" $ do + writeFile "package.yaml" [i| + executables: + foo: + main: Main.hs + bar: 42 + baz: 23 + |] + + fmap fst <$> readPackageConfig "package.yaml" `shouldReturn` Right [ + "Ignoring unknown field \"bar\" in executable section \"foo\"" + , "Ignoring unknown field \"baz\" in executable section \"foo\"" + ] + + it "reads executable section" $ do + writeFile "package.yaml" [i| + executables: + foo: + main: driver/Main.hs + |] + Right (_, c) <- readPackageConfig "package.yaml" + packageExecutables c `shouldBe` [executable "foo" "driver/Main.hs"] + + it "accepts source-dirs" $ do + writeFile "package.yaml" [i| + executables: + foo: + main: Main.hs + source-dirs: + - foo + - bar + |] + Right (_, c) <- readPackageConfig "package.yaml" + packageExecutables c `shouldBe` [(executable "foo" "Main.hs") {executableSourceDirs = ["foo", "bar"]}] + + it "accepts global source-dirs" $ do + writeFile "package.yaml" [i| + source-dirs: + - foo + - bar + executables: + foo: + main: Main.hs + |] + Right (_, c) <- readPackageConfig "package.yaml" + packageExecutables c `shouldBe` [(executable "foo" "Main.hs") {executableSourceDirs = ["foo", "bar"]}] + + it "infers other-modules" $ do + touch "src/Main.hs" + touch "src/Foo.hs" + touch "src/Bar.hs" + touch "src/Baz.lhs" + writeFile "package.yaml" [i| + executables: + foo: + main: Main.hs + source-dirs: src + |] + Right (_, [r]) <- (fmap . fmap) packageExecutables <$> readPackageConfig "package.yaml" + executableOtherModules r `shouldBe` ["Bar", "Baz", "Foo"] + + it "allows to specify other-modules" $ do + touch "src/Foo.hs" + touch "src/Bar.hs" + writeFile "package.yaml" [i| + executables: + foo: + main: Main.hs + source-dirs: src + other-modules: Baz + |] + Right (_, [r]) <- (fmap . fmap) packageExecutables <$> readPackageConfig "package.yaml" + executableOtherModules r `shouldBe` ["Baz"] + + it "accepts default-extensions" $ do + writeFile "package.yaml" [i| + executables: + foo: + main: driver/Main.hs + default-extensions: + - Foo + - Bar + |] + Right (_, c) <- readPackageConfig "package.yaml" + packageExecutables c `shouldBe` [(executable "foo" "driver/Main.hs") {executableDefaultExtensions = ["Foo", "Bar"]}] + + it "accepts global default-extensions" $ do + writeFile "package.yaml" [i| + default-extensions: + - Foo + - Bar + executables: + foo: + main: driver/Main.hs + |] + Right (_, c) <- readPackageConfig "package.yaml" + packageExecutables c `shouldBe` [(executable "foo" "driver/Main.hs") {executableDefaultExtensions = ["Foo", "Bar"]}] + + it "accepts GHC options" $ do + writeFile "package.yaml" [i| + executables: + foo: + main: driver/Main.hs + ghc-options: -Wall + |] + Right (_, c) <- readPackageConfig "package.yaml" + c `shouldBe` package {packageExecutables = [(executable "foo" "driver/Main.hs") {executableGhcOptions = ["-Wall"]}]} + + it "accepts global GHC options" $ do + writeFile "package.yaml" [i| + ghc-options: -Wall + executables: + foo: + main: driver/Main.hs + |] + Right (_, c) <- readPackageConfig "package.yaml" + c `shouldBe` package {packageExecutables = [(executable "foo" "driver/Main.hs") {executableGhcOptions = ["-Wall"]}]} + + context "when reading test section" $ do + it "warns on unknown fields" $ do + writeFile "package.yaml" [i| + tests: + foo: + main: Main.hs + bar: 42 + baz: 23 + |] + + fmap fst <$> readPackageConfig "package.yaml" `shouldReturn` Right [ + "Ignoring unknown field \"bar\" in test section \"foo\"" + , "Ignoring unknown field \"baz\" in test section \"foo\"" + ] + + it "reads test section" $ do + writeFile "package.yaml" [i| + tests: + spec: + main: test/Spec.hs + |] + Right (_, c) <- readPackageConfig "package.yaml" + c `shouldBe` package {packageTests = [executable "spec" "test/Spec.hs"]} + + it "accepts single dependency" $ do + writeFile "package.yaml" [i| + tests: + spec: + main: test/Spec.hs + dependencies: hspec + |] + Right (_, c) <- readPackageConfig "package.yaml" + c `shouldBe` package {packageTests = [(executable "spec" "test/Spec.hs") {executableDependencies = [["hspec"]]}]} + + it "accepts list of dependencies" $ do + writeFile "package.yaml" [i| + tests: + spec: + main: test/Spec.hs + dependencies: + - hspec + - QuickCheck + |] + Right (_, c) <- readPackageConfig "package.yaml" + c `shouldBe` package {packageTests = [(executable "spec" "test/Spec.hs") {executableDependencies = [["hspec", "QuickCheck"]]}]} + + context "when both global and section specific dependencies are specified" $ do + it "combines dependencies" $ do + writeFile "package.yaml" [i| + dependencies: + - base + + tests: + spec: + main: test/Spec.hs + dependencies: hspec + |] + Right (_, c) <- readPackageConfig "package.yaml" + c `shouldBe` package {packageTests = [(executable "spec" "test/Spec.hs") {executableDependencies = [["base"], ["hspec"]]}]} + + context "when a specified source directory does not exist" $ do + it "warns" $ do + writeFile "package.yaml" [i| + source-dirs: + - some-dir + - some-existing-dir + library: + source-dirs: some-lib-dir + executables: + main: + main: Main.hs + source-dirs: some-exec-dir + tests: + spec: + main: Main.hs + source-dirs: some-test-dir + |] + touch "some-existing-dir/foo" + fmap fst <$> readPackageConfig "package.yaml" `shouldReturn` Right [ + "Specified source-dir \"some-dir\" does not exist" + , "Specified source-dir \"some-exec-dir\" does not exist" + , "Specified source-dir \"some-lib-dir\" does not exist" + , "Specified source-dir \"some-test-dir\" does not exist" + ] + + context "when package.yaml can not be parsed" $ do + it "returns an error" $ do + writeFile "package.yaml" [i| + foo: bar + foo baz + |] + readPackageConfig "package.yaml" `shouldReturn` Left "package.yaml:3:10: could not find expected ':' while scanning a simple key" + + context "when package.yaml is invalid" $ do + it "returns an error" $ do + writeFile "package.yaml" [i| + executables: + foo: + ain: driver/Main.hs + |] + readPackageConfig "package.yaml" `shouldReturn` Left "package.yaml: The key \"main\" was not found" + + context "when package.yaml does not exist" $ do + it "returns an error" $ + readPackageConfig "package.yaml" `shouldReturn` Left "package.yaml: Yaml file not found: package.yaml" diff --git a/test/Hpack/RunSpec.hs b/test/Hpack/RunSpec.hs new file mode 100644 --- /dev/null +++ b/test/Hpack/RunSpec.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE OverloadedStrings #-} +module Hpack.RunSpec (main, spec) where + +import Test.Hspec + +import Hpack.ConfigSpec hiding (main, spec) +import Hpack.Config +import Hpack.Run + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "renderPackage" $ do + it "renders a package" $ do + renderPackage 0 [] package `shouldBe` unlines [ + "name: foo" + , "version: 0.0.0" + , "build-type: Simple" + , "cabal-version: >= 1.10" + ] + + it "aligns fields" $ do + renderPackage 16 [] package `shouldBe` unlines [ + "name: foo" + , "version: 0.0.0" + , "build-type: Simple" + , "cabal-version: >= 1.10" + ] + + it "includes description" $ do + renderPackage 0 [] package {packageDescription = Just "foo\nbar\n"} `shouldBe` unlines [ + "name: foo" + , "version: 0.0.0" + , "description: foo" + , " ." + , " bar" + , "build-type: Simple" + , "cabal-version: >= 1.10" + ] + + it "aligns description" $ do + renderPackage 16 [] package {packageDescription = Just "foo\nbar\n"} `shouldBe` unlines [ + "name: foo" + , "version: 0.0.0" + , "description: foo" + , " ." + , " bar" + , "build-type: Simple" + , "cabal-version: >= 1.10" + ] + + it "includes stability" $ do + renderPackage 0 [] package {packageStability = Just "experimental"} `shouldBe` unlines [ + "name: foo" + , "version: 0.0.0" + , "stability: experimental" + , "build-type: Simple" + , "cabal-version: >= 1.10" + ] + + it "includes copyright holder" $ do + renderPackage 0 [] package {packageCopyright = ["(c) 2015 Simon Hengel"]} `shouldBe` unlines [ + "name: foo" + , "version: 0.0.0" + , "copyright: (c) 2015 Simon Hengel" + , "build-type: Simple" + , "cabal-version: >= 1.10" + ] + + it "aligns copyright holders" $ do + renderPackage 16 [] package {packageCopyright = ["(c) 2015 Foo", "(c) 2015 Bar"]} `shouldBe` unlines [ + "name: foo" + , "version: 0.0.0" + , "copyright: (c) 2015 Foo," + , " (c) 2015 Bar" + , "build-type: Simple" + , "cabal-version: >= 1.10" + ] + + it "includes extra-source-files" $ do + renderPackage 0 [] package {packageExtraSourceFiles = ["foo", "bar"]} `shouldBe` unlines [ + "name: foo" + , "version: 0.0.0" + , "build-type: Simple" + , "cabal-version: >= 1.10" + , "" + , "extra-source-files:" + , " foo" + , " bar" + ] + + context "when given list of existing fields" $ do + it "retains field order" $ do + renderPackage 16 ["cabal-version", "version", "name", "build-type"] package `shouldBe` unlines [ + "cabal-version: >= 1.10" + , "version: 0.0.0" + , "name: foo" + , "build-type: Simple" + ] + + it "uses default field order for new fields" $ do + renderPackage 16 ["name", "version", "cabal-version"] package `shouldBe` unlines [ + "name: foo" + , "version: 0.0.0" + , "build-type: Simple" + , "cabal-version: >= 1.10" + ] + + context "when rendering executable section" $ do + it "includes dependencies" $ do + renderPackage 0 [] package {packageExecutables = [(executable "foo" "Main.hs") {executableDependencies = [["foo", "bar"], ["foo", "baz"]]}]} `shouldBe` unlines [ + "name: foo" + , "version: 0.0.0" + , "build-type: Simple" + , "cabal-version: >= 1.10" + , "" + , "executable foo" + , " main-is: Main.hs" + , " build-depends:" + , " foo" + , " , bar" + , "" + , " , foo" + , " , baz" + , " default-language: Haskell2010" + ] + + it "includes GHC options" $ do + renderPackage 0 [] package {packageExecutables = [(executable "foo" "Main.hs") {executableGhcOptions = ["-Wall", "-Werror"]}]} `shouldBe` unlines [ + "name: foo" + , "version: 0.0.0" + , "build-type: Simple" + , "cabal-version: >= 1.10" + , "" + , "executable foo" + , " main-is: Main.hs" + , " ghc-options: -Wall -Werror" + , " default-language: Haskell2010" + ] + + describe "renderSourceRepository" $ do + it "renders source-repository without subdir correctly" $ do + renderSourceRepository (SourceRepository "https://github.com/hspec/hspec" Nothing) + `shouldBe` unlines [ + "source-repository head" + , " type: git" + , " location: https://github.com/hspec/hspec" + ] + + it "renders source-repository with subdir" $ do + renderSourceRepository (SourceRepository "https://github.com/hspec/hspec" (Just "hspec-core")) + `shouldBe` unlines [ + "source-repository head" + , " type: git" + , " location: https://github.com/hspec/hspec" + , " subdir: hspec-core" + ] diff --git a/test/Hpack/UtilSpec.hs b/test/Hpack/UtilSpec.hs new file mode 100644 --- /dev/null +++ b/test/Hpack/UtilSpec.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE OverloadedStrings #-} +module Hpack.UtilSpec (main, spec) where + +import Helper +import Data.Aeson + +import Hpack.Util + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "toModule" $ do + it "maps paths to module names" $ do + toModule ["Foo", "Bar", "Baz.hs"] `shouldBe` Just "Foo.Bar.Baz" + + it "rejects invalid module names" $ do + toModule ["resources", "hello.hs"] `shouldBe` Nothing + + describe "getFilesRecursive" $ do + it "gets all files from given directory and all its subdirectories" $ do + inTempDirectoryNamed "test" $ do + touch "foo/bar" + touch "foo/baz" + touch "foo/foobar/baz" + getFilesRecursive "foo" `shouldReturn` [ + ["bar"] + , ["baz"] + , ["foobar", "baz"] + ] + + describe "List" $ do + it "can be a single value" $ do + fromJSON (toJSON $ Number 23) `shouldBe` Success (List [23 :: Int]) + + it "can be a list of values" $ do + fromJSON (toJSON [Number 23, Number 42]) `shouldBe` Success (List [23, 42 :: Int]) + + describe "tryReadFile" $ do + it "reads file" $ do + inTempDirectory $ do + writeFile "foo" "bar" + tryReadFile "foo" `shouldReturn` Just "bar" + + it "returns Nothing if file does not exist" $ do + inTempDirectory $ do + tryReadFile "foo" `shouldReturn` Nothing + + describe "extractFieldOrderHint" $ do + it "extracts field order hints" $ do + let input = unlines [ + "name: cabalize" + , "version: 0.0.0" + , "license:" + , "license-file: " + , "build-type: Simple" + , "cabal-version: >= 1.10" + ] + extractFieldOrderHint input `shouldBe` [ + "name" + , "version" + , "license" + , "license-file" + , "build-type" + , "cabal-version" + ] + + describe "sniffAlignment" $ do + it "sniffs field alignment from given cabal file" $ do + let input = unlines [ + "name: cabalize" + , "version: 0.0.0" + , "license: MIT" + , "license-file: LICENSE" + , "build-type: Simple" + , "cabal-version: >= 1.10" + ] + sniffAlignment input `shouldBe` Just 16 + + it "ignores fields without a value on the same line" $ do + let input = unlines [ + "name: cabalize" + , "version: 0.0.0" + , "description: " + , " foo" + , " bar" + ] + sniffAlignment input `shouldBe` Just 16 + + describe "splitField" $ do + it "splits fields" $ do + splitField "foo: bar" `shouldBe` Just ("foo", " bar") + + it "accepts fields names with dashes" $ do + splitField "foo-bar: baz" `shouldBe` Just ("foo-bar", " baz") + + it "rejects fields names with spaces" $ do + splitField "foo bar: baz" `shouldBe` Nothing + + it "rejects invalid fields" $ do + splitField "foo bar" `shouldBe` Nothing diff --git a/test/RunSpec.hs b/test/RunSpec.hs deleted file mode 100644 --- a/test/RunSpec.hs +++ /dev/null @@ -1,152 +0,0 @@ -module RunSpec (main, spec) where - -import Test.Hspec - -import ConfigSpec hiding (main, spec) -import Config -import Run - -main :: IO () -main = hspec spec - -spec :: Spec -spec = do - describe "renderPackage" $ do - it "renders a package" $ do - renderPackage 0 [] package `shouldBe` unlines [ - "name: foo" - , "version: 0.0.0" - , "build-type: Simple" - , "cabal-version: >= 1.10" - ] - - it "aligns fields" $ do - renderPackage 16 [] package `shouldBe` unlines [ - "name: foo" - , "version: 0.0.0" - , "build-type: Simple" - , "cabal-version: >= 1.10" - ] - - it "includes description" $ do - renderPackage 0 [] package {packageDescription = Just "foo\nbar\n"} `shouldBe` unlines [ - "name: foo" - , "version: 0.0.0" - , "description: foo" - , " ." - , " bar" - , "build-type: Simple" - , "cabal-version: >= 1.10" - ] - - it "aligns description" $ do - renderPackage 16 [] package {packageDescription = Just "foo\nbar\n"} `shouldBe` unlines [ - "name: foo" - , "version: 0.0.0" - , "description: foo" - , " ." - , " bar" - , "build-type: Simple" - , "cabal-version: >= 1.10" - ] - - it "includes stability" $ do - renderPackage 0 [] package {packageStability = Just "experimental"} `shouldBe` unlines [ - "name: foo" - , "version: 0.0.0" - , "stability: experimental" - , "build-type: Simple" - , "cabal-version: >= 1.10" - ] - - it "includes copyright holder" $ do - renderPackage 0 [] package {packageCopyright = ["(c) 2015 Simon Hengel"]} `shouldBe` unlines [ - "name: foo" - , "version: 0.0.0" - , "copyright: (c) 2015 Simon Hengel" - , "build-type: Simple" - , "cabal-version: >= 1.10" - ] - - it "aligns copyright holders" $ do - renderPackage 16 [] package {packageCopyright = ["(c) 2015 Foo", "(c) 2015 Bar"]} `shouldBe` unlines [ - "name: foo" - , "version: 0.0.0" - , "copyright: (c) 2015 Foo," - , " (c) 2015 Bar" - , "build-type: Simple" - , "cabal-version: >= 1.10" - ] - - it "includes extra-source-files" $ do - renderPackage 0 [] package {packageExtraSourceFiles = ["foo", "bar"]} `shouldBe` unlines [ - "name: foo" - , "version: 0.0.0" - , "build-type: Simple" - , "cabal-version: >= 1.10" - , "" - , "extra-source-files:" - , " foo" - , " bar" - ] - - it "includes source repository" $ do - renderPackage 0 [] package {packageSourceRepository = Just "https://github.com/hspec/hspec"} `shouldBe` unlines [ - "name: foo" - , "version: 0.0.0" - , "build-type: Simple" - , "cabal-version: >= 1.10" - , "" - , "source-repository head" - , " type: git" - , " location: https://github.com/hspec/hspec" - ] - - context "when given list of existing fields" $ do - it "retains field order" $ do - renderPackage 16 ["cabal-version", "version", "name", "build-type"] package `shouldBe` unlines [ - "cabal-version: >= 1.10" - , "version: 0.0.0" - , "name: foo" - , "build-type: Simple" - ] - - it "uses default field order for new fields" $ do - renderPackage 16 ["name", "version", "cabal-version"] package `shouldBe` unlines [ - "name: foo" - , "version: 0.0.0" - , "build-type: Simple" - , "cabal-version: >= 1.10" - ] - - context "when rendering executable section" $ do - it "includes dependencies" $ do - renderPackage 0 [] package {packageExecutables = [(executable "foo" "Main.hs") {executableDependencies = [["foo", "bar"], ["foo", "baz"]]}]} `shouldBe` unlines [ - "name: foo" - , "version: 0.0.0" - , "build-type: Simple" - , "cabal-version: >= 1.10" - , "" - , "executable foo" - , " main-is: Main.hs" - , " build-depends:" - , " foo" - , " , bar" - , "" - , " , foo" - , " , baz" - , " default-language: Haskell2010" - ] - - it "includes GHC options" $ do - renderPackage 0 [] package {packageExecutables = [(executable "foo" "Main.hs") {executableGhcOptions = ["-Wall", "-Werror"]}]} `shouldBe` unlines [ - "name: foo" - , "version: 0.0.0" - , "build-type: Simple" - , "cabal-version: >= 1.10" - , "" - , "executable foo" - , " main-is: Main.hs" - , " ghc-options: -Wall -Werror" - , " default-language: Haskell2010" - ] diff --git a/test/UtilSpec.hs b/test/UtilSpec.hs deleted file mode 100644 --- a/test/UtilSpec.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module UtilSpec (main, spec) where - -import Helper -import Data.Aeson - -import Util - -main :: IO () -main = hspec spec - -spec :: Spec -spec = do - describe "toModule" $ do - it "maps paths to module names" $ do - toModule ["Foo", "Bar", "Baz.hs"] `shouldBe` Just "Foo.Bar.Baz" - - it "rejects invalid module names" $ do - toModule ["resources", "hello.hs"] `shouldBe` Nothing - - describe "getFilesRecursive" $ do - it "gets all files from given directory and all its subdirectories" $ do - inTempDirectoryNamed "test" $ do - touch "foo/bar" - touch "foo/baz" - touch "foo/foobar/baz" - getFilesRecursive "foo" `shouldReturn` [ - ["bar"] - , ["baz"] - , ["foobar", "baz"] - ] - - describe "List" $ do - it "can be a single value" $ do - fromJSON (toJSON $ Number 23) `shouldBe` Success (List [23 :: Int]) - - it "can be a list of values" $ do - fromJSON (toJSON [Number 23, Number 42]) `shouldBe` Success (List [23, 42 :: Int]) - - describe "tryReadFile" $ do - it "reads file" $ do - inTempDirectory $ do - writeFile "foo" "bar" - tryReadFile "foo" `shouldReturn` Just "bar" - - it "returns Nothing if file does not exist" $ do - inTempDirectory $ do - tryReadFile "foo" `shouldReturn` Nothing - - describe "extractFieldOrderHint" $ do - it "extracts field order hints" $ do - let input = unlines [ - "name: cabalize" - , "version: 0.0.0" - , "license:" - , "license-file: " - , "build-type: Simple" - , "cabal-version: >= 1.10" - ] - extractFieldOrderHint input `shouldBe` [ - "name" - , "version" - , "license" - , "license-file" - , "build-type" - , "cabal-version" - ] - - describe "sniffAlignment" $ do - it "sniffs field alignment from given cabal file" $ do - let input = unlines [ - "name: cabalize" - , "version: 0.0.0" - , "license: MIT" - , "license-file: LICENSE" - , "build-type: Simple" - , "cabal-version: >= 1.10" - ] - sniffAlignment input `shouldBe` Just 16 - - it "ignores fields without a value on the same line" $ do - let input = unlines [ - "name: cabalize" - , "version: 0.0.0" - , "description: " - , " foo" - , " bar" - ] - sniffAlignment input `shouldBe` Just 16 - - describe "splitField" $ do - it "splits fields" $ do - splitField "foo: bar" `shouldBe` Just ("foo", " bar") - - it "accepts fields names with dashes" $ do - splitField "foo-bar: baz" `shouldBe` Just ("foo-bar", " baz") - - it "rejects fields names with spaces" $ do - splitField "foo bar: baz" `shouldBe` Nothing - - it "rejects invalid fields" $ do - splitField "foo bar" `shouldBe` Nothing