diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2014 Simon Hengel +Copyright (c) 2014-2016 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 diff --git a/hpack.cabal b/hpack.cabal --- a/hpack.cabal +++ b/hpack.cabal @@ -1,9 +1,9 @@ --- This file has been generated from package.yaml by hpack version 0.11.0. +-- This file has been generated from package.yaml by hpack version 0.11.2. -- -- see: https://github.com/sol/hpack name: hpack -version: 0.11.2 +version: 0.12.0 synopsis: An alternative format for Haskell packages category: Development homepage: https://github.com/sol/hpack#readme @@ -40,6 +40,7 @@ Hpack.Run Hpack.Yaml other-modules: + Hpack.FormattingHints Hpack.GenericsUtil Hpack.Haskell Hpack.Render @@ -87,6 +88,7 @@ , unordered-containers , yaml , hspec == 2.* + , QuickCheck , temporary , mockery >= 0.3 , interpolate @@ -95,6 +97,7 @@ other-modules: Helper Hpack.ConfigSpec + Hpack.FormattingHintsSpec Hpack.GenericsUtilSpec Hpack.HaskellSpec Hpack.RenderSpec @@ -103,6 +106,7 @@ HpackSpec Hpack Hpack.Config + Hpack.FormattingHints Hpack.GenericsUtil Hpack.Haskell Hpack.Render diff --git a/src/Hpack.hs b/src/Hpack.hs --- a/src/Hpack.hs +++ b/src/Hpack.hs @@ -4,7 +4,10 @@ , version , main #ifdef TEST +, hpackWithVersion , parseVerbosity +, extractVersion +, parseVersion #endif ) where @@ -15,22 +18,25 @@ import Control.Exception import Control.Monad.Compat import Data.List.Compat -import Data.Version (showVersion) +import Data.Maybe +import Data.Version (Version) +import qualified Data.Version as Version import System.Environment import System.Exit import System.IO import System.IO.Error +import Text.ParserCombinators.ReadP import Paths_hpack (version) import Hpack.Config import Hpack.Run -programVersion :: String -programVersion = "hpack version " ++ showVersion version +programVersion :: Version -> String +programVersion v = "hpack version " ++ Version.showVersion v -header :: String -header = unlines [ - "-- This file has been generated from " ++ packageConfig ++ " by " ++ programVersion ++ "." +header :: Version -> String +header v = unlines [ + "-- This file has been generated from " ++ packageConfig ++ " by " ++ programVersion v ++ "." , "--" , "-- see: https://github.com/sol/hpack" , "" @@ -40,11 +46,11 @@ main = do args <- getArgs case args of - ["--version"] -> putStrLn programVersion + ["--version"] -> putStrLn (programVersion version) ["--help"] -> printHelp _ -> case parseVerbosity args of (verbose, [dir]) -> hpack dir verbose - (verbose, []) -> hpack "." verbose + (verbose, []) -> hpack "" verbose _ -> do printHelp exitFailure @@ -63,19 +69,42 @@ verbose = not (silentFlag `elem` xs) ys = filter (/= silentFlag) xs +safeInit :: [a] -> [a] +safeInit [] = [] +safeInit xs = init xs + +extractVersion :: [String] -> Maybe Version +extractVersion = listToMaybe . mapMaybe (stripPrefix prefix >=> parseVersion . safeInit) + where + prefix = "-- This file has been generated from package.yaml by hpack version " + +parseVersion :: String -> Maybe Version +parseVersion xs = case [v | (v, "") <- readP_to_S Version.parseVersion xs] of + [v] -> Just v + _ -> Nothing + hpack :: FilePath -> Bool -> IO () -hpack dir verbose = do +hpack = hpackWithVersion version + +hpackWithVersion :: Version -> FilePath -> Bool -> IO () +hpackWithVersion v dir verbose = do (warnings, name, new) <- run dir forM_ warnings $ \warning -> hPutStrLn stderr ("WARNING: " ++ warning) - old <- force . either (const Nothing) (Just . stripHeader) <$> tryJust (guard . isDoesNotExistError) (readFile name) - if (old == Just (lines new)) then do - output (name ++ " is up-to-date") + + old <- either (const Nothing) (Just . splitHeader) <$> tryJust (guard . isDoesNotExistError) (readFile name >>= (return $!!)) + let oldVersion = fmap fst old >>= extractVersion + + if (oldVersion <= Just v) then do + if (fmap snd old == Just (lines new)) then do + output (name ++ " is up-to-date") + else do + (writeFile name $ header v ++ new) + output ("generated " ++ name) else do - (writeFile name $ header ++ new) - output ("generated " ++ name) + output (name ++ " was generated with a newer version of hpack, please upgrade and try again.") where - stripHeader :: String -> [String] - stripHeader = dropWhile null . dropWhile ("--" `isPrefixOf`) . lines + splitHeader :: String -> ([String], [String]) + splitHeader = fmap (dropWhile null) . span ("--" `isPrefixOf`) . lines output :: String -> IO () output message diff --git a/src/Hpack/Config.hs b/src/Hpack/Config.hs --- a/src/Hpack/Config.hs +++ b/src/Hpack/Config.hs @@ -46,7 +46,7 @@ import Data.Map.Lazy (Map) import qualified Data.Map.Lazy as Map import qualified Data.HashMap.Lazy as HashMap -import Data.List (nub, (\\), sortBy) +import Data.List.Compat (nub, (\\), sortBy) import Data.Maybe import Data.Ord import Data.String @@ -313,12 +313,12 @@ name :: Parser String name = o .: "name" - git :: Parser AddSource - git = GitRef <$> url <*> ref - local :: Parser AddSource local = Local <$> o .: "path" + git :: Parser AddSource + git = GitRef <$> url <*> ref <*> subdir + url :: Parser String url = ((githubBaseUrl ++) <$> o .: "github") @@ -328,7 +328,10 @@ ref :: Parser String ref = o .: "ref" -data AddSource = GitRef GitUrl GitRef | Local FilePath + subdir :: Parser (Maybe FilePath) + subdir = o .:? "subdir" + +data AddSource = GitRef GitUrl GitRef (Maybe FilePath) | Local FilePath deriving (Eq, Show, Ord) type GitUrl = String diff --git a/src/Hpack/FormattingHints.hs b/src/Hpack/FormattingHints.hs new file mode 100644 --- /dev/null +++ b/src/Hpack/FormattingHints.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} +module Hpack.FormattingHints ( + FormattingHints (..) +, sniffFormattingHints +#ifdef TEST +, extractFieldOrder +, extractSectionsFieldOrder +, breakLines +, unindent +, sniffAlignment +, splitField +, sniffIndentation +, sniffCommaStyle +#endif +) where + +import Prelude () +import Prelude.Compat + +import Data.Char +import Data.Maybe +import Data.List.Compat +import Control.Applicative + +import Hpack.Render +-- import Hpack.Util + +data FormattingHints = FormattingHints { + formattingHintsFieldOrder :: [String] +, formattingHintsSectionsFieldOrder :: [(String, [String])] +, formattingHintsAlignment :: Maybe Alignment +, formattingHintsRenderSettings :: RenderSettings +} deriving (Eq, Show) + +sniffFormattingHints :: String -> FormattingHints +sniffFormattingHints (breakLines -> input) = FormattingHints { + formattingHintsFieldOrder = extractFieldOrder input +, formattingHintsSectionsFieldOrder = extractSectionsFieldOrder input +, formattingHintsAlignment = sniffAlignment input +, formattingHintsRenderSettings = sniffRenderSettings input +} + +breakLines :: String -> [String] +breakLines = filter (not . null) . map (reverse . dropWhile isSpace . reverse) . lines + +extractFieldOrder :: [String] -> [String] +extractFieldOrder = map fst . catMaybes . map splitField + +extractSectionsFieldOrder :: [String] -> [(String, [String])] +extractSectionsFieldOrder = map (fmap extractFieldOrder) . splitSections + where + splitSections input = case break startsWithSpace input of + ([], []) -> [] + (xs, ys) -> case span startsWithSpace ys of + (fields, zs) -> case reverse xs of + name : _ -> (name, unindent fields) : splitSections zs + _ -> splitSections zs + + startsWithSpace :: String -> Bool + startsWithSpace xs = case xs of + y : _ -> isSpace y + _ -> False + +unindent :: [String] -> [String] +unindent input = map (drop indentation) input + where + indentation = minimum $ map (length . takeWhile isSpace) input + +sniffAlignment :: [String] -> Maybe Alignment +sniffAlignment input = case nub . catMaybes . map indentation . catMaybes . map splitField $ input of + [n] -> Just (Alignment n) + _ -> Nothing + where + + indentation :: (String, String) -> Maybe Int + indentation (name, value) = case span isSpace value of + (_, "") -> Nothing + (xs, _) -> (Just . succ . length $ name ++ xs) + +splitField :: String -> Maybe (String, String) +splitField field = case span isNameChar field of + (xs, ':':ys) -> Just (xs, ys) + _ -> Nothing + where + isNameChar = (`elem` nameChars) + nameChars = ['a'..'z'] ++ ['A'..'Z'] ++ "-" + +sniffIndentation :: [String] -> Maybe Int +sniffIndentation input = sniffFrom "library" <|> sniffFrom "executable" + where + sniffFrom :: String -> Maybe Int + sniffFrom section = case findSection . removeEmptyLines $ input of + _ : x : _ -> Just . length $ takeWhile isSpace x + _ -> Nothing + where + findSection = dropWhile (not . isPrefixOf section) + + removeEmptyLines :: [String] -> [String] + removeEmptyLines = filter $ any (not . isSpace) + +sniffCommaStyle :: [String] -> Maybe CommaStyle +sniffCommaStyle input + | any startsWithComma input = Just LeadingCommas + | any (startsWithComma . reverse) input = Just TrailingCommas + | otherwise = Nothing + where + startsWithComma = isPrefixOf "," . dropWhile isSpace + +sniffRenderSettings :: [String] -> RenderSettings +sniffRenderSettings input = RenderSettings indentation fieldAlignment commaStyle + where + indentation = fromMaybe (renderSettingsIndentation defaultRenderSettings) (sniffIndentation input) + fieldAlignment = renderSettingsFieldAlignment defaultRenderSettings + commaStyle = fromMaybe (renderSettingsCommaStyle defaultRenderSettings) (sniffCommaStyle input) diff --git a/src/Hpack/Render.hs b/src/Hpack/Render.hs --- a/src/Hpack/Render.hs +++ b/src/Hpack/Render.hs @@ -1,15 +1,34 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} -module Hpack.Render where +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Hpack.Render ( +-- * AST + Element (..) +, Value (..) +-- * Render +, RenderSettings (..) +, CommaStyle (..) +, defaultRenderSettings +, Alignment (..) +, Nesting +, render + +-- * Utils +, sortFieldsBy + +#ifdef TEST +, Lines (..) +, renderValue +, addSortKey +#endif +) where + import Prelude () import Prelude.Compat -import Control.Applicative -import Data.Char -import Data.List.Compat -import Data.Maybe import Data.String +import Data.List.Compat data Value = Literal String @@ -18,7 +37,7 @@ | WordList [String] deriving (Eq, Show) -data Element = Stanza String [Element] | Field String Value +data Element = Stanza String [Element] | Group Element Element | Field String Value deriving (Eq, Show) data Lines = SingleLine String | MultipleLines [String] @@ -27,24 +46,38 @@ data CommaStyle = LeadingCommas | TrailingCommas deriving (Eq, Show) +newtype Nesting = Nesting Int + deriving (Eq, Show, Num, Enum) + +newtype Alignment = Alignment Int + deriving (Eq, Show, Num) + data RenderSettings = RenderSettings { renderSettingsIndentation :: Int +, renderSettingsFieldAlignment :: Alignment , renderSettingsCommaStyle :: CommaStyle } deriving (Eq, Show) defaultRenderSettings :: RenderSettings -defaultRenderSettings = RenderSettings 2 LeadingCommas +defaultRenderSettings = RenderSettings 2 0 LeadingCommas -render :: RenderSettings -> Int -> Element -> [String] -render settings nesting (Stanza name elements) = indent settings nesting name : renderElements elements - where - renderElements :: [Element] -> [String] - renderElements = concatMap (render settings $ succ nesting) -render settings nesting (Field name v) = case renderValue settings v of +render :: RenderSettings -> Nesting -> Element -> [String] +render settings nesting (Stanza name elements) = indent settings nesting name : renderElements settings (succ nesting) elements +render settings nesting (Group a b) = render settings nesting a ++ render settings nesting b +render settings nesting (Field name value) = renderField settings nesting name value + +renderElements :: RenderSettings -> Nesting -> [Element] -> [String] +renderElements settings nesting = concatMap (render settings nesting) + +renderField :: RenderSettings -> Nesting -> String -> Value -> [String] +renderField settings@RenderSettings{..} nesting name value = case renderValue settings value of SingleLine "" -> [] - SingleLine x -> [indent settings nesting (name ++ ": " ++ x)] + SingleLine x -> [indent settings nesting (name ++ ": " ++ padding ++ x)] MultipleLines [] -> [] MultipleLines xs -> (indent settings nesting name ++ ":") : map (indent settings $ succ nesting) xs + where + Alignment fieldAlignment = renderSettingsFieldAlignment + padding = replicate (fieldAlignment - length name - 2) ' ' renderValue :: RenderSettings -> Value -> Lines renderValue RenderSettings{..} v = case v of @@ -78,32 +111,25 @@ instance IsString Value where fromString = Literal -indent :: RenderSettings -> Int -> String -> String -indent RenderSettings{..} nesting s = replicate (nesting * renderSettingsIndentation) ' ' ++ s - -sniffIndentation :: String -> Maybe Int -sniffIndentation input = sniffFrom "library" <|> sniffFrom "executable" - where - sniffFrom :: String -> Maybe Int - sniffFrom section = case findSection . removeEmptyLines $ lines input of - _ : x : _ -> Just . length $ takeWhile isSpace x - _ -> Nothing - where - findSection = dropWhile (not . isPrefixOf section) - - removeEmptyLines :: [String] -> [String] - removeEmptyLines = filter $ any (not . isSpace) +indent :: RenderSettings -> Nesting -> String -> String +indent RenderSettings{..} (Nesting nesting) s = replicate (nesting * renderSettingsIndentation) ' ' ++ s -sniffCommaStyle :: String -> Maybe CommaStyle -sniffCommaStyle (lines -> input) - | any startsWithComma input = Just LeadingCommas - | any (startsWithComma . reverse) input = Just TrailingCommas - | otherwise = Nothing +sortFieldsBy :: [String] -> [Element] -> [Element] +sortFieldsBy existingFieldOrder = + map snd + . sortOn fst + . addSortKey + . map (\a -> (existingIndex a, a)) where - startsWithComma = isPrefixOf "," . dropWhile isSpace + existingIndex :: Element -> Maybe Int + existingIndex (Field name _) = name `elemIndex` existingFieldOrder + existingIndex _ = Nothing -sniffRenderSettings :: String -> RenderSettings -sniffRenderSettings input = RenderSettings indentation trailingCommas +addSortKey :: [(Maybe Int, a)] -> [((Int, Int), a)] +addSortKey = go (-1) . zip [0..] where - indentation = fromMaybe (renderSettingsIndentation defaultRenderSettings) (sniffIndentation input) - trailingCommas = fromMaybe (renderSettingsCommaStyle defaultRenderSettings) (sniffCommaStyle input) + go :: Int -> [(Int, (Maybe Int, a))] -> [((Int, Int), a)] + go n xs = case xs of + [] -> [] + (x, (Just y, a)) : ys -> ((y, x), a) : go y ys + (x, (Nothing, a)) : ys -> ((n, x), a) : go n ys diff --git a/src/Hpack/Run.hs b/src/Hpack/Run.hs --- a/src/Hpack/Run.hs +++ b/src/Hpack/Run.hs @@ -7,6 +7,7 @@ run , renderPackage , RenderSettings(..) +, Alignment(..) , CommaStyle(..) , defaultRenderSettings #ifdef TEST @@ -30,6 +31,7 @@ import Hpack.Util import Hpack.Config import Hpack.Render +import Hpack.FormattingHints run :: FilePath -> IO ([String], FilePath, String) run dir = do @@ -40,19 +42,24 @@ old <- tryReadFile cabalFile - let alignment = fromMaybe 16 (old >>= sniffAlignment) - settings = maybe defaultRenderSettings sniffRenderSettings old - output = renderPackage settings alignment (maybe [] extractFieldOrderHint old) pkg + let + FormattingHints{..} = sniffFormattingHints (fromMaybe "" old) + alignment = fromMaybe 16 formattingHintsAlignment + settings = formattingHintsRenderSettings + + output = renderPackage settings alignment formattingHintsFieldOrder formattingHintsSectionsFieldOrder pkg + return (warnings, cabalFile, output) Left err -> die err -renderPackage :: RenderSettings -> Int -> [String] -> Package -> String -renderPackage settings alignment existingFieldOrder Package{..} = intercalate "\n" (header : chunks) +renderPackage :: RenderSettings -> Alignment -> [String] -> [(String, [String])] -> Package -> String +renderPackage settings alignment existingFieldOrder sectionsFieldOrder Package{..} = intercalate "\n" (unlines header : chunks) where chunks :: [String] - chunks = map unlines . filter (not . null) . map (render settings 0) $ stanzas + chunks = map unlines . filter (not . null) . map (render settings 0) $ sortSectionFields sectionsFieldOrder stanzas - header = unlines $ map formatField sortedFields + header :: [String] + header = concatMap (render settings {renderSettingsFieldAlignment = alignment} 0) fields extraSourceFiles :: Element extraSourceFiles = Field "extra-source-files" (LineSeparatedList packageExtraSourceFiles) @@ -65,41 +72,20 @@ library = maybe [] (return . renderLibrary) packageLibrary stanzas :: [Element] - stanzas = extraSourceFiles - : dataFiles - : sourceRepository - ++ map renderFlag packageFlags - ++ library - ++ renderExecutables packageExecutables - ++ renderTests packageTests - ++ renderBenchmarks packageBenchmarks - - 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) + stanzas = + extraSourceFiles + : dataFiles + : sourceRepository + ++ concat [ + map renderFlag packageFlags + , library + , renderExecutables packageExecutables + , renderTests packageTests + , renderBenchmarks packageBenchmarks + ] - fields :: [(String, String)] - fields = mapMaybe (\(name, value) -> (,) name <$> value) $ [ + fields :: [Element] + fields = sortFieldsBy existingFieldOrder . mapMaybe (\(name, value) -> Field name . Literal <$> value) $ [ ("name", Just packageName) , ("version", Just packageVersion) , ("synopsis", packageSynopsis) @@ -121,10 +107,7 @@ 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 + separator = let Alignment n = alignment in ",\n" ++ replicate n ' ' cabalVersion :: Maybe String cabalVersion = maximum [ @@ -138,8 +121,16 @@ hasReexportedModules :: Section Library -> Bool hasReexportedModules = not . null . libraryReexportedModules . sectionData -formatDescription :: Int -> String -> String -formatDescription alignment description = case map emptyLineToDot $ lines description of +sortSectionFields :: [(String, [String])] -> [Element] -> [Element] +sortSectionFields sectionsFieldOrder = go + where + go sections = case sections of + [] -> [] + Stanza name fields : xs | Just fieldOrder <- lookup name sectionsFieldOrder -> Stanza name (sortFieldsBy fieldOrder fields) : go xs + x : xs -> x : go xs + +formatDescription :: Alignment -> String -> String +formatDescription (Alignment alignment) description = case map emptyLineToDot $ lines description of x : xs -> intercalate "\n" (x : map (indentation ++) xs) [] -> "" where @@ -224,12 +215,14 @@ , renderDependencies sectionDependencies ] ++ maybe [] (return . renderBuildable) sectionBuildable - ++ concatMap renderConditional sectionConditionals + ++ map renderConditional sectionConditionals -renderConditional :: Conditional -> [Element] -renderConditional (Conditional condition sect mElse) = Stanza ("if " ++ condition) (renderSection sect) : else_ +renderConditional :: Conditional -> Element +renderConditional (Conditional condition sect mElse) = case mElse of + Nothing -> if_ + Just else_ -> Group if_ (Stanza "else" $ renderSection else_) where - else_ = maybe [] (return . Stanza "else" . renderSection) mElse + if_ = Stanza ("if " ++ condition) (renderSection sect) defaultLanguage :: Element defaultLanguage = Field "default-language" "Haskell2010" diff --git a/src/Hpack/Util.hs b/src/Hpack/Util.hs --- a/src/Hpack/Util.hs +++ b/src/Hpack/Util.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE CPP #-} module Hpack.Util ( List(..) , GhcOption @@ -10,25 +9,22 @@ , toModule , getFilesRecursive , tryReadFile -, sniffAlignment -, extractFieldOrderHint , expandGlobs , sort , lexicographically -#ifdef TEST -, splitField -#endif ) where +import Prelude () +import Prelude.Compat + import Control.Applicative import Control.DeepSeq import Control.Exception -import Control.Monad +import Control.Monad.Compat import Data.Aeson.Types import Data.Char import Data.Data -import Data.List hiding (sort) -import Data.Maybe +import Data.List.Compat hiding (sort) import Data.Ord import System.Directory import System.FilePath @@ -99,28 +95,6 @@ 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'] ++ "-" toPosixFilePath :: FilePath -> FilePath toPosixFilePath = Posix.joinPath . splitDirectories diff --git a/test/Hpack/ConfigSpec.hs b/test/Hpack/ConfigSpec.hs --- a/test/Hpack/ConfigSpec.hs +++ b/test/Hpack/ConfigSpec.hs @@ -193,7 +193,7 @@ git: "https://github.com/sol/hpack", ref: "master" }|] - source = GitRef "https://github.com/sol/hpack" "master" + source = GitRef "https://github.com/sol/hpack" "master" Nothing parseEither parseJSON value `shouldBe` Right (Dependency "hpack" (Just source)) it "accepts github dependencies" $ do @@ -202,8 +202,18 @@ github: "sol/hpack", ref: "master" }|] - source = GitRef "https://github.com/sol/hpack" "master" + source = GitRef "https://github.com/sol/hpack" "master" Nothing parseEither parseJSON value `shouldBe` Right (Dependency "hpack" (Just source)) + + it "accepts an optional subdirectory for git dependencies" $ do + let value = [aesonQQ|{ + name: "warp", + github: "yesodweb/wai", + ref: "master", + subdir: "warp" + }|] + source = GitRef "https://github.com/yesodweb/wai" "master" (Just "warp") + parseEither parseJSON value `shouldBe` Right (Dependency "warp" (Just source)) it "accepts local dependencies" $ do let value = [aesonQQ|{ diff --git a/test/Hpack/FormattingHintsSpec.hs b/test/Hpack/FormattingHintsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Hpack/FormattingHintsSpec.hs @@ -0,0 +1,166 @@ +module Hpack.FormattingHintsSpec (spec) where + +import Test.Hspec + +import Hpack.FormattingHints +import Hpack.Render + +spec :: Spec +spec = do + describe "extractFieldOrder" $ do + it "extracts field order hints" $ do + let input = [ + "name: cabalize" + , "version: 0.0.0" + , "license:" + , "license-file: " + , "build-type: Simple" + , "cabal-version: >= 1.10" + ] + extractFieldOrder input `shouldBe` [ + "name" + , "version" + , "license" + , "license-file" + , "build-type" + , "cabal-version" + ] + + describe "extractSectionsFieldOrder" $ do + it "splits input into sections" $ do + let input = [ + "name: cabalize" + , "version: 0.0.0" + , "" + , "library" + , " foo: 23" + , " bar: 42" + , "" + , "executable foo" + , " bar: 23" + , " baz: 42" + ] + extractSectionsFieldOrder input `shouldBe` [("library", ["foo", "bar"]), ("executable foo", ["bar", "baz"])] + + describe "breakLines" $ do + it "breaks input into lines" $ do + let input = unlines [ + "foo" + , "" + , " " + , " bar " + , " baz" + ] + breakLines input `shouldBe` [ + "foo" + , " bar" + , " baz" + ] + + describe "unindent" $ do + it "unindents" $ do + let input = [ + " foo" + , " bar" + , " baz" + ] + unindent input `shouldBe` [ + " foo" + , "bar" + , " baz" + ] + + describe "sniffAlignment" $ do + it "sniffs field alignment from given cabal file" $ do + let input = [ + "name: cabalize" + , "version: 0.0.0" + , "license: MIT" + , "license-file: LICENSE" + , "build-type: Simple" + , "cabal-version: >= 1.10" + ] + sniffAlignment input `shouldBe` Just 16 + + it "ignores fields without a value on the same line" $ do + let input = [ + "name: cabalize" + , "version: 0.0.0" + , "description: " + , " foo" + , " bar" + ] + sniffAlignment input `shouldBe` Just 16 + + describe "splitField" $ do + it "splits fields" $ do + splitField "foo: bar" `shouldBe` Just ("foo", " bar") + + it "accepts fields names with dashes" $ do + splitField "foo-bar: baz" `shouldBe` Just ("foo-bar", " baz") + + it "rejects fields names with spaces" $ do + splitField "foo bar: baz" `shouldBe` Nothing + + it "rejects invalid fields" $ do + splitField "foo bar" `shouldBe` Nothing + + describe "sniffIndentation" $ do + it "sniff alignment from executable section" $ do + let input = [ + "name: foo" + , "version: 0.0.0" + , "" + , "executable foo" + , " build-depends: bar" + ] + sniffIndentation input `shouldBe` Just 4 + + it "sniff alignment from library section" $ do + let input = [ + "name: foo" + , "version: 0.0.0" + , "" + , "library" + , " build-depends: bar" + ] + sniffIndentation input `shouldBe` Just 4 + + it "ignores empty lines" $ do + let input = [ + "executable foo" + , "" + , " build-depends: bar" + ] + sniffIndentation input `shouldBe` Just 4 + + it "ignores whitespace lines" $ do + let input = [ + "executable foo" + , " " + , " build-depends: bar" + ] + sniffIndentation input `shouldBe` Just 4 + + describe "sniffCommaStyle" $ do + it "detects leading commas" $ do + let input = [ + "executable foo" + , " build-depends:" + , " bar" + , " , baz" + ] + sniffCommaStyle input `shouldBe` Just LeadingCommas + + it "detects trailing commas" $ do + let input = [ + "executable foo" + , " build-depends:" + , " bar, " + , " baz" + ] + sniffCommaStyle input `shouldBe` Just TrailingCommas + + context "when detection fails" $ do + it "returns Nothing" $ do + sniffCommaStyle [] `shouldBe` Nothing diff --git a/test/Hpack/RenderSpec.hs b/test/Hpack/RenderSpec.hs --- a/test/Hpack/RenderSpec.hs +++ b/test/Hpack/RenderSpec.hs @@ -1,21 +1,27 @@ {-# LANGUAGE OverloadedStrings #-} - module Hpack.RenderSpec where -import Test.Hspec +import Prelude () +import Prelude.Compat -import Hpack.Render +import Test.Hspec +import Test.QuickCheck +import Data.List.Compat +import Data.Maybe +import Hpack.Render + spec :: Spec spec = do describe "render" $ do + let render_ = render defaultRenderSettings 0 context "when rendering a Stanza" $ do it "renders stanza" $ do let stanza = Stanza "foo" [ Field "bar" "23" , Field "baz" "42" ] - render defaultRenderSettings 0 stanza `shouldBe` [ + render_ stanza `shouldBe` [ "foo" , " bar: 23" , " baz: 42" @@ -26,7 +32,7 @@ Field "bar" "23" , Field "baz" (WordList []) ] - render defaultRenderSettings 0 stanza `shouldBe` [ + render_ stanza `shouldBe` [ "foo" , " bar: 23" ] @@ -44,7 +50,7 @@ it "renders nested stanzas" $ do let input = Stanza "foo" [Field "bar" "23", Stanza "baz" [Field "qux" "42"]] - render defaultRenderSettings 0 input `shouldBe` [ + render_ input `shouldBe` [ "foo" , " bar: 23" , " baz" @@ -64,21 +70,25 @@ context "when value is empty" $ do it "returns an empty list" $ do let field = Field "foo" (CommaSeparatedList []) - render defaultRenderSettings 0 field `shouldBe` [] + render_ field `shouldBe` [] context "when rendering a SingleLine value" $ do it "returns a single line" $ do let field = Field "foo" (Literal "bar") - render defaultRenderSettings 0 field `shouldBe` ["foo: bar"] + render_ field `shouldBe` ["foo: bar"] it "takes nesting into account" $ do let field = Field "foo" (Literal "bar") render defaultRenderSettings 2 field `shouldBe` [" foo: bar"] + it "takes alignment into account" $ do + let field = Field "foo" (Literal "bar") + render defaultRenderSettings {renderSettingsFieldAlignment = 10} 0 field `shouldBe` ["foo: bar"] + context "when value is empty" $ do it "returns an empty list" $ do let field = Field "foo" (Literal "") - render defaultRenderSettings 0 field `shouldBe` [] + render_ field `shouldBe` [] describe "renderValue" $ do it "renders WordList" $ do @@ -115,62 +125,34 @@ , "baz" ] - describe "sniffIndentation" $ do - it "sniff alignment from executable section" $ do - let input = unlines [ - "name: foo" - , "version: 0.0.0" - , "" - , "executable foo" - , " build-depends: bar" - ] - sniffIndentation input `shouldBe` Just 4 + describe "sortFieldsBy" $ do + let + field name = Field name (Literal $ name ++ " value") + arbitraryFieldNames = sublistOf ["foo", "bar", "baz", "qux", "foobar", "foobaz"] >>= shuffle - it "sniff alignment from library section" $ do - let input = unlines [ - "name: foo" - , "version: 0.0.0" - , "" - , "library" - , " build-depends: bar" - ] - sniffIndentation input `shouldBe` Just 4 + it "sorts fields" $ do + let fields = map field ["baz", "bar", "foo"] + sortFieldsBy ["foo", "bar", "baz"] fields `shouldBe` map field ["foo", "bar", "baz"] - it "ignores empty lines" $ do - let input = unlines [ - "executable foo" - , "" - , " build-depends: bar" - ] - sniffIndentation input `shouldBe` Just 4 + it "keeps existing field order" $ do + forAll (map field <$> arbitraryFieldNames) $ \fields -> do + forAll arbitraryFieldNames $ \existingFieldOrder -> do + let + existingIndex :: Element -> Maybe Int + existingIndex (Field name _) = name `elemIndex` existingFieldOrder + existingIndex _ = Nothing - it "ignores whitespace lines" $ do - let input = unlines [ - "executable foo" - , " " - , " build-depends: bar" - ] - sniffIndentation input `shouldBe` Just 4 + indexes :: [Int] + indexes = mapMaybe existingIndex (sortFieldsBy existingFieldOrder fields) - describe "sniffCommaStyle" $ do - it "detects leading commas" $ do - let input = unlines [ - "executable foo" - , " build-depends:" - , " bar" - , " , baz" - ] - sniffCommaStyle input `shouldBe` Just LeadingCommas + sort indexes `shouldBe` indexes - it "detects trailing commas" $ do - let input = unlines [ - "executable foo" - , " build-depends:" - , " bar, " - , " baz" - ] - sniffCommaStyle input `shouldBe` Just TrailingCommas + it "is stable" $ do + forAll arbitraryFieldNames $ \fieldNames -> do + forAll (elements $ subsequences fieldNames) $ \existingFieldOrder -> do + let fields = map field fieldNames + sortFieldsBy existingFieldOrder fields `shouldBe` fields - context "when detection fails" $ do - it "returns Nothing" $ do - sniffCommaStyle "" `shouldBe` Nothing + describe "addSortKey" $ do + it "adds sort key" $ do + addSortKey [(Nothing, "foo"), (Just 3, "bar"), (Nothing, "baz")] `shouldBe` [((-1, 0), "foo"), ((3, 1), "bar"), ((3, 2), "baz" :: String)] diff --git a/test/Hpack/RunSpec.hs b/test/Hpack/RunSpec.hs --- a/test/Hpack/RunSpec.hs +++ b/test/Hpack/RunSpec.hs @@ -2,7 +2,7 @@ module Hpack.RunSpec (spec) where import Test.Hspec -import Data.List +import Data.List.Compat import Hpack.ConfigSpec hiding (spec) import Hpack.Config hiding (package) @@ -12,9 +12,9 @@ spec :: Spec spec = do describe "renderPackage" $ do - let renderPackage_ = renderPackage defaultRenderSettings + let renderPackage_ = renderPackage defaultRenderSettings 0 [] [] it "renders a package" $ do - renderPackage_ 0 [] package `shouldBe` unlines [ + renderPackage_ package `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" @@ -22,7 +22,7 @@ ] it "aligns fields" $ do - renderPackage_ 16 [] package `shouldBe` unlines [ + renderPackage defaultRenderSettings 16 [] [] package `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" @@ -30,7 +30,7 @@ ] it "includes description" $ do - renderPackage_ 0 [] package {packageDescription = Just "foo\n\nbar\n"} `shouldBe` unlines [ + renderPackage_ package {packageDescription = Just "foo\n\nbar\n"} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "description: foo" @@ -41,7 +41,7 @@ ] it "aligns description" $ do - renderPackage_ 16 [] package {packageDescription = Just "foo\n\nbar\n"} `shouldBe` unlines [ + renderPackage defaultRenderSettings 16 [] [] package {packageDescription = Just "foo\n\nbar\n"} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "description: foo" @@ -52,7 +52,7 @@ ] it "includes stability" $ do - renderPackage_ 0 [] package {packageStability = Just "experimental"} `shouldBe` unlines [ + renderPackage_ package {packageStability = Just "experimental"} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "stability: experimental" @@ -61,7 +61,7 @@ ] it "includes copyright holder" $ do - renderPackage_ 0 [] package {packageCopyright = ["(c) 2015 Simon Hengel"]} `shouldBe` unlines [ + renderPackage_ package {packageCopyright = ["(c) 2015 Simon Hengel"]} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "copyright: (c) 2015 Simon Hengel" @@ -70,7 +70,7 @@ ] it "aligns copyright holders" $ do - renderPackage_ 16 [] package {packageCopyright = ["(c) 2015 Foo", "(c) 2015 Bar"]} `shouldBe` unlines [ + renderPackage defaultRenderSettings 16 [] [] package {packageCopyright = ["(c) 2015 Foo", "(c) 2015 Bar"]} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "copyright: (c) 2015 Foo," @@ -80,7 +80,7 @@ ] it "includes extra-source-files" $ do - renderPackage_ 0 [] package {packageExtraSourceFiles = ["foo", "bar"]} `shouldBe` unlines [ + renderPackage_ package {packageExtraSourceFiles = ["foo", "bar"]} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" @@ -92,7 +92,7 @@ ] it "includes buildable" $ do - renderPackage_ 0 [] package {packageLibrary = Just (section library){sectionBuildable = Just False}} `shouldBe` unlines [ + renderPackage_ package {packageLibrary = Just (section library){sectionBuildable = Just False}} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" @@ -105,7 +105,7 @@ context "when rendering library section" $ do it "renders library section" $ do - renderPackage_ 0 [] package {packageLibrary = Just $ section library} `shouldBe` unlines [ + renderPackage_ package {packageLibrary = Just $ section library} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" @@ -116,7 +116,7 @@ ] it "includes exposed-modules" $ do - renderPackage_ 0 [] package {packageLibrary = Just (section library{libraryExposedModules = ["Foo"]})} `shouldBe` unlines [ + renderPackage_ package {packageLibrary = Just (section library{libraryExposedModules = ["Foo"]})} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" @@ -129,7 +129,7 @@ ] it "includes other-modules" $ do - renderPackage_ 0 [] package {packageLibrary = Just (section library{libraryOtherModules = ["Bar"]})} `shouldBe` unlines [ + renderPackage_ package {packageLibrary = Just (section library{libraryOtherModules = ["Bar"]})} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" @@ -142,7 +142,7 @@ ] it "includes reexported-modules and bumps cabal version" $ do - renderPackage_ 0 [] package {packageLibrary = Just (section library{libraryReexportedModules = ["Baz"]})} `shouldBe` unlines [ + renderPackage_ package {packageLibrary = Just (section library{libraryReexportedModules = ["Baz"]})} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" @@ -156,7 +156,7 @@ context "when given list of existing fields" $ do it "retains field order" $ do - renderPackage_ 16 ["cabal-version", "version", "name", "build-type"] package `shouldBe` unlines [ + renderPackage defaultRenderSettings 16 ["cabal-version", "version", "name", "build-type"] [] package `shouldBe` unlines [ "cabal-version: >= 1.10" , "version: 0.0.0" , "name: foo" @@ -164,16 +164,30 @@ ] it "uses default field order for new fields" $ do - renderPackage_ 16 ["name", "version", "cabal-version"] package `shouldBe` unlines [ + renderPackage defaultRenderSettings 16 ["name", "version", "cabal-version"] [] package `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" , "cabal-version: >= 1.10" ] + it "retains section field order" $ do + renderPackage defaultRenderSettings 0 [] [("executable foo", ["default-language", "main-is", "ghc-options"])] package {packageExecutables = [(section $ executable "foo" "Main.hs") {sectionGhcOptions = ["-Wall", "-Werror"]}]} `shouldBe` unlines [ + "name: foo" + , "version: 0.0.0" + , "build-type: Simple" + , "cabal-version: >= 1.10" + , "" + , "executable foo" + , " default-language: Haskell2010" + , " main-is: Main.hs" + , " ghc-options: -Wall -Werror" + ] + + context "when rendering executable section" $ do it "includes dependencies" $ do - renderPackage_ 0 [] package {packageExecutables = [(section $ executable "foo" "Main.hs") {sectionDependencies = ["foo", "bar", "foo", "baz"]}]} `shouldBe` unlines [ + renderPackage_ package {packageExecutables = [(section $ executable "foo" "Main.hs") {sectionDependencies = ["foo", "bar", "foo", "baz"]}]} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" @@ -190,7 +204,7 @@ ] it "includes GHC options" $ do - renderPackage_ 0 [] package {packageExecutables = [(section $ executable "foo" "Main.hs") {sectionGhcOptions = ["-Wall", "-Werror"]}]} `shouldBe` unlines [ + renderPackage_ package {packageExecutables = [(section $ executable "foo" "Main.hs") {sectionGhcOptions = ["-Wall", "-Werror"]}]} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" @@ -203,7 +217,7 @@ ] it "includes GHC profiling options" $ do - renderPackage_ 0 [] package {packageExecutables = [(section $ executable "foo" "Main.hs") {sectionGhcProfOptions = ["-fprof-auto", "-rtsopts"]}]} `shouldBe` unlines [ + renderPackage_ package {packageExecutables = [(section $ executable "foo" "Main.hs") {sectionGhcProfOptions = ["-fprof-auto", "-rtsopts"]}]} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" @@ -217,7 +231,7 @@ describe "renderConditional" $ do it "renders conditionals" $ do let conditional = Conditional "os(windows)" (section ()) {sectionDependencies = ["Win32"]} Nothing - concatMap (render defaultRenderSettings 0) (renderConditional conditional) `shouldBe` [ + render defaultRenderSettings 0 (renderConditional conditional) `shouldBe` [ "if os(windows)" , " build-depends:" , " Win32" @@ -225,7 +239,7 @@ it "renders conditionals with else-branch" $ do let conditional = Conditional "os(windows)" (section ()) {sectionDependencies = ["Win32"]} (Just $ (section ()) {sectionDependencies = ["unix"]}) - concatMap (render defaultRenderSettings 0) (renderConditional conditional) `shouldBe` [ + render defaultRenderSettings 0 (renderConditional conditional) `shouldBe` [ "if os(windows)" , " build-depends:" , " Win32" @@ -237,7 +251,7 @@ it "renders nested conditionals" $ do let conditional = Conditional "arch(i386)" (section ()) {sectionGhcOptions = ["-threaded"], sectionConditionals = [innerConditional]} Nothing innerConditional = Conditional "os(windows)" (section ()) {sectionDependencies = ["Win32"]} Nothing - concatMap (render defaultRenderSettings 0) (renderConditional conditional) `shouldBe` [ + render defaultRenderSettings 0 (renderConditional conditional) `shouldBe` [ "if arch(i386)" , " ghc-options: -threaded" , " if os(windows)" diff --git a/test/Hpack/UtilSpec.hs b/test/Hpack/UtilSpec.hs --- a/test/Hpack/UtilSpec.hs +++ b/test/Hpack/UtilSpec.hs @@ -88,60 +88,6 @@ 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 - describe "expandGlobs" $ around withTempDirectory $ do it "accepts simple files" $ \dir -> do touch (dir "foo.js") diff --git a/test/HpackSpec.hs b/test/HpackSpec.hs --- a/test/HpackSpec.hs +++ b/test/HpackSpec.hs @@ -1,9 +1,21 @@ module HpackSpec (spec) where +import Prelude () +import Prelude.Compat + +import Control.Monad.Compat +import Control.DeepSeq +import Data.Version (Version(..), showVersion) + import Test.Hspec +import Test.Mockery.Directory +import Test.QuickCheck import Hpack +makeVersion :: [Int] -> Version +makeVersion v = Version v [] + spec :: Spec spec = do describe "parseVerbosity" $ do @@ -13,3 +25,47 @@ context "with --silent" $ do it "returns False" $ do parseVerbosity ["--silent"] `shouldBe` (False, []) + + describe "extractVersion" $ do + it "extracts Hpack version from a cabal file" $ do + let cabalFile = ["-- This file has been generated from package.yaml by hpack version 0.10.0."] + extractVersion cabalFile `shouldBe` Just (Version [0, 10, 0] []) + + it "is total" $ do + let cabalFile = ["-- This file has been generated from package.yaml by hpack version "] + extractVersion cabalFile `shouldBe` Nothing + + describe "parseVersion" $ do + it "is inverse to showVersion" $ do + let positive = getPositive <$> arbitrary + forAll (replicateM 3 positive) $ \xs -> do + let v = Version xs [] + parseVersion (showVersion v) `shouldBe` Just v + + describe "hpackWithVersion" $ do + context "when only the hpack version in the cabal file header changed" $ do + it "does not write a new cabal file" $ do + inTempDirectory $ do + writeFile "package.yaml" "name: foo" + hpackWithVersion (makeVersion [0,8,0]) "." False + old <- readFile "foo.cabal" >>= (return $!!) + hpackWithVersion (makeVersion [0,10,0]) "." False + readFile "foo.cabal" `shouldReturn` old + + context "when exsting cabal file was generated with a newer version of hpack" $ do + it "does not re-generate" $ do + inTempDirectory $ do + writeFile "package.yaml" $ unlines [ + "name: foo" + , "version: 0.1.0" + ] + hpackWithVersion (makeVersion [0,10,0]) "." False + old <- readFile "foo.cabal" >>= (return $!!) + + writeFile "package.yaml" $ unlines [ + "name: foo" + , "version: 0.2.0" + ] + + hpackWithVersion (makeVersion [0,8,0]) "." False + readFile "foo.cabal" `shouldReturn` old