diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2014 Simon Hengel + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/driver/Main.hs b/driver/Main.hs new file mode 100644 --- /dev/null +++ b/driver/Main.hs @@ -0,0 +1,16 @@ +module Main (main) where + +import Prelude () +import Prelude.Compat +import Control.Monad +import Control.DeepSeq +import Control.Exception +import System.IO.Error + +import Run + +main :: IO () +main = do + (name, new) <- run + old <- force . either (const Nothing) Just <$> tryJust (guard . isDoesNotExistError) (readFile name) + unless (old == Just new) (writeFile name new) diff --git a/hpack.cabal b/hpack.cabal new file mode 100644 --- /dev/null +++ b/hpack.cabal @@ -0,0 +1,60 @@ +-- This file has been generated from package.yaml by hpack version 0.1.0. +-- +-- see: https://github.com/sol/hpack + +name: hpack +version: 0.1.0 +synopsis: An alternative format for Haskell packages +homepage: https://github.com/sol/hpack#readme +bug-reports: https://github.com/sol/hpack/issues +license: MIT +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +source-repository head + type: git + location: https://github.com/sol/hpack + +executable hpack + hs-source-dirs: driver, src + main-is: Main.hs + build-depends: + aeson >= 0.8 + , base == 4.* + , base-compat >= 0.8 + , deepseq + , directory + , filepath + , unordered-containers + , yaml + ghc-options: -Wall + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + hs-source-dirs: test, src + main-is: Spec.hs + other-modules: + ConfigSpec + Helper + RunSpec + UtilSpec + Config + Run + Util + build-depends: + aeson >= 0.8 + , base == 4.* + , base-compat >= 0.8 + , deepseq + , directory + , filepath + , unordered-containers + , yaml + + , hspec == 2.* + , mockery + , interpolate + ghc-options: -Wall + default-language: Haskell2010 diff --git a/src/Config.hs b/src/Config.hs new file mode 100644 --- /dev/null +++ b/src/Config.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE DeriveGeneric, RecordWildCards #-} +module Config ( + readPackageConfig +, Package(..) +, Dependency +, GhcOption +, Library(..) +, Executable(..) +) where + +import Prelude () +import Prelude.Compat +import Control.Applicative +import Control.Monad.Compat +import Data.List ((\\)) +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 System.FilePath +import System.Directory + +import Util + +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) +} deriving (Eq, Show, Generic) + +instance FromJSON LibrarySection where + parseJSON = genericParseJSON_ "LibrarySection" + +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) +} deriving (Eq, Show, Generic) + +instance FromJSON ExecutableSection where + parseJSON = genericParseJSON_ "ExecutableSection" + +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) +, packageConfigLibrary :: Maybe LibrarySection +, packageConfigExecutables :: Maybe (HashMap String ExecutableSection) +, packageConfigTests :: Maybe (HashMap String ExecutableSection) +} deriving (Eq, Show, Generic) + +instance FromJSON PackageConfig where + parseJSON value = handleNullValues <$> genericParseJSON_ "PackageConfig" 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 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 e) -> let loc = yamlProblemMark e in ":" ++ show (yamlLine loc) ++ ":" ++ show (yamlColumn loc) ++ ": " ++ yamlProblem e ++ " " ++ yamlContext e + _ -> ": " ++ show err + +type Dependency = String +type GhcOption = 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] +} deriving (Eq, Show) + +data Executable = Executable { + executableName :: String +, executableMain :: FilePath +, executableSourceDirs :: [FilePath] +, executableOtherModules :: [String] +, executableDependencies :: [[Dependency]] +, executableDefaultExtensions :: [String] +, executableGhcOptions :: [GhcOption] +} deriving (Eq, Show) + +mkPackage :: PackageConfig -> IO Package +mkPackage PackageConfig{..} = do + let dependencies = fromMaybeList packageConfigDependencies + let sourceDirs = fromMaybeList packageConfigSourceDirs + let defaultExtensions = fromMaybeList packageConfigDefaultExtensions + let ghcOptions = fromMaybeList packageConfigGhcOptions + mLibrary <- mapM (mkLibrary sourceDirs dependencies defaultExtensions ghcOptions) packageConfigLibrary + executables <- toExecutables sourceDirs dependencies defaultExtensions ghcOptions packageConfigExecutables + tests <- toExecutables sourceDirs dependencies defaultExtensions ghcOptions packageConfigTests + + name <- maybe (takeBaseName <$> getCurrentDirectory) return packageConfigName + + licenseFileExists <- doesFileExist "LICENSE" + + 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 + } + return package + where + 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) + +mkLibrary :: [FilePath] -> [Dependency] -> [String] -> [GhcOption] -> LibrarySection -> IO Library +mkLibrary globalSourceDirs globalDependencies globalDefaultExtensions globalGhcOptions LibrarySection{..} = do + modules <- concat <$> mapM getModules sourceDirs + + let (exposedModules, otherModules) = determineModules modules librarySectionExposedModules librarySectionOtherModules + + return (Library sourceDirs exposedModules otherModules dependencies defaultExtensions ghcOptions) + where + sourceDirs = globalSourceDirs ++ fromMaybeList librarySectionSourceDirs + dependencies = filter (not . null) [globalDependencies, fromMaybeList librarySectionDependencies] + defaultExtensions = globalDefaultExtensions ++ fromMaybeList librarySectionDefaultExtensions + ghcOptions = globalGhcOptions ++ fromMaybeList librarySectionGhcOptions + +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] -> Maybe (HashMap String ExecutableSection) -> IO [Executable] +toExecutables globalSourceDirs globalDependencies globalDefaultExtensions globalGhcOptions 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 + where + dependencies = filter (not . null) [globalDependencies, fromMaybeList executableSectionDependencies] + sourceDirs = globalSourceDirs ++ fromMaybeList executableSectionSourceDirs + defaultExtensions = globalDefaultExtensions ++ fromMaybeList executableSectionDefaultExtensions + ghcOptions = globalGhcOptions ++ fromMaybeList executableSectionGhcOptions + + filterMain :: [String] -> [String] + filterMain = maybe id (filter . (/=)) (toModule $ splitDirectories executableSectionMain) + +fromMaybeList :: Maybe (List a) -> [a] +fromMaybeList = maybe [] fromList diff --git a/src/Run.hs b/src/Run.hs new file mode 100644 --- /dev/null +++ b/src/Run.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE QuasiQuotes, RecordWildCards #-} +module Run ( + run +-- exported for testing +, renderPackage +) where + +import Control.Applicative +import Control.Monad +import Data.Maybe +import Data.List +import System.Exit.Compat +import Data.Version (showVersion) + +import Paths_hpack (version) +import Util +import Config + +configFile :: FilePath +configFile = "package.yaml" + +run :: IO (FilePath, String) +run = do + mPackage <- readPackageConfig configFile + case mPackage of + Right package -> do + let cabalFile = packageName package ++ ".cabal" + + old <- tryReadFile cabalFile + + let alignment = fromMaybe 16 (old >>= sniffAlignment) + output = concat [ + "-- This file has been generated from " ++ configFile ++ " by hpack version " ++ showVersion version ++ ".\n" + , "--\n" + , "-- see: https://github.com/sol/hpack\n" + , "\n" + , renderPackage alignment (maybe [] extractFieldOrderHint old) package + ] + return (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 + ++ " default-language: Haskell2010\n" + +renderLibrary :: Library -> String +renderLibrary Library{..} = + "library\n" + ++ renderSourceDirs librarySourceDirs + ++ renderExposedModules libraryExposedModules + ++ renderOtherModules libraryOtherModules + ++ renderDependencies libraryDependencies + ++ renderDefaultExtensions libraryDefaultExtensions + ++ renderGhcOptions libraryGhcOptions + ++ " 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 ghcOptions + | null ghcOptions = "" + | otherwise = " ghc-options: " ++ unwords ghcOptions ++ "\n" + +renderDefaultExtensions :: [String] -> String +renderDefaultExtensions defaultExtensions + | null defaultExtensions = "" + | otherwise = " default-extensions: " ++ unwords defaultExtensions ++ "\n" diff --git a/src/Util.hs b/src/Util.hs new file mode 100644 --- /dev/null +++ b/src/Util.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE FlexibleContexts #-} +module Util ( + List(..) +, toModule +, genericParseJSON_ +, 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 GHC.Generics +import Data.Aeson.Types + +genericParseJSON_ :: (Generic a, GFromJSON (Rep a)) => String -> Value -> Parser a +genericParseJSON_ name = genericParseJSON defaultOptions {fieldLabelModifier = camelTo '-' . drop (length name)} + +newtype List a = List {fromList :: [a]} + deriving (Eq, Show) + +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 new file mode 100644 --- /dev/null +++ b/test/ConfigSpec.hs @@ -0,0 +1,408 @@ +{-# LANGUAGE QuasiQuotes, OverloadedLists #-} +module ConfigSpec ( + main +, spec + +, package +, executable +, library +) where + +import Helper +import Test.Mockery.Directory + +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 "accepts name" $ do + writeFile "package.yaml" [i| + name: bar + |] + readPackageConfig "package.yaml" `shouldReturn` Right package {packageName = "bar"} + + it "accepts version" $ do + writeFile "package.yaml" [i| + version: 0.1.0 + |] + readPackageConfig "package.yaml" `shouldReturn` Right package {packageVersion = "0.1.0"} + + it "accepts synopsis" $ do + writeFile "package.yaml" [i| + synopsis: some synopsis + |] + readPackageConfig "package.yaml" `shouldReturn` Right package {packageSynopsis = Just "some synopsis"} + + it "accepts description" $ do + writeFile "package.yaml" [i| + description: some description + |] + readPackageConfig "package.yaml" `shouldReturn` Right package {packageDescription = Just "some description"} + + it "accepts category" $ do + writeFile "package.yaml" [i| + category: Data + |] + readPackageConfig "package.yaml" `shouldReturn` Right package {packageCategory = Just "Data"} + + it "accepts author" $ do + writeFile "package.yaml" [i| + author: John Doe + |] + readPackageConfig "package.yaml" `shouldReturn` Right package {packageAuthor = ["John Doe"]} + + it "accepts maintainer" $ do + writeFile "package.yaml" [i| + maintainer: John Doe + |] + readPackageConfig "package.yaml" `shouldReturn` Right package {packageMaintainer = ["John Doe "]} + + it "accepts copyright" $ do + writeFile "package.yaml" [i| + copyright: (c) 2015 John Doe + |] + readPackageConfig "package.yaml" `shouldReturn` Right 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 + |] + readPackageConfig "package.yaml" `shouldReturn` Right package {packageLicense = Just "MIT"} + + it "infers license file" $ do + writeFile "package.yaml" [i| + name: foo + |] + touch "LICENSE" + readPackageConfig "package.yaml" `shouldReturn` Right 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 "https://github.com/hspec/hspec" + + context "when reading library section" $ do + 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 "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 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 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 + |] + readPackageConfig "package.yaml" `shouldReturn` Right 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 + |] + readPackageConfig "package.yaml" `shouldReturn` Right package {packageExecutables = [(executable "foo" "driver/Main.hs") {executableGhcOptions = ["-Wall"]}]} + + context "when reading test section" $ do + it "reads test section" $ do + writeFile "package.yaml" [i| + tests: + spec: + main: test/Spec.hs + |] + readPackageConfig "package.yaml" `shouldReturn` Right package {packageTests = [executable "spec" "test/Spec.hs"]} + + it "accepts single dependency" $ do + writeFile "package.yaml" [i| + tests: + spec: + main: test/Spec.hs + dependencies: hspec + |] + readPackageConfig "package.yaml" `shouldReturn` Right 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 + |] + readPackageConfig "package.yaml" `shouldReturn` Right package {packageTests = [(executable "spec" "test/Spec.hs") {executableDependencies = [["hspec", "QuickCheck"]]}]} + + context "when both top-level 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 + |] + readPackageConfig "package.yaml" `shouldReturn` Right package {packageTests = [(executable "spec" "test/Spec.hs") {executableDependencies = [["base"], ["hspec"]]}]} + + 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" diff --git a/test/Helper.hs b/test/Helper.hs new file mode 100644 --- /dev/null +++ b/test/Helper.hs @@ -0,0 +1,15 @@ +module Helper ( + module Test.Hspec +, module Control.Applicative +, touch +) where + +import Test.Hspec +import Control.Applicative +import System.Directory +import System.FilePath + +touch :: FilePath -> IO () +touch p = do + createDirectoryIfMissing True (takeDirectory p) + writeFile p "" diff --git a/test/RunSpec.hs b/test/RunSpec.hs new file mode 100644 --- /dev/null +++ b/test/RunSpec.hs @@ -0,0 +1,152 @@ +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/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/UtilSpec.hs b/test/UtilSpec.hs new file mode 100644 --- /dev/null +++ b/test/UtilSpec.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE OverloadedStrings #-} +module UtilSpec (main, spec) where + +import Helper +import Test.Mockery.Directory +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 + tryReadFile "test/asset/foo" `shouldReturn` Just "foo\n" + + it "returns Nothing if file does not exist" $ do + tryReadFile "test/asset/bar" `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