hpack-0.14.1/driver/0000755000000000000000000000000012726536670012362 5ustar0000000000000000hpack-0.14.1/src/0000755000000000000000000000000012726536670011656 5ustar0000000000000000hpack-0.14.1/src/Hpack/0000755000000000000000000000000012726536670012704 5ustar0000000000000000hpack-0.14.1/test/0000755000000000000000000000000012726536670012046 5ustar0000000000000000hpack-0.14.1/test/Hpack/0000755000000000000000000000000012726536670013074 5ustar0000000000000000hpack-0.14.1/src/Hpack.hs0000644000000000000000000000744212714052040013224 0ustar0000000000000000{-# LANGUAGE CPP #-} module Hpack ( hpack , hpackResult , Result(..) , Status(..) , version , main #ifdef TEST , hpackWithVersion , parseVerbosity , extractVersion , parseVersion #endif ) where import Prelude () import Prelude.Compat import Control.DeepSeq import Control.Exception import Control.Monad.Compat import Data.List.Compat 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 :: Version -> String programVersion v = "hpack version " ++ Version.showVersion v header :: Version -> String header v = unlines [ "-- This file has been generated from " ++ packageConfig ++ " by " ++ programVersion v ++ "." , "--" , "-- see: https://github.com/sol/hpack" , "" ] main :: IO () main = do args <- getArgs case args of ["--version"] -> putStrLn (programVersion version) ["--help"] -> printHelp _ -> case parseVerbosity args of (verbose, [dir]) -> hpack dir verbose (verbose, []) -> hpack "" verbose _ -> do printHelp exitFailure printHelp :: IO () printHelp = do hPutStrLn stderr $ unlines [ "Usage: hpack [ --silent ] [ dir ]" , " hpack --version" ] parseVerbosity :: [String] -> (Bool, [String]) parseVerbosity xs = (verbose, ys) where silentFlag = "--silent" 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 = hpackWithVersion version hpackResult :: FilePath -> IO Result hpackResult = hpackWithVersionResult version data Result = Result { resultWarnings :: [String] , resultCabalFile :: String , resultStatus :: Status } data Status = Generated | AlreadyGeneratedByNewerHpack | OutputUnchanged hpackWithVersion :: Version -> FilePath -> Bool -> IO () hpackWithVersion v dir verbose = do r <- hpackWithVersionResult v dir forM_ (resultWarnings r) $ \warning -> hPutStrLn stderr ("WARNING: " ++ warning) when verbose $ putStrLn $ case resultStatus r of Generated -> "generated " ++ resultCabalFile r OutputUnchanged -> resultCabalFile r ++ " is up-to-date" AlreadyGeneratedByNewerHpack -> resultCabalFile r ++ " was generated with a newer version of hpack, please upgrade and try again." hpackWithVersionResult :: Version -> FilePath -> IO Result hpackWithVersionResult v dir = do (warnings, cabalFile, new) <- run dir old <- either (const Nothing) (Just . splitHeader) <$> tryJust (guard . isDoesNotExistError) (readFile cabalFile >>= (return $!!)) let oldVersion = fmap fst old >>= extractVersion status <- if (oldVersion <= Just v) then if (fmap snd old == Just (lines new)) then return OutputUnchanged else do writeFile cabalFile $ header v ++ new return Generated else return AlreadyGeneratedByNewerHpack return Result { resultWarnings = warnings , resultCabalFile = cabalFile , resultStatus = status } where splitHeader :: String -> ([String], [String]) splitHeader = fmap (dropWhile null) . span ("--" `isPrefixOf`) . lines hpack-0.14.1/src/Hpack/Config.hs0000644000000000000000000006371212726536046014453 0ustar0000000000000000{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} module Hpack.Config ( packageConfig , readPackageConfig , renamePackage , packageDependencies , package , section , Package(..) , Dependency(..) , AddSource(..) , GitUrl , GitRef , GhcOption , Section(..) , Library(..) , Executable(..) , Conditional(..) , Flag(..) , SourceRepository(..) #ifdef TEST , renameDependencies , HasFieldNames(..) , CaptureUnknownFields(..) , Empty(..) , getModules , determineModules #endif ) where import Control.Applicative import Control.Monad.Compat import Data.Aeson.Types import Data.Data import Data.Map.Lazy (Map) import qualified Data.Map.Lazy as Map import qualified Data.HashMap.Lazy as HashMap import Data.List.Compat (nub, (\\), sortBy) import Data.Maybe import Data.Ord import Data.String import Data.Text (Text) import qualified Data.Text as T import GHC.Generics (Generic, Rep) import Prelude () import Prelude.Compat import System.Directory import System.FilePath import Hpack.GenericsUtil import Hpack.Util import Hpack.Yaml package :: String -> String -> Package package name version = Package name version Nothing Nothing Nothing Nothing Nothing Nothing [] [] [] Nothing Nothing Nothing [] [] [] Nothing Nothing [] [] [] renamePackage :: String -> Package -> Package renamePackage name p@Package{..} = p { packageName = name , packageExecutables = map (renameDependencies packageName name) packageExecutables , packageTests = map (renameDependencies packageName name) packageTests , packageBenchmarks = map (renameDependencies packageName name) packageBenchmarks } renameDependencies :: String -> String -> Section a -> Section a renameDependencies old new sect@Section{..} = sect {sectionDependencies = map rename sectionDependencies, sectionConditionals = map renameConditional sectionConditionals} where rename dep | dependencyName dep == old = dep {dependencyName = new} | otherwise = dep renameConditional :: Conditional -> Conditional renameConditional (Conditional condition then_ else_) = Conditional condition (renameDependencies old new then_) (renameDependencies old new <$> else_) packageDependencies :: Package -> [Dependency] packageDependencies Package{..} = nub . sortBy (comparing (lexicographically . dependencyName)) $ (concatMap sectionDependencies packageExecutables) ++ (concatMap sectionDependencies packageTests) ++ (concatMap sectionDependencies packageBenchmarks) ++ maybe [] sectionDependencies packageLibrary section :: a -> Section a section a = Section a [] [] [] [] [] [] [] [] [] [] [] [] [] Nothing [] [] packageConfig :: FilePath packageConfig = "package.yaml" githubBaseUrl :: String githubBaseUrl = "https://github.com/" genericParseJSON_ :: forall a. (Generic a, GFromJSON (Rep a), HasTypeName a) => Value -> Parser a genericParseJSON_ = genericParseJSON defaultOptions {fieldLabelModifier = hyphenize name} where name :: String name = typeName (Proxy :: Proxy a) hyphenize :: String -> String -> String hyphenize name = #if MIN_VERSION_aeson(0,10,0) camelTo2 #else camelTo #endif '-' . drop (length name) . dropWhile (== '_') type FieldName = String class HasFieldNames a where fieldNames :: Proxy a -> [FieldName] default fieldNames :: (HasTypeName a, Selectors (Rep a)) => Proxy a -> [String] fieldNames proxy = map (hyphenize $ typeName proxy) (selectors proxy) data CaptureUnknownFields a = CaptureUnknownFields { captureUnknownFieldsFields :: [FieldName] , captureUnknownFieldsValue :: a } deriving (Eq, Show, Generic) captureUnknownFields :: forall a. (HasFieldNames a, FromJSON a) => Value -> Parser (CaptureUnknownFields a) captureUnknownFields v = CaptureUnknownFields unknown <$> parseJSON v where unknown = getUnknownFields v (Proxy :: Proxy a) instance (HasFieldNames a, FromJSON a) => FromJSON (CaptureUnknownFields (Section a)) where parseJSON v = do (unknownFields, sect) <- toSection <$> parseJSON v <*> parseJSON v return (CaptureUnknownFields (unknownSectionFields ++ unknownFields) sect) where unknownSectionFields = getUnknownFields v (Proxy :: Proxy (Section a)) instance FromJSON (CaptureUnknownFields FlagSection) where parseJSON = captureUnknownFields getUnknownFields :: forall a. HasFieldNames a => Value -> Proxy a -> [FieldName] getUnknownFields v _ = case v of Object o -> unknown where unknown = keys \\ fields keys = map T.unpack (HashMap.keys o) fields = fieldNames (Proxy :: Proxy a) _ -> [] data LibrarySection = LibrarySection { librarySectionExposed :: Maybe Bool , librarySectionExposedModules :: Maybe (List String) , librarySectionOtherModules :: Maybe (List String) , librarySectionReexportedModules :: Maybe (List String) } deriving (Eq, Show, Generic) instance HasFieldNames LibrarySection instance FromJSON LibrarySection where parseJSON = genericParseJSON_ data ExecutableSection = ExecutableSection { executableSectionMain :: FilePath , executableSectionOtherModules :: Maybe (List String) } deriving (Eq, Show, Generic) instance HasFieldNames ExecutableSection instance FromJSON ExecutableSection where parseJSON = genericParseJSON_ data CommonOptions = CommonOptions { commonOptionsSourceDirs :: Maybe (List FilePath) , commonOptionsDependencies :: Maybe (List Dependency) , commonOptionsDefaultExtensions :: Maybe (List String) , commonOptionsOtherExtensions :: Maybe (List String) , commonOptionsGhcOptions :: Maybe (List GhcOption) , commonOptionsGhcProfOptions :: Maybe (List GhcProfOption) , commonOptionsCppOptions :: Maybe (List CppOption) , commonOptionsCSources :: Maybe (List FilePath) , commonOptionsExtraLibDirs :: Maybe (List FilePath) , commonOptionsExtraLibraries :: Maybe (List FilePath) , commonOptionsIncludeDirs :: Maybe (List FilePath) , commonOptionsInstallIncludes :: Maybe (List FilePath) , commonOptionsLdOptions :: Maybe (List LdOption) , commonOptionsBuildable :: Maybe Bool , commonOptionsWhen :: Maybe (List ConditionalSection) , commonOptionsBuildTools :: Maybe (List Dependency) } deriving (Eq, Show, Generic) instance HasFieldNames CommonOptions instance FromJSON CommonOptions where parseJSON = genericParseJSON_ data ConditionalSection = ThenElseConditional (CaptureUnknownFields ThenElse) | FlatConditional (CaptureUnknownFields (Section Condition)) deriving (Eq, Show) instance FromJSON ConditionalSection where parseJSON v | hasKey "then" v || hasKey "else" v = ThenElseConditional <$> parseJSON v | otherwise = FlatConditional <$> parseJSON v hasKey :: Text -> Value -> Bool hasKey key (Object o) = HashMap.member key o hasKey _ _ = False newtype Condition = Condition { conditionCondition :: String } deriving (Eq, Show, Generic) instance FromJSON Condition where parseJSON = genericParseJSON_ instance HasFieldNames Condition data ThenElse = ThenElse { _thenElseCondition :: String , _thenElseThen :: (CaptureUnknownFields (Section Empty)) , _thenElseElse :: (CaptureUnknownFields (Section Empty)) } deriving (Eq, Show, Generic) instance FromJSON (CaptureUnknownFields ThenElse) where parseJSON = captureUnknownFields instance HasFieldNames ThenElse instance FromJSON ThenElse where parseJSON = genericParseJSON_ data Empty = Empty deriving (Eq, Show) instance FromJSON Empty where parseJSON _ = return Empty instance HasFieldNames Empty where fieldNames _ = [] 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 , packageConfigLicenseFile :: Maybe String , packageConfigTestedWith :: Maybe String , packageConfigFlags :: Maybe (Map String (CaptureUnknownFields FlagSection)) , packageConfigExtraSourceFiles :: Maybe (List FilePath) , packageConfigDataFiles :: Maybe (List FilePath) , packageConfigGithub :: Maybe Text , packageConfigGit :: Maybe String , packageConfigLibrary :: Maybe (CaptureUnknownFields (Section LibrarySection)) , packageConfigExecutables :: Maybe (Map String (CaptureUnknownFields (Section ExecutableSection))) , packageConfigTests :: Maybe (Map String (CaptureUnknownFields (Section ExecutableSection))) , packageConfigBenchmarks :: Maybe (Map String (CaptureUnknownFields (Section ExecutableSection))) } deriving (Eq, Show, Generic) instance HasFieldNames PackageConfig 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 r <- decodeYaml file case r of Left err -> return (Left err) Right config -> do dir <- takeDirectory <$> canonicalizePath file Right <$> mkPackage dir config data Dependency = Dependency { dependencyName :: String , dependencyGitRef :: Maybe AddSource } deriving (Eq, Show, Ord, Generic) instance IsString Dependency where fromString name = Dependency name Nothing instance FromJSON Dependency where parseJSON v = case v of String _ -> fromString <$> parseJSON v Object o -> addSourceDependency o _ -> typeMismatch "String or an Object" v where addSourceDependency o = Dependency <$> name <*> (Just <$> (local <|> git)) where name :: Parser String name = o .: "name" local :: Parser AddSource local = Local <$> o .: "path" git :: Parser AddSource git = GitRef <$> url <*> ref <*> subdir url :: Parser String url = ((githubBaseUrl ++) <$> o .: "github") <|> (o .: "git") <|> fail "neither key \"git\" nor key \"github\" present" ref :: Parser String ref = o .: "ref" subdir :: Parser (Maybe FilePath) subdir = o .:? "subdir" data AddSource = GitRef GitUrl GitRef (Maybe FilePath) | Local FilePath deriving (Eq, Show, Ord) type GitUrl = String type GitRef = 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 , packageTestedWith :: Maybe String , packageFlags :: [Flag] , packageExtraSourceFiles :: [FilePath] , packageDataFiles :: [FilePath] , packageSourceRepository :: Maybe SourceRepository , packageLibrary :: Maybe (Section Library) , packageExecutables :: [Section Executable] , packageTests :: [Section Executable] , packageBenchmarks :: [Section Executable] } deriving (Eq, Show) data Library = Library { libraryExposed :: Maybe Bool , libraryExposedModules :: [String] , libraryOtherModules :: [String] , libraryReexportedModules :: [String] } deriving (Eq, Show) data Executable = Executable { executableName :: String , executableMain :: FilePath , executableOtherModules :: [String] } deriving (Eq, Show) data Section a = Section { sectionData :: a , sectionSourceDirs :: [FilePath] , sectionDependencies :: [Dependency] , sectionDefaultExtensions :: [String] , sectionOtherExtensions :: [String] , sectionGhcOptions :: [GhcOption] , sectionGhcProfOptions :: [GhcProfOption] , sectionCppOptions :: [CppOption] , sectionCSources :: [FilePath] , sectionExtraLibDirs :: [FilePath] , sectionExtraLibraries :: [FilePath] , sectionIncludeDirs :: [FilePath] , sectionInstallIncludes :: [FilePath] , sectionLdOptions :: [LdOption] , sectionBuildable :: Maybe Bool , sectionConditionals :: [Conditional] , sectionBuildTools :: [Dependency] } deriving (Eq, Show, Functor, Foldable, Traversable) data Conditional = Conditional { conditionalCondition :: String , conditionalThen :: Section () , conditionalElse :: Maybe (Section ()) } deriving (Eq, Show) instance HasFieldNames a => HasFieldNames (Section a) where fieldNames Proxy = fieldNames (Proxy :: Proxy a) ++ fieldNames (Proxy :: Proxy CommonOptions) data FlagSection = FlagSection { _flagSectionDescription :: Maybe String , _flagSectionManual :: Bool , _flagSectionDefault :: Bool } deriving (Eq, Show, Generic) instance HasFieldNames FlagSection instance FromJSON FlagSection where parseJSON = genericParseJSON_ data Flag = Flag { flagName :: String , flagDescription :: Maybe String , flagManual :: Bool , flagDefault :: Bool } deriving (Eq, Show) toFlag :: (String, FlagSection) -> Flag toFlag (name, FlagSection description manual def) = Flag name description manual def data SourceRepository = SourceRepository { sourceRepositoryUrl :: String , sourceRepositorySubdir :: Maybe String } deriving (Eq, Show) mkPackage :: FilePath -> (CaptureUnknownFields (Section PackageConfig)) -> IO ([String], Package) mkPackage dir (CaptureUnknownFields unknownFields globalOptions@Section{sectionData = PackageConfig{..}}) = do let name = fromMaybe (takeBaseName dir) packageConfigName mLibrary <- mapM (toLibrary dir name globalOptions) mLibrarySection executables <- toExecutables dir globalOptions (map (fmap captureUnknownFieldsValue) executableSections) tests <- toExecutables dir globalOptions (map (fmap captureUnknownFieldsValue) testsSections) benchmarks <- toExecutables dir globalOptions (map (fmap captureUnknownFieldsValue) benchmarkSections) licenseFileExists <- doesFileExist (dir "LICENSE") missingSourceDirs <- nub . sort <$> filterM (fmap not <$> doesDirectoryExist . (dir )) ( maybe [] sectionSourceDirs mLibrary ++ concatMap sectionSourceDirs executables ++ concatMap sectionSourceDirs tests ++ concatMap sectionSourceDirs benchmarks ) (extraSourceFilesWarnings, extraSourceFiles) <- expandGlobs dir (fromMaybeList packageConfigExtraSourceFiles) (dataFilesWarnings, dataFiles) <- expandGlobs dir (fromMaybeList packageConfigDataFiles) let pkg = 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 = packageConfigLicenseFile <|> (guard licenseFileExists >> Just "LICENSE") , packageTestedWith = packageConfigTestedWith , packageFlags = flags , packageExtraSourceFiles = extraSourceFiles , packageDataFiles = dataFiles , packageSourceRepository = sourceRepository , packageLibrary = mLibrary , packageExecutables = executables , packageTests = tests , packageBenchmarks = benchmarks } warnings = formatUnknownFields "package description" unknownFields ++ flagWarnings ++ maybe [] (formatUnknownFields "library section") (captureUnknownFieldsFields <$> packageConfigLibrary) ++ formatUnknownSectionFields "executable" executableSections ++ formatUnknownSectionFields "test" testsSections ++ formatMissingSourceDirs missingSourceDirs ++ extraSourceFilesWarnings ++ dataFilesWarnings return (warnings, pkg) where executableSections :: [(String, CaptureUnknownFields (Section ExecutableSection))] executableSections = toList packageConfigExecutables testsSections :: [(String, CaptureUnknownFields (Section ExecutableSection))] testsSections = toList packageConfigTests benchmarkSections :: [(String, CaptureUnknownFields (Section ExecutableSection))] benchmarkSections = toList packageConfigBenchmarks (flagWarnings, flags) = (concatMap formatUnknownFlagFields xs, map (toFlag . fmap captureUnknownFieldsValue) xs) where xs :: [(String, CaptureUnknownFields FlagSection)] xs = toList packageConfigFlags formatUnknownFlagFields :: (String, CaptureUnknownFields a) -> [String] formatUnknownFlagFields (name, fields) = map f (captureUnknownFieldsFields fields) where f field = "Ignoring unknown field " ++ show field ++ " for flag " ++ show name toList :: Maybe (Map String a) -> [(String, a)] toList = Map.toList . fromMaybe mempty mLibrarySection :: Maybe (Section LibrarySection) mLibrarySection = captureUnknownFieldsValue <$> packageConfigLibrary formatUnknownFields :: String -> [FieldName] -> [String] formatUnknownFields name = map f . sort where f field = "Ignoring unknown field " ++ show field ++ " in " ++ name formatUnknownSectionFields :: String -> [(String, CaptureUnknownFields a)] -> [String] formatUnknownSectionFields sectionType = concatMap f . map (fmap captureUnknownFieldsFields) where f :: (String, [String]) -> [String] f (sect, fields) = formatUnknownFields (sectionType ++ " section " ++ show sect) fields formatMissingSourceDirs = map f where f name = "Specified source-dir " ++ show name ++ " does not exist" sourceRepository :: Maybe SourceRepository sourceRepository = github <|> (`SourceRepository` Nothing) <$> packageConfigGit github :: Maybe SourceRepository github = 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 <$> github bugReports :: Maybe String bugReports = case packageConfigBugReports of Just Nothing -> Nothing _ -> join packageConfigBugReports <|> fromGithub where fromGithub = (++ "/issues") . sourceRepositoryUrl <$> github toLibrary :: FilePath -> String -> Section global -> Section LibrarySection -> IO (Section Library) toLibrary dir name globalOptions library = traverse fromLibrarySection sect where sect :: Section LibrarySection sect = mergeSections globalOptions library sourceDirs :: [FilePath] sourceDirs = sectionSourceDirs sect fromLibrarySection :: LibrarySection -> IO Library fromLibrarySection LibrarySection{..} = do modules <- concat <$> mapM (getModules dir) sourceDirs let (exposedModules, otherModules) = determineModules name modules librarySectionExposedModules librarySectionOtherModules reexportedModules = fromMaybeList librarySectionReexportedModules return (Library librarySectionExposed exposedModules otherModules reexportedModules) toExecutables :: FilePath -> Section global -> [(String, Section ExecutableSection)] -> IO [Section Executable] toExecutables dir globalOptions executables = mapM toExecutable sections where sections :: [(String, Section ExecutableSection)] sections = map (fmap $ mergeSections globalOptions) executables toExecutable :: (String, Section ExecutableSection) -> IO (Section Executable) toExecutable (name, sect@Section{..}) = do (executable, ghcOptions) <- fromExecutableSection sectionData return (sect {sectionData = executable, sectionGhcOptions = sectionGhcOptions ++ ghcOptions}) where fromExecutableSection :: ExecutableSection -> IO (Executable, [GhcOption]) fromExecutableSection ExecutableSection{..} = do modules <- maybe (filterMain . concat <$> mapM (getModules dir) sectionSourceDirs) (return . fromList) executableSectionOtherModules return (Executable name mainSrcFile modules, ghcOptions) where filterMain :: [String] -> [String] filterMain = maybe id (filter . (/=)) (toModule $ splitDirectories executableSectionMain) (mainSrcFile, ghcOptions) = parseMain executableSectionMain mergeSections :: Section global -> Section a -> Section a mergeSections globalOptions options = Section { sectionData = sectionData options , sectionSourceDirs = sectionSourceDirs globalOptions ++ sectionSourceDirs options , sectionDefaultExtensions = sectionDefaultExtensions globalOptions ++ sectionDefaultExtensions options , sectionOtherExtensions = sectionOtherExtensions globalOptions ++ sectionOtherExtensions options , sectionGhcOptions = sectionGhcOptions globalOptions ++ sectionGhcOptions options , sectionGhcProfOptions = sectionGhcProfOptions globalOptions ++ sectionGhcProfOptions options , sectionCppOptions = sectionCppOptions globalOptions ++ sectionCppOptions options , sectionCSources = sectionCSources globalOptions ++ sectionCSources options , sectionExtraLibDirs = sectionExtraLibDirs globalOptions ++ sectionExtraLibDirs options , sectionExtraLibraries = sectionExtraLibraries globalOptions ++ sectionExtraLibraries options , sectionIncludeDirs = sectionIncludeDirs globalOptions ++ sectionIncludeDirs options , sectionInstallIncludes = sectionInstallIncludes globalOptions ++ sectionInstallIncludes options , sectionLdOptions = sectionLdOptions globalOptions ++ sectionLdOptions options , sectionBuildable = sectionBuildable options <|> sectionBuildable globalOptions , sectionDependencies = sectionDependencies globalOptions ++ sectionDependencies options , sectionConditionals = sectionConditionals globalOptions ++ sectionConditionals options , sectionBuildTools = sectionBuildTools globalOptions ++ sectionBuildTools options } toSection :: a -> CommonOptions -> ([FieldName], Section a) toSection a CommonOptions{..} = ( concat unknownFields , Section { sectionData = a , sectionSourceDirs = fromMaybeList commonOptionsSourceDirs , sectionDefaultExtensions = fromMaybeList commonOptionsDefaultExtensions , sectionOtherExtensions = fromMaybeList commonOptionsOtherExtensions , sectionGhcOptions = fromMaybeList commonOptionsGhcOptions , sectionGhcProfOptions = fromMaybeList commonOptionsGhcProfOptions , sectionCppOptions = fromMaybeList commonOptionsCppOptions , sectionCSources = fromMaybeList commonOptionsCSources , sectionExtraLibDirs = fromMaybeList commonOptionsExtraLibDirs , sectionExtraLibraries = fromMaybeList commonOptionsExtraLibraries , sectionIncludeDirs = fromMaybeList commonOptionsIncludeDirs , sectionInstallIncludes = fromMaybeList commonOptionsInstallIncludes , sectionLdOptions = fromMaybeList commonOptionsLdOptions , sectionBuildable = commonOptionsBuildable , sectionDependencies = fromMaybeList commonOptionsDependencies , sectionConditionals = conditionals , sectionBuildTools = fromMaybeList commonOptionsBuildTools } ) where (unknownFields, conditionals) = unzip (map toConditional $ fromMaybeList commonOptionsWhen) toConditional :: ConditionalSection -> ([FieldName], Conditional) toConditional x = case x of ThenElseConditional (CaptureUnknownFields fields (ThenElse condition (CaptureUnknownFields fieldsThen then_) (CaptureUnknownFields fieldsElse else_))) -> (fields ++ fieldsThen ++ fieldsElse, Conditional condition (() <$ then_) (Just (() <$ else_))) FlatConditional (CaptureUnknownFields fields sect) -> (fields, Conditional (conditionCondition $ sectionData sect) (() <$ sect) Nothing) pathsModuleFromPackageName :: String -> String pathsModuleFromPackageName name = "Paths_" ++ map f name where f '-' = '_' f x = x determineModules :: String -> [String] -> Maybe (List String) -> Maybe (List String) -> ([String], [String]) determineModules name modules mExposedModules mOtherModules = case (mExposedModules, mOtherModules) of (Nothing, Nothing) -> (modules, []) _ -> (exposedModules, otherModules) where otherModules = maybe ((modules \\ exposedModules) ++ pathsModule) fromList mOtherModules exposedModules = maybe (modules \\ otherModules) fromList mExposedModules pathsModule = [pathsModuleFromPackageName name] \\ exposedModules getModules :: FilePath -> FilePath -> IO [String] getModules dir src_ = sort <$> do exists <- doesDirectoryExist (dir src_) if exists then do src <- canonicalizePath (dir src_) removeSetup src . toModules <$> getFilesRecursive src else return [] where toModules :: [[FilePath]] -> [String] toModules = catMaybes . map toModule removeSetup :: FilePath -> [String] -> [String] removeSetup src | src == dir = filter (/= "Setup") | otherwise = id fromMaybeList :: Maybe (List a) -> [a] fromMaybeList = maybe [] fromList hpack-0.14.1/src/Hpack/Run.hs0000644000000000000000000002266412714052040013773 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE CPP #-} module Hpack.Run ( run , renderPackage , RenderSettings(..) , Alignment(..) , CommaStyle(..) , defaultRenderSettings #ifdef TEST , renderConditional , renderFlag , renderSourceRepository , formatDescription #endif ) where import Prelude () import Prelude.Compat import Control.Monad import Data.Char import Data.Maybe import Data.List.Compat import System.Exit.Compat import System.FilePath import Hpack.Util import Hpack.Config import Hpack.Render import Hpack.FormattingHints run :: FilePath -> IO ([String], FilePath, String) run dir = do mPackage <- readPackageConfig (dir packageConfig) case mPackage of Right (warnings, pkg) -> do let cabalFile = dir (packageName pkg ++ ".cabal") old <- tryReadFile cabalFile let FormattingHints{..} = sniffFormattingHints (fromMaybe "" old) alignment = fromMaybe 16 formattingHintsAlignment settings = formattingHintsRenderSettings output = renderPackage settings alignment formattingHintsFieldOrder formattingHintsSectionsFieldOrder pkg return (warnings, cabalFile, output) Left err -> die err renderPackage :: RenderSettings -> Alignment -> [String] -> [(String, [String])] -> Package -> String renderPackage settings alignment existingFieldOrder sectionsFieldOrder Package{..} = intercalate "\n" (unlines header : chunks) where chunks :: [String] chunks = map unlines . filter (not . null) . map (render settings 0) $ sortSectionFields sectionsFieldOrder stanzas header :: [String] header = concatMap (render settings {renderSettingsFieldAlignment = alignment} 0) fields extraSourceFiles :: Element extraSourceFiles = Field "extra-source-files" (LineSeparatedList packageExtraSourceFiles) dataFiles :: Element dataFiles = Field "data-files" (LineSeparatedList packageDataFiles) sourceRepository = maybe [] (return . renderSourceRepository) packageSourceRepository library = maybe [] (return . renderLibrary) packageLibrary stanzas :: [Element] stanzas = extraSourceFiles : dataFiles : sourceRepository ++ concat [ map renderFlag packageFlags , library , renderExecutables packageExecutables , renderTests packageTests , renderBenchmarks packageBenchmarks ] fields :: [Element] fields = sortFieldsBy existingFieldOrder . mapMaybe (\(name, value) -> Field name . Literal <$> value) $ [ ("name", Just packageName) , ("version", Just packageVersion) , ("synopsis", packageSynopsis) , ("description", (formatDescription alignment <$> packageDescription)) , ("category", packageCategory) , ("stability", packageStability) , ("homepage", packageHomepage) , ("bug-reports", packageBugReports) , ("author", formatList packageAuthor) , ("maintainer", formatList packageMaintainer) , ("copyright", formatList packageCopyright) , ("license", packageLicense) , ("license-file", packageLicenseFile) , ("tested-with", packageTestedWith) , ("build-type", Just "Simple") , ("cabal-version", cabalVersion) ] formatList :: [String] -> Maybe String formatList xs = guard (not $ null xs) >> (Just $ intercalate separator xs) where separator = let Alignment n = alignment in ",\n" ++ replicate n ' ' cabalVersion :: Maybe String cabalVersion = maximum [ Just ">= 1.10" , packageLibrary >>= libCabalVersion ] where libCabalVersion :: Section Library -> Maybe String libCabalVersion sect = ">= 1.21" <$ guard (hasReexportedModules sect) hasReexportedModules :: Section Library -> Bool hasReexportedModules = not . null . libraryReexportedModules . sectionData sortSectionFields :: [(String, [String])] -> [Element] -> [Element] sortSectionFields sectionsFieldOrder = go where go sections = case sections of [] -> [] Stanza name fields : xs | Just fieldOrder <- lookup name sectionsFieldOrder -> Stanza name (sortFieldsBy fieldOrder fields) : go xs x : xs -> x : go xs formatDescription :: Alignment -> String -> String formatDescription (Alignment alignment) description = case map emptyLineToDot $ lines description of x : xs -> intercalate "\n" (x : map (indentation ++) xs) [] -> "" where n = max alignment (length ("description: " :: String)) indentation = replicate n ' ' emptyLineToDot xs | isEmptyLine xs = "." | otherwise = xs isEmptyLine = all isSpace renderSourceRepository :: SourceRepository -> Element renderSourceRepository SourceRepository{..} = Stanza "source-repository head" [ Field "type" "git" , Field "location" (Literal sourceRepositoryUrl) , Field "subdir" (maybe "" Literal sourceRepositorySubdir) ] renderFlag :: Flag -> Element renderFlag Flag {..} = Stanza ("flag " ++ flagName) $ description ++ [ Field "manual" (Literal $ show flagManual) , Field "default" (Literal $ show flagDefault) ] where description = maybe [] (return . Field "description" . Literal) flagDescription renderExecutables :: [Section Executable] -> [Element] renderExecutables = map renderExecutable renderExecutable :: Section Executable -> Element renderExecutable sect@(sectionData -> Executable{..}) = Stanza ("executable " ++ executableName) (renderExecutableSection sect) renderTests :: [Section Executable] -> [Element] renderTests = map renderTest renderTest :: Section Executable -> Element renderTest sect@(sectionData -> Executable{..}) = Stanza ("test-suite " ++ executableName) (Field "type" "exitcode-stdio-1.0" : renderExecutableSection sect) renderBenchmarks :: [Section Executable] -> [Element] renderBenchmarks = map renderBenchmark renderBenchmark :: Section Executable -> Element renderBenchmark sect@(sectionData -> Executable{..}) = Stanza ("benchmark " ++ executableName) (Field "type" "exitcode-stdio-1.0" : renderExecutableSection sect) renderExecutableSection :: Section Executable -> [Element] renderExecutableSection sect@(sectionData -> Executable{..}) = mainIs : renderSection sect ++ [otherModules, defaultLanguage] where mainIs = Field "main-is" (Literal executableMain) otherModules = renderOtherModules executableOtherModules renderLibrary :: Section Library -> Element renderLibrary sect@(sectionData -> Library{..}) = Stanza "library" $ renderSection sect ++ maybe [] (return . renderExposed) libraryExposed ++ [ renderExposedModules libraryExposedModules , renderOtherModules libraryOtherModules , renderReexportedModules libraryReexportedModules , defaultLanguage ] renderExposed :: Bool -> Element renderExposed = Field "exposed" . Literal . show renderSection :: Section a -> [Element] renderSection Section{..} = [ renderSourceDirs sectionSourceDirs , renderDefaultExtensions sectionDefaultExtensions , renderOtherExtensions sectionOtherExtensions , renderGhcOptions sectionGhcOptions , renderGhcProfOptions sectionGhcProfOptions , renderCppOptions sectionCppOptions , Field "include-dirs" (LineSeparatedList sectionIncludeDirs) , Field "install-includes" (LineSeparatedList sectionInstallIncludes) , Field "c-sources" (LineSeparatedList sectionCSources) , Field "extra-lib-dirs" (LineSeparatedList sectionExtraLibDirs) , Field "extra-libraries" (LineSeparatedList sectionExtraLibraries) , renderLdOptions sectionLdOptions , renderDependencies sectionDependencies , renderBuildTools sectionBuildTools ] ++ maybe [] (return . renderBuildable) sectionBuildable ++ map renderConditional sectionConditionals renderConditional :: Conditional -> Element renderConditional (Conditional condition sect mElse) = case mElse of Nothing -> if_ Just else_ -> Group if_ (Stanza "else" $ renderSection else_) where if_ = Stanza ("if " ++ condition) (renderSection sect) defaultLanguage :: Element defaultLanguage = Field "default-language" "Haskell2010" renderSourceDirs :: [String] -> Element renderSourceDirs = Field "hs-source-dirs" . CommaSeparatedList renderExposedModules :: [String] -> Element renderExposedModules = Field "exposed-modules" . LineSeparatedList renderOtherModules :: [String] -> Element renderOtherModules = Field "other-modules" . LineSeparatedList renderReexportedModules :: [String] -> Element renderReexportedModules = Field "reexported-modules" . LineSeparatedList renderDependencies :: [Dependency] -> Element renderDependencies = Field "build-depends" . CommaSeparatedList . map dependencyName renderGhcOptions :: [GhcOption] -> Element renderGhcOptions = Field "ghc-options" . WordList renderGhcProfOptions :: [GhcProfOption] -> Element renderGhcProfOptions = Field "ghc-prof-options" . WordList renderCppOptions :: [CppOption] -> Element renderCppOptions = Field "cpp-options" . WordList renderLdOptions :: [LdOption] -> Element renderLdOptions = Field "ld-options" . WordList renderBuildable :: Bool -> Element renderBuildable = Field "buildable" . Literal . show renderDefaultExtensions :: [String] -> Element renderDefaultExtensions = Field "default-extensions" . WordList renderOtherExtensions :: [String] -> Element renderOtherExtensions = Field "other-extensions" . WordList renderBuildTools :: [Dependency] -> Element renderBuildTools = Field "build-tools" . CommaSeparatedList . map dependencyName hpack-0.14.1/src/Hpack/Yaml.hs0000644000000000000000000000114612601277064014133 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} module Hpack.Yaml where import Data.Yaml decodeYaml :: FromJSON a => FilePath -> IO (Either String a) decodeYaml file = do result <- decodeFileEither file return $ either (Left . errToString) Right result 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 hpack-0.14.1/src/Hpack/FormattingHints.hs0000644000000000000000000000741312706324120016344 0ustar0000000000000000{-# 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) hpack-0.14.1/src/Hpack/GenericsUtil.hs0000644000000000000000000000242612726536046015636 0ustar0000000000000000{-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Hpack.GenericsUtil ( HasTypeName , typeName , Selectors , selectors ) where import Data.Proxy import GHC.Generics class HasTypeName a where typeName :: Proxy a -> String instance (Datatype d, Generic a, Rep a ~ M1 D d m) => HasTypeName a where typeName _ = datatypeName (undefined :: M1 D d x y) selectors :: (Selectors (Rep a)) => Proxy a -> [String] selectors = f where f :: forall a. (Selectors (Rep a)) => Proxy a -> [String] f _ = selNames (Proxy :: Proxy (Rep a)) class Selectors a where selNames :: Proxy a -> [String] instance Selectors f => Selectors (M1 D x f) where selNames _ = selNames (Proxy :: Proxy f) instance Selectors f => Selectors (M1 C x f) where selNames _ = selNames (Proxy :: Proxy f) instance Selector s => Selectors (M1 S s (K1 R t)) where selNames _ = [selName (undefined :: M1 S s (K1 R t) ())] instance (Selectors a, Selectors b) => Selectors (a :*: b) where selNames _ = selNames (Proxy :: Proxy a) ++ selNames (Proxy :: Proxy b) instance Selectors U1 where selNames _ = [] hpack-0.14.1/src/Hpack/Haskell.hs0000644000000000000000000000174512551635302014616 0ustar0000000000000000module Hpack.Haskell ( isModule , isQualifiedIdentifier , isIdentifier ) where import Data.Char isModule :: [String] -> Bool isModule name = (not . null) name && all isModuleName name isModuleName :: String -> Bool isModuleName name = case name of x : xs -> isUpper x && all isIdChar xs _ -> False isQualifiedIdentifier :: [String] -> Bool isQualifiedIdentifier name = case reverse name of x : xs -> isIdentifier x && isModule xs _ -> False isIdentifier :: String -> Bool isIdentifier name = case name of x : xs -> isLower x && all isIdChar xs && name `notElem` reserved _ -> False reserved :: [String] reserved = [ "case" , "class" , "data" , "default" , "deriving" , "do" , "else" , "foreign" , "if" , "import" , "in" , "infix" , "infixl" , "infixr" , "instance" , "let" , "module" , "newtype" , "of" , "then" , "type" , "where" , "_" ] isIdChar :: Char -> Bool isIdChar c = isAlphaNum c || c == '_' || c == '\'' hpack-0.14.1/src/Hpack/Render.hs0000644000000000000000000001026512706324120014442 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# 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 Data.String import Data.List.Compat data Value = Literal String | CommaSeparatedList [String] | LineSeparatedList [String] | WordList [String] deriving (Eq, Show) data Element = Stanza String [Element] | Group Element Element | Field String Value deriving (Eq, Show) data Lines = SingleLine String | MultipleLines [String] deriving (Eq, Show) data CommaStyle = LeadingCommas | TrailingCommas deriving (Eq, Show) newtype Nesting = Nesting Int deriving (Eq, Show, Num, Enum) newtype Alignment = Alignment Int deriving (Eq, Show, Num) data RenderSettings = RenderSettings { renderSettingsIndentation :: Int , renderSettingsFieldAlignment :: Alignment , renderSettingsCommaStyle :: CommaStyle } deriving (Eq, Show) defaultRenderSettings :: RenderSettings defaultRenderSettings = RenderSettings 2 0 LeadingCommas render :: RenderSettings -> Nesting -> Element -> [String] render settings nesting (Stanza name elements) = indent settings nesting name : renderElements settings (succ nesting) elements render settings nesting (Group a b) = render settings nesting a ++ render settings nesting b render settings nesting (Field name value) = renderField settings nesting name value renderElements :: RenderSettings -> Nesting -> [Element] -> [String] renderElements settings nesting = concatMap (render settings nesting) renderField :: RenderSettings -> Nesting -> String -> Value -> [String] renderField settings@RenderSettings{..} nesting name value = case renderValue settings value of SingleLine "" -> [] SingleLine x -> [indent settings nesting (name ++ ": " ++ padding ++ x)] MultipleLines [] -> [] MultipleLines xs -> (indent settings nesting name ++ ":") : map (indent settings $ succ nesting) xs where Alignment fieldAlignment = renderSettingsFieldAlignment padding = replicate (fieldAlignment - length name - 2) ' ' renderValue :: RenderSettings -> Value -> Lines renderValue RenderSettings{..} v = case v of Literal s -> SingleLine s WordList ws -> SingleLine $ unwords ws LineSeparatedList xs -> renderLineSeparatedList renderSettingsCommaStyle xs CommaSeparatedList xs -> renderCommaSeparatedList renderSettingsCommaStyle xs renderLineSeparatedList :: CommaStyle -> [String] -> Lines renderLineSeparatedList style = MultipleLines . map (padding ++) where padding = case style of LeadingCommas -> " " TrailingCommas -> "" renderCommaSeparatedList :: CommaStyle -> [String] -> Lines renderCommaSeparatedList style = MultipleLines . case style of LeadingCommas -> map renderLeadingComma . zip (True : repeat False) TrailingCommas -> map renderTrailingComma . reverse . zip (True : repeat False) . reverse where renderLeadingComma :: (Bool, String) -> String renderLeadingComma (isFirst, x) | isFirst = " " ++ x | otherwise = ", " ++ x renderTrailingComma :: (Bool, String) -> String renderTrailingComma (isLast, x) | isLast = x | otherwise = x ++ "," instance IsString Value where fromString = Literal indent :: RenderSettings -> Nesting -> String -> String indent RenderSettings{..} (Nesting nesting) s = replicate (nesting * renderSettingsIndentation) ' ' ++ s sortFieldsBy :: [String] -> [Element] -> [Element] sortFieldsBy existingFieldOrder = map snd . sortOn fst . addSortKey . map (\a -> (existingIndex a, a)) where existingIndex :: Element -> Maybe Int existingIndex (Field name _) = name `elemIndex` existingFieldOrder existingIndex _ = Nothing addSortKey :: [(Maybe Int, a)] -> [((Int, Int), a)] addSortKey = go (-1) . zip [0..] where go :: Int -> [(Int, (Maybe Int, a))] -> [((Int, Int), a)] go n xs = case xs of [] -> [] (x, (Just y, a)) : ys -> ((y, x), a) : go y ys (x, (Nothing, a)) : ys -> ((n, x), a) : go n ys hpack-0.14.1/src/Hpack/Util.hs0000644000000000000000000000730112706324120014135 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} module Hpack.Util ( List(..) , GhcOption , GhcProfOption , CppOption , LdOption , parseMain , toModule , getFilesRecursive , tryReadFile , expandGlobs , sort , lexicographically ) where import Prelude () import Prelude.Compat import Control.Applicative import Control.DeepSeq import Control.Exception import Control.Monad.Compat import Data.Aeson.Types import Data.Char import Data.Data import Data.List.Compat hiding (sort) import Data.Ord import System.Directory import System.FilePath import qualified System.FilePath.Posix as Posix import System.FilePath.Glob import Hpack.Haskell sort :: [String] -> [String] sort = sortBy (comparing lexicographically) lexicographically :: String -> (String, String) lexicographically x = (map toLower x, x) newtype List a = List {fromList :: [a]} deriving (Eq, Show, Data, Typeable) instance FromJSON a => FromJSON (List a) where parseJSON v = List <$> case v of Array _ -> parseJSON v _ -> return <$> parseJSON v type GhcOption = String type GhcProfOption = String type CppOption = String type LdOption = String parseMain :: String -> (FilePath, [GhcOption]) parseMain main = case reverse name of x : _ | isQualifiedIdentifier name && x `notElem` ["hs", "lhs"] -> (intercalate "/" (init name) ++ ".hs", ["-main-is " ++ main]) _ | isModule name -> (intercalate "/" name ++ ".hs", ["-main-is " ++ main]) _ -> (main, []) where name = splitOn '.' main splitOn :: Char -> String -> [String] splitOn c = go where go xs = case break (== c) xs of (ys, "") -> [ys] (ys, _:zs) -> ys : go zs 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 (isModule name) >> return (intercalate "." name) where stripSuffix :: String -> String -> Maybe String stripSuffix suffix x = reverse <$> stripPrefix (reverse suffix) (reverse x) getFilesRecursive :: FilePath -> IO [[String]] getFilesRecursive baseDir = 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 toPosixFilePath :: FilePath -> FilePath toPosixFilePath = Posix.joinPath . splitDirectories expandGlobs :: FilePath -> [String] -> IO ([String], [FilePath]) expandGlobs dir patterns = do files <- (fst <$> globDir compiledPatterns dir) >>= mapM removeDirectories let warnings = [warn pattern | ([], pattern) <- zip files patterns] return (warnings, combineResults files) where combineResults = nub . sort . map (toPosixFilePath . makeRelative dir) . concat warn pattern = "Specified pattern " ++ show pattern ++ " for extra-source-files does not match any files" compiledPatterns = map (compileWith options) patterns removeDirectories = filterM doesFileExist options = CompOptions { characterClasses = False , characterRanges = False , numberRanges = False , wildcards = True , recursiveWildcards = True , pathSepInRanges = False , errorRecovery = True } hpack-0.14.1/driver/Main.hs0000644000000000000000000000012212662640632013566 0ustar0000000000000000module Main (main) where import qualified Hpack main :: IO () main = Hpack.main hpack-0.14.1/test/Spec.hs0000644000000000000000000000005412515475744013273 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} hpack-0.14.1/test/Helper.hs0000644000000000000000000000147612726536046013626 0ustar0000000000000000module Helper ( module Test.Hspec , module Test.Mockery.Directory , module Control.Applicative , withTempDirectory , module System.FilePath , withCurrentDirectory ) where import Test.Hspec import Test.Mockery.Directory import Control.Applicative import System.Directory (getCurrentDirectory, setCurrentDirectory, canonicalizePath) import Control.Exception import qualified System.IO.Temp as Temp import System.FilePath withCurrentDirectory :: FilePath -> IO a -> IO a withCurrentDirectory dir action = do bracket getCurrentDirectory setCurrentDirectory $ \ _ -> do setCurrentDirectory dir action withTempDirectory :: (FilePath -> IO a) -> IO a withTempDirectory action = Temp.withSystemTempDirectory "hspec" $ \dir -> do canonicalizePath dir >>= action hpack-0.14.1/test/Hpack/ConfigSpec.hs0000644000000000000000000010045412714052040015431 0ustar0000000000000000{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} module Hpack.ConfigSpec ( spec , package , executable , library ) where import Helper import Data.Aeson.QQ import Data.Aeson.Types import Data.String.Interpolate.IsString import Control.Arrow import System.Directory (createDirectory) import Data.Yaml import Data.Either.Compat import Hpack.Util import Hpack.Config hiding (package) import qualified Hpack.Config as Config package :: Package package = Config.package "foo" "0.0.0" executable :: String -> String -> Executable executable name main_ = Executable name main_ [] library :: Library library = Library Nothing [] [] [] withPackage :: String -> IO () -> (([String], Package) -> Expectation) -> Expectation withPackage content beforeAction expectation = withTempDirectory $ \dir_ -> do let dir = dir_ "foo" createDirectory dir writeFile (dir "package.yaml") content withCurrentDirectory dir beforeAction r <- readPackageConfig (dir "package.yaml") either expectationFailure expectation r withPackageConfig :: String -> IO () -> (Package -> Expectation) -> Expectation withPackageConfig content beforeAction expectation = withPackage content beforeAction (expectation . snd) withPackageConfig_ :: String -> (Package -> Expectation) -> Expectation withPackageConfig_ content = withPackageConfig content (return ()) withPackageWarnings :: String -> IO () -> ([String] -> Expectation) -> Expectation withPackageWarnings content beforeAction expectation = withPackage content beforeAction (expectation . fst) withPackageWarnings_ :: String -> ([String] -> Expectation) -> Expectation withPackageWarnings_ content = withPackageWarnings content (return ()) spec :: Spec spec = do describe "renamePackage" $ do it "renames a package" $ do renamePackage "bar" package `shouldBe` package {packageName = "bar"} it "renames dependencies on self" $ do let packageWithExecutable dependencies = package {packageExecutables = [(section $ executable "main" "Main.hs") {sectionDependencies = dependencies}]} renamePackage "bar" (packageWithExecutable ["foo"]) `shouldBe` (packageWithExecutable ["bar"]) {packageName = "bar"} describe "renameDependencies" $ do let sectionWithDeps dependencies = (section ()) {sectionDependencies = dependencies} it "renames dependencies" $ do renameDependencies "bar" "baz" (sectionWithDeps ["foo", "bar"]) `shouldBe` sectionWithDeps ["foo", "baz"] it "renames dependency in conditionals" $ do let sectionWithConditional dependencies = (section ()) { sectionConditionals = [ Conditional { conditionalCondition = "some condition" , conditionalThen = sectionWithDeps dependencies , conditionalElse = Just (sectionWithDeps dependencies) } ] } renameDependencies "bar" "baz" (sectionWithConditional ["foo", "bar"]) `shouldBe` sectionWithConditional ["foo", "baz"] describe "parseJSON" $ do context "when parsing (CaptureUnknownFields Section a)" $ do it "accepts dependencies" $ do let input = [i| dependencies: hpack |] captureUnknownFieldsValue <$> decodeEither input `shouldBe` Right (section Empty){sectionDependencies = ["hpack"]} it "accepts includes-dirs" $ do let input = [i| include-dirs: - foo - bar |] captureUnknownFieldsValue <$> decodeEither input `shouldBe` Right (section Empty){sectionIncludeDirs = ["foo", "bar"]} it "accepts install-includes" $ do let input = [i| install-includes: - foo.h - bar.h |] captureUnknownFieldsValue <$> decodeEither input `shouldBe` Right (section Empty){sectionInstallIncludes = ["foo.h", "bar.h"]} it "accepts c-sources" $ do let input = [i| c-sources: - foo.c - bar.c |] captureUnknownFieldsValue <$> decodeEither input `shouldBe` Right (section Empty){sectionCSources = ["foo.c", "bar.c"]} it "accepts extra-lib-dirs" $ do let input = [i| extra-lib-dirs: - foo - bar |] captureUnknownFieldsValue <$> decodeEither input `shouldBe` Right (section Empty){sectionExtraLibDirs = ["foo", "bar"]} it "accepts extra-libraries" $ do let input = [i| extra-libraries: - foo - bar |] captureUnknownFieldsValue <$> decodeEither input `shouldBe` Right (section Empty){sectionExtraLibraries = ["foo", "bar"]} context "when parsing conditionals" $ do it "accepts conditionals" $ do let input = [i| when: condition: os(windows) dependencies: Win32 |] conditionals = [ Conditional "os(windows)" (section ()){sectionDependencies = ["Win32"]} Nothing ] captureUnknownFieldsValue <$> decodeEither input `shouldBe` Right (section Empty){sectionConditionals = conditionals} it "warns on unknown fields" $ do let input = [i| foo: 23 when: - condition: os(windows) bar: 23 when: condition: os(windows) bar2: 23 - condition: os(windows) baz: 23 |] captureUnknownFieldsFields <$> (decodeEither input :: Either String (CaptureUnknownFields (Section Empty))) `shouldBe` Right ["foo", "bar", "bar2", "baz"] context "when parsing conditionals with else-branch" $ do it "accepts conditionals with else-branch" $ do let input = [i| when: condition: os(windows) then: dependencies: Win32 else: dependencies: unix |] conditionals = [ Conditional "os(windows)" (section ()){sectionDependencies = ["Win32"]} (Just (section ()){sectionDependencies = ["unix"]}) ] r :: Either String (Section Empty) r = captureUnknownFieldsValue <$> decodeEither input sectionConditionals <$> r `shouldBe` Right conditionals it "rejects invalid conditionals" $ do let input = [i| when: condition: os(windows) then: dependencies: Win32 else: null |] r :: Either String (Section Empty) r = captureUnknownFieldsValue <$> decodeEither input sectionConditionals <$> r `shouldSatisfy` isLeft it "warns on unknown fields" $ do let input = [i| when: condition: os(windows) foo: null then: bar: null else: baz: null |] captureUnknownFieldsFields <$> (decodeEither input :: Either String (CaptureUnknownFields (Section Empty))) `shouldBe` Right ["foo", "bar", "baz"] 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" }|] source = GitRef "https://github.com/sol/hpack" "master" Nothing parseEither parseJSON value `shouldBe` Right (Dependency "hpack" (Just source)) it "accepts github dependencies" $ do let value = [aesonQQ|{ name: "hpack", github: "sol/hpack", ref: "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|{ name: "hpack", path: "../hpack" }|] source = Local "../hpack" parseEither parseJSON value `shouldBe` Right (Dependency "hpack" (Just source)) context "when parsing fails" $ do it "returns an error message" $ do let value = Number 23 parseEither parseJSON value `shouldBe` (Left "Error in $: expected String or an Object, encountered Number" :: 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 "Error in $: 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 "Error in $: neither key \"git\" nor key \"github\" present" :: Either String Dependency) describe "getModules" $ around withTempDirectory $ do it "returns Haskell modules in specified source directory" $ \dir -> do touch (dir "src/Foo.hs") touch (dir "src/Bar/Baz.hs") touch (dir "src/Setup.hs") getModules dir "src" >>= (`shouldMatchList` ["Foo", "Bar.Baz", "Setup"]) context "when source directory is '.'" $ do it "ignores Setup" $ \dir -> do touch (dir "Foo.hs") touch (dir "Setup.hs") getModules dir "." `shouldReturn` ["Foo"] context "when source directory is './.'" $ do it "ignores Setup" $ \dir -> do touch (dir "Foo.hs") touch (dir "Setup.hs") getModules dir "./." `shouldReturn` ["Foo"] describe "determineModules" $ do it "adds the Paths_* module to the other-modules" $ do determineModules "foo" [] (Just $ List ["Foo"]) Nothing `shouldBe` (["Foo"], ["Paths_foo"]) it "replaces dashes with underscores in Paths_*" $ do determineModules "foo-bar" [] (Just $ List ["Foo"]) Nothing `shouldBe` (["Foo"], ["Paths_foo_bar"]) context "when the Paths_* module is part of the exposed-modules" $ do it "does not add the Paths_* module to the other-modules" $ do determineModules "foo" [] (Just $ List ["Foo", "Paths_foo"]) Nothing `shouldBe` (["Foo", "Paths_foo"], []) describe "readPackageConfig" $ do it "warns on unknown fields" $ do withPackageWarnings_ [i| bar: 23 baz: 42 |] (`shouldBe` [ "Ignoring unknown field \"bar\" in package description" , "Ignoring unknown field \"baz\" in package description" ] ) it "warns on unknown fields in when block, list" $ do withPackageWarnings_ [i| when: - condition: impl(ghc) bar: 23 baz: 42 |] (`shouldBe` [ "Ignoring unknown field \"bar\" in package description" , "Ignoring unknown field \"baz\" in package description" ] ) it "warns on unknown fields in when block, single" $ do withPackageWarnings_ [i| when: condition: impl(ghc) github: foo/bar dependencies: ghc-prim baz: 42 |] (`shouldBe` [ "Ignoring unknown field \"baz\" in package description" , "Ignoring unknown field \"github\" in package description" ] ) it "accepts name" $ do withPackageConfig_ [i| name: bar |] (packageName >>> (`shouldBe` "bar")) it "accepts version" $ do withPackageConfig_ [i| version: 0.1.0 |] (packageVersion >>> (`shouldBe` "0.1.0")) it "accepts synopsis" $ do withPackageConfig_ [i| synopsis: some synopsis |] (packageSynopsis >>> (`shouldBe` Just "some synopsis")) it "accepts description" $ do withPackageConfig_ [i| description: some description |] (packageDescription >>> (`shouldBe` Just "some description")) it "accepts category" $ do withPackageConfig_ [i| category: Data |] (`shouldBe` package {packageCategory = Just "Data"}) it "accepts author" $ do withPackageConfig_ [i| author: John Doe |] (`shouldBe` package {packageAuthor = ["John Doe"]}) it "accepts maintainer" $ do withPackageConfig_ [i| maintainer: John Doe |] (`shouldBe` package {packageMaintainer = ["John Doe "]}) it "accepts copyright" $ do withPackageConfig_ [i| copyright: (c) 2015 John Doe |] (`shouldBe` package {packageCopyright = ["(c) 2015 John Doe"]}) it "accepts stability" $ do withPackageConfig_ [i| stability: experimental |] (packageStability >>> (`shouldBe` Just "experimental")) it "accepts homepage URL" $ do withPackageConfig_ [i| github: hspec/hspec homepage: https://example.com/ |] (packageHomepage >>> (`shouldBe` Just "https://example.com/")) it "infers homepage URL from github" $ do withPackageConfig_ [i| github: hspec/hspec |] (packageHomepage >>> (`shouldBe` Just "https://github.com/hspec/hspec#readme")) it "omits homepage URL if it is null" $ do withPackageConfig_ [i| github: hspec/hspec homepage: null |] (packageHomepage >>> (`shouldBe` Nothing)) it "accepts bug-reports URL" $ do withPackageConfig_ [i| github: hspec/hspec bug-reports: https://example.com/issues |] (packageBugReports >>> (`shouldBe` Just "https://example.com/issues")) it "infers bug-reports URL from github" $ do withPackageConfig_ [i| github: hspec/hspec |] (packageBugReports >>> (`shouldBe` Just "https://github.com/hspec/hspec/issues")) it "omits bug-reports URL if it is null" $ do withPackageConfig_ [i| github: hspec/hspec bug-reports: null |] (packageBugReports >>> (`shouldBe` Nothing)) it "accepts license" $ do withPackageConfig_ [i| license: MIT |] (`shouldBe` package {packageLicense = Just "MIT"}) it "infers license file" $ do withPackageConfig [i| name: foo |] (do touch "LICENSE" ) (packageLicenseFile >>> (`shouldBe` Just "LICENSE")) it "accepts license file" $ do withPackageConfig_ [i| license-file: FOO |] (packageLicenseFile >>> (`shouldBe` Just "FOO")) it "accepts flags" $ do withPackageConfig_ [i| flags: integration-tests: description: Run the integration test suite manual: yes default: no |] (packageFlags >>> (`shouldBe` [Flag "integration-tests" (Just "Run the integration test suite") True False])) it "warns on unknown fields in flag sections" $ do withPackageWarnings_ [i| flags: integration-tests: description: Run the integration test suite manual: yes default: no foo: 23 |] (`shouldBe` [ "Ignoring unknown field \"foo\" for flag \"integration-tests\"" ] ) it "accepts extra-source-files" $ do withPackageConfig [i| extra-source-files: - CHANGES.markdown - README.markdown |] (do touch "CHANGES.markdown" touch "README.markdown" ) (packageExtraSourceFiles >>> (`shouldBe` ["CHANGES.markdown", "README.markdown"])) it "accepts data-files" $ do withPackageConfig [i| data-files: - data/**/*.html |] (do touch "data/foo/index.html" touch "data/bar/index.html" ) (packageDataFiles >>> (`shouldMatchList` ["data/foo/index.html", "data/bar/index.html"])) it "accepts github" $ do withPackageConfig_ [i| github: hspec/hspec |] (packageSourceRepository >>> (`shouldBe` Just (SourceRepository "https://github.com/hspec/hspec" Nothing))) it "accepts third part of github URL as subdir" $ do withPackageConfig_ [i| github: hspec/hspec/hspec-core |] (packageSourceRepository >>> (`shouldBe` Just (SourceRepository "https://github.com/hspec/hspec" (Just "hspec-core")))) it "accepts arbitrary git URLs as source repository" $ do withPackageConfig_ [i| git: https://gitlab.com/gitlab-org/gitlab-ce.git |] (packageSourceRepository >>> (`shouldBe` Just (SourceRepository "https://gitlab.com/gitlab-org/gitlab-ce.git" Nothing))) it "accepts CPP options" $ do withPackageConfig_ [i| cpp-options: -DFOO library: cpp-options: -DLIB executables: foo: main: Main.hs cpp-options: -DFOO tests: spec: main: Spec.hs cpp-options: -DTEST |] (`shouldBe` package { packageLibrary = Just (section library) {sectionCppOptions = ["-DFOO", "-DLIB"]} , packageExecutables = [(section $ executable "foo" "Main.hs") {sectionCppOptions = ["-DFOO", "-DFOO"]}] , packageTests = [(section $ executable "spec" "Spec.hs") {sectionCppOptions = ["-DFOO", "-DTEST"]}] } ) it "accepts ld-options" $ do withPackageConfig_ [i| library: ld-options: -static |] (`shouldBe` package { packageLibrary = Just (section library) {sectionLdOptions = ["-static"]} } ) it "accepts buildable" $ do withPackageConfig_ [i| buildable: no library: buildable: yes executables: foo: main: Main.hs |] (`shouldBe` package { packageLibrary = Just (section library) {sectionBuildable = Just True} , packageExecutables = [(section $ executable "foo" "Main.hs") {sectionBuildable = Just False}] } ) context "when reading library section" $ do it "warns on unknown fields" $ do withPackageWarnings_ [i| library: bar: 23 baz: 42 |] (`shouldBe` [ "Ignoring unknown field \"bar\" in library section" , "Ignoring unknown field \"baz\" in library section" ] ) it "accepts source-dirs" $ do withPackageConfig_ [i| library: source-dirs: - foo - bar |] (packageLibrary >>> (`shouldBe` Just (section library) {sectionSourceDirs = ["foo", "bar"]})) it "accepts build-tools" $ do withPackageConfig_ [i| library: build-tools: - alex - happy |] (packageLibrary >>> (`shouldBe` Just (section library) {sectionBuildTools = ["alex", "happy"]})) it "accepts default-extensions" $ do withPackageConfig_ [i| library: default-extensions: - Foo - Bar |] (packageLibrary >>> (`shouldBe` Just (section library) {sectionDefaultExtensions = ["Foo", "Bar"]})) it "accepts global default-extensions" $ do withPackageConfig_ [i| default-extensions: - Foo - Bar library: {} |] (packageLibrary >>> (`shouldBe` Just (section library) {sectionDefaultExtensions = ["Foo", "Bar"]})) it "accepts global source-dirs" $ do withPackageConfig_ [i| source-dirs: - foo - bar library: {} |] (packageLibrary >>> (`shouldBe` Just (section library) {sectionSourceDirs = ["foo", "bar"]})) it "accepts global build-tools" $ do withPackageConfig_ [i| build-tools: - alex - happy library: {} |] (packageLibrary >>> (`shouldBe` Just (section library) {sectionBuildTools = ["alex", "happy"]})) it "allows to specify exposed" $ do withPackageConfig_ [i| library: exposed: no |] (packageLibrary >>> (`shouldBe` Just (section library{libraryExposed = Just False}))) it "allows to specify exposed-modules" $ do withPackageConfig [i| library: source-dirs: src exposed-modules: Foo |] (do touch "src/Foo.hs" touch "src/Bar.hs" ) (packageLibrary >>> (`shouldBe` Just (section library{libraryExposedModules = ["Foo"], libraryOtherModules = ["Bar", "Paths_foo"]}) {sectionSourceDirs = ["src"]})) it "allows to specify other-modules" $ do withPackageConfig [i| library: source-dirs: src other-modules: Bar |] (do touch "src/Foo.hs" touch "src/Bar.hs" ) (packageLibrary >>> (`shouldBe` Just (section library{libraryExposedModules = ["Foo"], libraryOtherModules = ["Bar"]}) {sectionSourceDirs = ["src"]})) it "allows to specify reexported-modules" $ do withPackageConfig_ [i| library: reexported-modules: Baz |] (packageLibrary >>> (`shouldBe` Just (section library{libraryReexportedModules = ["Baz"]}))) it "allows to specify both exposed-modules and other-modules" $ do withPackageConfig [i| library: source-dirs: src exposed-modules: Foo other-modules: Bar |] (do touch "src/Baz.hs" ) (packageLibrary >>> (`shouldBe` Just (section library{libraryExposedModules = ["Foo"], libraryOtherModules = ["Bar"]}) {sectionSourceDirs = ["src"]})) context "when neither exposed-modules nor other-modules are specified" $ do it "exposes all modules" $ do withPackageConfig [i| library: source-dirs: src |] (do touch "src/Foo.hs" touch "src/Bar.hs" ) (packageLibrary >>> (`shouldBe` Just (section library{libraryExposedModules = ["Bar", "Foo"]}) {sectionSourceDirs = ["src"]})) context "when reading executable section" $ do it "warns on unknown fields" $ do withPackageWarnings_ [i| executables: foo: main: Main.hs bar: 42 baz: 23 |] (`shouldBe` [ "Ignoring unknown field \"bar\" in executable section \"foo\"" , "Ignoring unknown field \"baz\" in executable section \"foo\"" ] ) it "reads executable section" $ do withPackageConfig_ [i| executables: foo: main: driver/Main.hs |] (packageExecutables >>> (`shouldBe` [section $ executable "foo" "driver/Main.hs"])) it "accepts arbitrary entry points as main" $ do withPackageConfig_ [i| executables: foo: main: Foo |] (packageExecutables >>> (`shouldBe` [ (section $ executable "foo" "Foo.hs") {sectionGhcOptions = ["-main-is Foo"]} ] )) it "accepts source-dirs" $ do withPackageConfig_ [i| executables: foo: main: Main.hs source-dirs: - foo - bar |] (packageExecutables >>> (`shouldBe` [(section $ executable "foo" "Main.hs") {sectionSourceDirs = ["foo", "bar"]}])) it "accepts build-tools" $ do withPackageConfig_ [i| executables: foo: main: Main.hs build-tools: - alex - happy |] (packageExecutables >>> (`shouldBe` [(section $ executable "foo" "Main.hs") {sectionBuildTools = ["alex", "happy"]}])) it "accepts global source-dirs" $ do withPackageConfig_ [i| source-dirs: - foo - bar executables: foo: main: Main.hs |] (packageExecutables >>> (`shouldBe` [(section $ executable "foo" "Main.hs") {sectionSourceDirs = ["foo", "bar"]}])) it "accepts global build-tools" $ do withPackageConfig_ [i| build-tools: - alex - happy executables: foo: main: Main.hs |] (packageExecutables >>> (`shouldBe` [(section $ executable "foo" "Main.hs") {sectionBuildTools = ["alex", "happy"]}])) it "infers other-modules" $ do withPackageConfig [i| executables: foo: main: Main.hs source-dirs: src |] (do touch "src/Main.hs" touch "src/Foo.hs" touch "src/Bar.hs" touch "src/Baz.lhs" ) (map (executableOtherModules . sectionData) . packageExecutables >>> (`shouldBe` [["Bar", "Baz", "Foo"]])) it "allows to specify other-modules" $ do withPackageConfig [i| executables: foo: main: Main.hs source-dirs: src other-modules: Baz |] (do touch "src/Foo.hs" touch "src/Bar.hs" ) (map (executableOtherModules . sectionData) . packageExecutables >>> (`shouldBe` [["Baz"]])) it "accepts default-extensions" $ do withPackageConfig_ [i| executables: foo: main: driver/Main.hs default-extensions: - Foo - Bar |] (packageExecutables >>> (`shouldBe` [(section $ executable "foo" "driver/Main.hs") {sectionDefaultExtensions = ["Foo", "Bar"]}])) it "accepts global default-extensions" $ do withPackageConfig_ [i| default-extensions: - Foo - Bar executables: foo: main: driver/Main.hs |] (packageExecutables >>> (`shouldBe` [(section $ executable "foo" "driver/Main.hs") {sectionDefaultExtensions = ["Foo", "Bar"]}])) it "accepts GHC options" $ do withPackageConfig_ [i| executables: foo: main: driver/Main.hs ghc-options: -Wall |] (`shouldBe` package {packageExecutables = [(section $ executable "foo" "driver/Main.hs") {sectionGhcOptions = ["-Wall"]}]}) it "accepts global GHC options" $ do withPackageConfig_ [i| ghc-options: -Wall executables: foo: main: driver/Main.hs |] (`shouldBe` package {packageExecutables = [(section $ executable "foo" "driver/Main.hs") {sectionGhcOptions = ["-Wall"]}]}) it "accepts GHC profiling options" $ do withPackageConfig_ [i| executables: foo: main: driver/Main.hs ghc-prof-options: -fprof-auto |] (`shouldBe` package {packageExecutables = [(section $ executable "foo" "driver/Main.hs") {sectionGhcProfOptions = ["-fprof-auto"]}]}) it "accepts global GHC profiling options" $ do withPackageConfig_ [i| ghc-prof-options: -fprof-auto executables: foo: main: driver/Main.hs |] (`shouldBe` package {packageExecutables = [(section $ executable "foo" "driver/Main.hs") {sectionGhcProfOptions = ["-fprof-auto"]}]}) context "when reading test section" $ do it "warns on unknown fields" $ do withPackageWarnings_ [i| tests: foo: main: Main.hs bar: 42 baz: 23 |] (`shouldBe` [ "Ignoring unknown field \"bar\" in test section \"foo\"" , "Ignoring unknown field \"baz\" in test section \"foo\"" ] ) it "reads test section" $ do withPackageConfig_ [i| tests: spec: main: test/Spec.hs |] (`shouldBe` package {packageTests = [section $ executable "spec" "test/Spec.hs"]}) it "accepts single dependency" $ do withPackageConfig_ [i| tests: spec: main: test/Spec.hs dependencies: hspec |] (`shouldBe` package {packageTests = [(section $ executable "spec" "test/Spec.hs") {sectionDependencies = ["hspec"]}]}) it "accepts list of dependencies" $ do withPackageConfig_ [i| tests: spec: main: test/Spec.hs dependencies: - hspec - QuickCheck |] (`shouldBe` package {packageTests = [(section $ executable "spec" "test/Spec.hs") {sectionDependencies = ["hspec", "QuickCheck"]}]}) context "when both global and section specific dependencies are specified" $ do it "combines dependencies" $ do withPackageConfig_ [i| dependencies: - base tests: spec: main: test/Spec.hs dependencies: hspec |] (`shouldBe` package {packageTests = [(section $ executable "spec" "test/Spec.hs") {sectionDependencies = ["base", "hspec"]}]}) context "when a specified source directory does not exist" $ do it "warns" $ do withPackageWarnings [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 |] (do touch "some-existing-dir/foo" ) (`shouldBe` [ "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" ] ) around withTempDirectory $ do context "when package.yaml can not be parsed" $ do it "returns an error" $ \dir -> do let file = dir "package.yaml" writeFile file [i| foo: bar foo baz |] readPackageConfig file `shouldReturn` Left (file ++ ":3:12: could not find expected ':' while scanning a simple key") context "when package.yaml is invalid" $ do it "returns an error" $ \dir -> do let file = dir "package.yaml" writeFile file [i| executables: foo: ain: driver/Main.hs |] readPackageConfig file `shouldReturn` Left (file ++ ": Error in $.executables.foo: failed to parse field executables: The key \"main\" was not found") context "when package.yaml does not exist" $ do it "returns an error" $ \dir -> do let file = dir "package.yaml" readPackageConfig file `shouldReturn` Left [i|#{file}: Yaml file not found: #{file}|] hpack-0.14.1/test/Hpack/FormattingHintsSpec.hs0000644000000000000000000001073412706324120017347 0ustar0000000000000000module 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 hpack-0.14.1/test/Hpack/GenericsUtilSpec.hs0000644000000000000000000000111412551635302016621 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} module Hpack.GenericsUtilSpec (spec) where import Test.Hspec import Data.Proxy import GHC.Generics import Hpack.GenericsUtil data Person = Person { _personName :: String , _personAge :: Int } deriving Generic spec :: Spec spec = do describe "selectors" $ do it "returns a list of record selectors" $ do selectors (Proxy :: Proxy Person) `shouldBe` ["_personName", "_personAge"] describe "typeName" $ do it "gets datatype name" $ do typeName (Proxy :: Proxy Person) `shouldBe` "Person" hpack-0.14.1/test/Hpack/HaskellSpec.hs0000644000000000000000000000151512551635302015614 0ustar0000000000000000module Hpack.HaskellSpec (spec) where import Test.Hspec import Hpack.Haskell spec :: Spec spec = do describe "isModule" $ do it "accepts module names" $ do isModule ["Foo", "Bar"] `shouldBe` True it "rejects the empty list" $ do isModule [] `shouldBe` False describe "isQualifiedIdentifier" $ do it "accepts qualified Haskell identifiers" $ do isQualifiedIdentifier ["Foo", "Bar", "baz"] `shouldBe` True it "rejects invalid input" $ do isQualifiedIdentifier ["Foo", "Bar", "Baz"] `shouldBe` False describe "isIdentifier" $ do it "accepts Haskell identifiers" $ do isIdentifier "foo" `shouldBe` True it "rejects reserved keywords" $ do isIdentifier "case" `shouldBe` False it "rejects invalid input" $ do isIdentifier "Foo" `shouldBe` False hpack-0.14.1/test/Hpack/RenderSpec.hs0000644000000000000000000001242712706324120015447 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Hpack.RenderSpec where import Prelude () import Prelude.Compat 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_ stanza `shouldBe` [ "foo" , " bar: 23" , " baz: 42" ] it "omits empty fields" $ do let stanza = Stanza "foo" [ Field "bar" "23" , Field "baz" (WordList []) ] render_ stanza `shouldBe` [ "foo" , " bar: 23" ] it "allows to customize indentation" $ do let stanza = Stanza "foo" [ Field "bar" "23" , Field "baz" "42" ] render defaultRenderSettings{renderSettingsIndentation = 4} 0 stanza `shouldBe` [ "foo" , " bar: 23" , " baz: 42" ] it "renders nested stanzas" $ do let input = Stanza "foo" [Field "bar" "23", Stanza "baz" [Field "qux" "42"]] render_ input `shouldBe` [ "foo" , " bar: 23" , " baz" , " qux: 42" ] context "when rendering a Field" $ do context "when rendering a MultipleLines value" $ do it "takes nesting into account" $ do let field = Field "foo" (CommaSeparatedList ["bar", "baz"]) render defaultRenderSettings 1 field `shouldBe` [ " foo:" , " bar" , " , baz" ] context "when value is empty" $ do it "returns an empty list" $ do let field = Field "foo" (CommaSeparatedList []) render_ field `shouldBe` [] context "when rendering a SingleLine value" $ do it "returns a single line" $ do let field = Field "foo" (Literal "bar") render_ field `shouldBe` ["foo: bar"] it "takes nesting into account" $ do let field = Field "foo" (Literal "bar") render defaultRenderSettings 2 field `shouldBe` [" foo: bar"] it "takes alignment into account" $ do let field = Field "foo" (Literal "bar") render defaultRenderSettings {renderSettingsFieldAlignment = 10} 0 field `shouldBe` ["foo: bar"] context "when value is empty" $ do it "returns an empty list" $ do let field = Field "foo" (Literal "") render_ field `shouldBe` [] describe "renderValue" $ do it "renders WordList" $ do renderValue defaultRenderSettings (WordList ["foo", "bar", "baz"]) `shouldBe` SingleLine "foo bar baz" it "renders CommaSeparatedList" $ do renderValue defaultRenderSettings (CommaSeparatedList ["foo", "bar", "baz"]) `shouldBe` MultipleLines [ " foo" , ", bar" , ", baz" ] it "renders LineSeparatedList" $ do renderValue defaultRenderSettings (LineSeparatedList ["foo", "bar", "baz"]) `shouldBe` MultipleLines [ " foo" , " bar" , " baz" ] context "when renderSettingsCommaStyle is TrailingCommas" $ do let settings = defaultRenderSettings{renderSettingsCommaStyle = TrailingCommas} it "renders CommaSeparatedList with trailing commas" $ do renderValue settings (CommaSeparatedList ["foo", "bar", "baz"]) `shouldBe` MultipleLines [ "foo," , "bar," , "baz" ] it "renders LineSeparatedList without padding" $ do renderValue settings (LineSeparatedList ["foo", "bar", "baz"]) `shouldBe` MultipleLines [ "foo" , "bar" , "baz" ] describe "sortFieldsBy" $ do let field name = Field name (Literal $ name ++ " value") arbitraryFieldNames = sublistOf ["foo", "bar", "baz", "qux", "foobar", "foobaz"] >>= shuffle it "sorts fields" $ do let fields = map field ["baz", "bar", "foo"] sortFieldsBy ["foo", "bar", "baz"] fields `shouldBe` map field ["foo", "bar", "baz"] it "keeps existing field order" $ do forAll (map field <$> arbitraryFieldNames) $ \fields -> do forAll arbitraryFieldNames $ \existingFieldOrder -> do let existingIndex :: Element -> Maybe Int existingIndex (Field name _) = name `elemIndex` existingFieldOrder existingIndex _ = Nothing indexes :: [Int] indexes = mapMaybe existingIndex (sortFieldsBy existingFieldOrder fields) sort indexes `shouldBe` indexes it "is stable" $ do forAll arbitraryFieldNames $ \fieldNames -> do forAll (elements $ subsequences fieldNames) $ \existingFieldOrder -> do let fields = map field fieldNames sortFieldsBy existingFieldOrder fields `shouldBe` fields describe "addSortKey" $ do it "adds sort key" $ do addSortKey [(Nothing, "foo"), (Just 3, "bar"), (Nothing, "baz")] `shouldBe` [((-1, 0), "foo"), ((3, 1), "bar"), ((3, 2), "baz" :: String)] hpack-0.14.1/test/Hpack/RunSpec.hs0000644000000000000000000002644312706324120014777 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Hpack.RunSpec (spec) where import Test.Hspec import Data.List.Compat import Hpack.ConfigSpec hiding (spec) import Hpack.Config hiding (package) import Hpack.Render import Hpack.Run spec :: Spec spec = do describe "renderPackage" $ do let renderPackage_ = renderPackage defaultRenderSettings 0 [] [] it "renders a package" $ do renderPackage_ package `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" , "cabal-version: >= 1.10" ] it "aligns fields" $ do renderPackage defaultRenderSettings 16 [] [] package `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" , "cabal-version: >= 1.10" ] it "includes description" $ do renderPackage_ package {packageDescription = Just "foo\n\nbar\n"} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "description: foo" , " ." , " bar" , "build-type: Simple" , "cabal-version: >= 1.10" ] it "aligns description" $ do renderPackage defaultRenderSettings 16 [] [] package {packageDescription = Just "foo\n\nbar\n"} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "description: foo" , " ." , " bar" , "build-type: Simple" , "cabal-version: >= 1.10" ] it "includes stability" $ do renderPackage_ package {packageStability = Just "experimental"} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "stability: experimental" , "build-type: Simple" , "cabal-version: >= 1.10" ] it "includes copyright holder" $ do renderPackage_ package {packageCopyright = ["(c) 2015 Simon Hengel"]} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "copyright: (c) 2015 Simon Hengel" , "build-type: Simple" , "cabal-version: >= 1.10" ] it "aligns copyright holders" $ do renderPackage defaultRenderSettings 16 [] [] package {packageCopyright = ["(c) 2015 Foo", "(c) 2015 Bar"]} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "copyright: (c) 2015 Foo," , " (c) 2015 Bar" , "build-type: Simple" , "cabal-version: >= 1.10" ] it "includes extra-source-files" $ do renderPackage_ package {packageExtraSourceFiles = ["foo", "bar"]} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" , "cabal-version: >= 1.10" , "" , "extra-source-files:" , " foo" , " bar" ] it "includes buildable" $ do renderPackage_ package {packageLibrary = Just (section library){sectionBuildable = Just False}} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" , "cabal-version: >= 1.10" , "" , "library" , " buildable: False" , " default-language: Haskell2010" ] context "when rendering library section" $ do it "renders library section" $ do renderPackage_ package {packageLibrary = Just $ section library} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" , "cabal-version: >= 1.10" , "" , "library" , " default-language: Haskell2010" ] it "includes exposed-modules" $ do renderPackage_ package {packageLibrary = Just (section library{libraryExposedModules = ["Foo"]})} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" , "cabal-version: >= 1.10" , "" , "library" , " exposed-modules:" , " Foo" , " default-language: Haskell2010" ] it "includes other-modules" $ do renderPackage_ package {packageLibrary = Just (section library{libraryOtherModules = ["Bar"]})} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" , "cabal-version: >= 1.10" , "" , "library" , " other-modules:" , " Bar" , " default-language: Haskell2010" ] it "includes reexported-modules and bumps cabal version" $ do renderPackage_ package {packageLibrary = Just (section library{libraryReexportedModules = ["Baz"]})} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" , "cabal-version: >= 1.21" , "" , "library" , " reexported-modules:" , " Baz" , " default-language: Haskell2010" ] context "when given list of existing fields" $ do it "retains field order" $ do renderPackage defaultRenderSettings 16 ["cabal-version", "version", "name", "build-type"] [] package `shouldBe` unlines [ "cabal-version: >= 1.10" , "version: 0.0.0" , "name: foo" , "build-type: Simple" ] it "uses default field order for new fields" $ do renderPackage defaultRenderSettings 16 ["name", "version", "cabal-version"] [] package `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" , "cabal-version: >= 1.10" ] it "retains section field order" $ do renderPackage defaultRenderSettings 0 [] [("executable foo", ["default-language", "main-is", "ghc-options"])] package {packageExecutables = [(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_ package {packageExecutables = [(section $ executable "foo" "Main.hs") {sectionDependencies = ["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_ 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" , " main-is: Main.hs" , " ghc-options: -Wall -Werror" , " default-language: Haskell2010" ] it "includes GHC profiling options" $ do renderPackage_ package {packageExecutables = [(section $ executable "foo" "Main.hs") {sectionGhcProfOptions = ["-fprof-auto", "-rtsopts"]}]} `shouldBe` unlines [ "name: foo" , "version: 0.0.0" , "build-type: Simple" , "cabal-version: >= 1.10" , "" , "executable foo" , " main-is: Main.hs" , " ghc-prof-options: -fprof-auto -rtsopts" , " default-language: Haskell2010" ] describe "renderConditional" $ do it "renders conditionals" $ do let conditional = Conditional "os(windows)" (section ()) {sectionDependencies = ["Win32"]} Nothing render defaultRenderSettings 0 (renderConditional conditional) `shouldBe` [ "if os(windows)" , " build-depends:" , " Win32" ] it "renders conditionals with else-branch" $ do let conditional = Conditional "os(windows)" (section ()) {sectionDependencies = ["Win32"]} (Just $ (section ()) {sectionDependencies = ["unix"]}) render defaultRenderSettings 0 (renderConditional conditional) `shouldBe` [ "if os(windows)" , " build-depends:" , " Win32" , "else" , " build-depends:" , " unix" ] it "renders nested conditionals" $ do let conditional = Conditional "arch(i386)" (section ()) {sectionGhcOptions = ["-threaded"], sectionConditionals = [innerConditional]} Nothing innerConditional = Conditional "os(windows)" (section ()) {sectionDependencies = ["Win32"]} Nothing render defaultRenderSettings 0 (renderConditional conditional) `shouldBe` [ "if arch(i386)" , " ghc-options: -threaded" , " if os(windows)" , " build-depends:" , " Win32" ] describe "renderFlag" $ do it "renders flags" $ do let flag = (Flag "foo" (Just "some flag") True False) render defaultRenderSettings 0 (renderFlag flag) `shouldBe` [ "flag foo" , " description: some flag" , " manual: True" , " default: False" ] describe "formatDescription" $ do it "formats description" $ do let description = unlines [ "foo" , "bar" ] "description: " ++ formatDescription 0 description `shouldBe` intercalate "\n" [ "description: foo" , " bar" ] it "takes specified alignment into account" $ do let description = unlines [ "foo" , "bar" , "baz" ] "description: " ++ formatDescription 15 description `shouldBe` intercalate "\n" [ "description: foo" , " bar" , " baz" ] it "formats empty lines" $ do let description = unlines [ "foo" , " " , "bar" ] "description: " ++ formatDescription 0 description `shouldBe` intercalate "\n" [ "description: foo" , " ." , " bar" ] describe "renderSourceRepository" $ do it "renders source-repository without subdir correctly" $ do let repository = SourceRepository "https://github.com/hspec/hspec" Nothing (render defaultRenderSettings 0 $ renderSourceRepository repository) `shouldBe` [ "source-repository head" , " type: git" , " location: https://github.com/hspec/hspec" ] it "renders source-repository with subdir" $ do let repository = SourceRepository "https://github.com/hspec/hspec" (Just "hspec-core") (render defaultRenderSettings 0 $ renderSourceRepository repository) `shouldBe` [ "source-repository head" , " type: git" , " location: https://github.com/hspec/hspec" , " subdir: hspec-core" ] hpack-0.14.1/test/Hpack/UtilSpec.hs0000644000000000000000000001232612706324120015143 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} module Hpack.UtilSpec (main, spec) where import Data.Aeson import Data.Aeson.QQ import Data.Aeson.Types import Helper import System.Directory import Hpack.Config import Hpack.Util main :: IO () main = hspec spec spec :: Spec spec = do describe "sort" $ do it "sorts lexicographically" $ do sort ["foo", "Foo"] `shouldBe` ["Foo", "foo" :: String] describe "parseMain" $ do it "accepts source file" $ do parseMain "Main.hs" `shouldBe` ("Main.hs", []) it "accepts literate source file" $ do parseMain "Main.lhs" `shouldBe` ("Main.lhs", []) it "accepts module" $ do parseMain "Foo" `shouldBe` ("Foo.hs", ["-main-is Foo"]) it "accepts hierarchical module" $ do parseMain "Foo.Bar.Baz" `shouldBe` ("Foo/Bar/Baz.hs", ["-main-is Foo.Bar.Baz"]) it "accepts qualified identifier" $ do parseMain "Foo.bar" `shouldBe` ("Foo.hs", ["-main-is Foo.bar"]) 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" actual <- getFilesRecursive "foo" actual `shouldMatchList` [ ["bar"] , ["baz"] , ["foobar", "baz"] ] describe "List" $ do let invalid = [aesonQQ|{ name: "hpack", gi: "sol/hpack", ref: "master" }|] parseError :: String -> Either String (List Dependency) parseError prefix = Left (prefix ++ ": neither key \"git\" nor key \"github\" present") context "when parsing single values" $ do it "returns the value in a singleton list" $ do fromJSON (toJSON $ Number 23) `shouldBe` Success (List [23 :: Int]) it "returns error messages from element parsing" $ do parseEither parseJSON invalid `shouldBe` parseError "Error in $" context "when parsing a list of values" $ do it "returns the list" $ do fromJSON (toJSON [Number 23, Number 42]) `shouldBe` Success (List [23, 42 :: Int]) it "propagates parse error messages of invalid elements" $ do parseEither parseJSON (toJSON [String "foo", invalid]) `shouldBe` parseError "Error in $[1]" 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 "expandGlobs" $ around withTempDirectory $ do it "accepts simple files" $ \dir -> do touch (dir "foo.js") expandGlobs dir ["foo.js"] `shouldReturn` ([], ["foo.js"]) it "removes duplicates" $ \dir -> do touch (dir "foo.js") expandGlobs dir ["foo.js", "*.js"] `shouldReturn` ([], ["foo.js"]) it "rejects directories" $ \dir -> do touch (dir "foo") createDirectory (dir "bar") expandGlobs dir ["*"] `shouldReturn` ([], ["foo"]) it "rejects character ranges" $ \dir -> do touch (dir "foo1") touch (dir "foo2") touch (dir "foo[1,2]") expandGlobs dir ["foo[1,2]"] `shouldReturn` ([], ["foo[1,2]"]) context "when expanding *" $ do it "expands by extension" $ \dir -> do let files = [ "files/foo.js" , "files/bar.js" , "files/baz.js"] mapM_ (touch . (dir )) files touch (dir "files/foo.hs") expandGlobs dir ["files/*.js"] `shouldReturn` ([], sort files) it "rejects dot-files" $ \dir -> do touch (dir "foo/bar") touch (dir "foo/.baz") expandGlobs dir ["foo/*"] `shouldReturn` ([], ["foo/bar"]) it "accepts dot-files when explicitly asked to" $ \dir -> do touch (dir "foo/bar") touch (dir "foo/.baz") expandGlobs dir ["foo/.*"] `shouldReturn` ([], ["foo/.baz"]) it "matches at most one directory component" $ \dir -> do touch (dir "foo/bar/baz.js") touch (dir "foo/bar.js") expandGlobs dir ["*/*.js"] `shouldReturn` ([], ["foo/bar.js"]) context "when expanding **" $ do it "matches arbitrary many directory components" $ \dir -> do let file = "foo/bar/baz.js" touch (dir file) expandGlobs dir ["**/*.js"] `shouldReturn` ([], [file]) context "when a pattern does not match anything" $ do it "warns" $ \dir -> do expandGlobs dir ["foo"] `shouldReturn` (["Specified pattern \"foo\" for extra-source-files does not match any files"], []) context "when a pattern only matches a directory" $ do it "warns" $ \dir -> do createDirectory (dir "foo") expandGlobs dir ["foo"] `shouldReturn` (["Specified pattern \"foo\" for extra-source-files does not match any files"], []) hpack-0.14.1/test/HpackSpec.hs0000644000000000000000000000461412706324120014227 0ustar0000000000000000module 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 it "returns True by default" $ do parseVerbosity ["foo"] `shouldBe` (True, ["foo"]) 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 hpack-0.14.1/src/Hpack.hs0000644000000000000000000000744212714052040013224 0ustar0000000000000000{-# LANGUAGE CPP #-} module Hpack ( hpack , hpackResult , Result(..) , Status(..) , version , main #ifdef TEST , hpackWithVersion , parseVerbosity , extractVersion , parseVersion #endif ) where import Prelude () import Prelude.Compat import Control.DeepSeq import Control.Exception import Control.Monad.Compat import Data.List.Compat 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 :: Version -> String programVersion v = "hpack version " ++ Version.showVersion v header :: Version -> String header v = unlines [ "-- This file has been generated from " ++ packageConfig ++ " by " ++ programVersion v ++ "." , "--" , "-- see: https://github.com/sol/hpack" , "" ] main :: IO () main = do args <- getArgs case args of ["--version"] -> putStrLn (programVersion version) ["--help"] -> printHelp _ -> case parseVerbosity args of (verbose, [dir]) -> hpack dir verbose (verbose, []) -> hpack "" verbose _ -> do printHelp exitFailure printHelp :: IO () printHelp = do hPutStrLn stderr $ unlines [ "Usage: hpack [ --silent ] [ dir ]" , " hpack --version" ] parseVerbosity :: [String] -> (Bool, [String]) parseVerbosity xs = (verbose, ys) where silentFlag = "--silent" 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 = hpackWithVersion version hpackResult :: FilePath -> IO Result hpackResult = hpackWithVersionResult version data Result = Result { resultWarnings :: [String] , resultCabalFile :: String , resultStatus :: Status } data Status = Generated | AlreadyGeneratedByNewerHpack | OutputUnchanged hpackWithVersion :: Version -> FilePath -> Bool -> IO () hpackWithVersion v dir verbose = do r <- hpackWithVersionResult v dir forM_ (resultWarnings r) $ \warning -> hPutStrLn stderr ("WARNING: " ++ warning) when verbose $ putStrLn $ case resultStatus r of Generated -> "generated " ++ resultCabalFile r OutputUnchanged -> resultCabalFile r ++ " is up-to-date" AlreadyGeneratedByNewerHpack -> resultCabalFile r ++ " was generated with a newer version of hpack, please upgrade and try again." hpackWithVersionResult :: Version -> FilePath -> IO Result hpackWithVersionResult v dir = do (warnings, cabalFile, new) <- run dir old <- either (const Nothing) (Just . splitHeader) <$> tryJust (guard . isDoesNotExistError) (readFile cabalFile >>= (return $!!)) let oldVersion = fmap fst old >>= extractVersion status <- if (oldVersion <= Just v) then if (fmap snd old == Just (lines new)) then return OutputUnchanged else do writeFile cabalFile $ header v ++ new return Generated else return AlreadyGeneratedByNewerHpack return Result { resultWarnings = warnings , resultCabalFile = cabalFile , resultStatus = status } where splitHeader :: String -> ([String], [String]) splitHeader = fmap (dropWhile null) . span ("--" `isPrefixOf`) . lines hpack-0.14.1/src/Hpack/Config.hs0000644000000000000000000006371212726536046014453 0ustar0000000000000000{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} module Hpack.Config ( packageConfig , readPackageConfig , renamePackage , packageDependencies , package , section , Package(..) , Dependency(..) , AddSource(..) , GitUrl , GitRef , GhcOption , Section(..) , Library(..) , Executable(..) , Conditional(..) , Flag(..) , SourceRepository(..) #ifdef TEST , renameDependencies , HasFieldNames(..) , CaptureUnknownFields(..) , Empty(..) , getModules , determineModules #endif ) where import Control.Applicative import Control.Monad.Compat import Data.Aeson.Types import Data.Data import Data.Map.Lazy (Map) import qualified Data.Map.Lazy as Map import qualified Data.HashMap.Lazy as HashMap import Data.List.Compat (nub, (\\), sortBy) import Data.Maybe import Data.Ord import Data.String import Data.Text (Text) import qualified Data.Text as T import GHC.Generics (Generic, Rep) import Prelude () import Prelude.Compat import System.Directory import System.FilePath import Hpack.GenericsUtil import Hpack.Util import Hpack.Yaml package :: String -> String -> Package package name version = Package name version Nothing Nothing Nothing Nothing Nothing Nothing [] [] [] Nothing Nothing Nothing [] [] [] Nothing Nothing [] [] [] renamePackage :: String -> Package -> Package renamePackage name p@Package{..} = p { packageName = name , packageExecutables = map (renameDependencies packageName name) packageExecutables , packageTests = map (renameDependencies packageName name) packageTests , packageBenchmarks = map (renameDependencies packageName name) packageBenchmarks } renameDependencies :: String -> String -> Section a -> Section a renameDependencies old new sect@Section{..} = sect {sectionDependencies = map rename sectionDependencies, sectionConditionals = map renameConditional sectionConditionals} where rename dep | dependencyName dep == old = dep {dependencyName = new} | otherwise = dep renameConditional :: Conditional -> Conditional renameConditional (Conditional condition then_ else_) = Conditional condition (renameDependencies old new then_) (renameDependencies old new <$> else_) packageDependencies :: Package -> [Dependency] packageDependencies Package{..} = nub . sortBy (comparing (lexicographically . dependencyName)) $ (concatMap sectionDependencies packageExecutables) ++ (concatMap sectionDependencies packageTests) ++ (concatMap sectionDependencies packageBenchmarks) ++ maybe [] sectionDependencies packageLibrary section :: a -> Section a section a = Section a [] [] [] [] [] [] [] [] [] [] [] [] [] Nothing [] [] packageConfig :: FilePath packageConfig = "package.yaml" githubBaseUrl :: String githubBaseUrl = "https://github.com/" genericParseJSON_ :: forall a. (Generic a, GFromJSON (Rep a), HasTypeName a) => Value -> Parser a genericParseJSON_ = genericParseJSON defaultOptions {fieldLabelModifier = hyphenize name} where name :: String name = typeName (Proxy :: Proxy a) hyphenize :: String -> String -> String hyphenize name = #if MIN_VERSION_aeson(0,10,0) camelTo2 #else camelTo #endif '-' . drop (length name) . dropWhile (== '_') type FieldName = String class HasFieldNames a where fieldNames :: Proxy a -> [FieldName] default fieldNames :: (HasTypeName a, Selectors (Rep a)) => Proxy a -> [String] fieldNames proxy = map (hyphenize $ typeName proxy) (selectors proxy) data CaptureUnknownFields a = CaptureUnknownFields { captureUnknownFieldsFields :: [FieldName] , captureUnknownFieldsValue :: a } deriving (Eq, Show, Generic) captureUnknownFields :: forall a. (HasFieldNames a, FromJSON a) => Value -> Parser (CaptureUnknownFields a) captureUnknownFields v = CaptureUnknownFields unknown <$> parseJSON v where unknown = getUnknownFields v (Proxy :: Proxy a) instance (HasFieldNames a, FromJSON a) => FromJSON (CaptureUnknownFields (Section a)) where parseJSON v = do (unknownFields, sect) <- toSection <$> parseJSON v <*> parseJSON v return (CaptureUnknownFields (unknownSectionFields ++ unknownFields) sect) where unknownSectionFields = getUnknownFields v (Proxy :: Proxy (Section a)) instance FromJSON (CaptureUnknownFields FlagSection) where parseJSON = captureUnknownFields getUnknownFields :: forall a. HasFieldNames a => Value -> Proxy a -> [FieldName] getUnknownFields v _ = case v of Object o -> unknown where unknown = keys \\ fields keys = map T.unpack (HashMap.keys o) fields = fieldNames (Proxy :: Proxy a) _ -> [] data LibrarySection = LibrarySection { librarySectionExposed :: Maybe Bool , librarySectionExposedModules :: Maybe (List String) , librarySectionOtherModules :: Maybe (List String) , librarySectionReexportedModules :: Maybe (List String) } deriving (Eq, Show, Generic) instance HasFieldNames LibrarySection instance FromJSON LibrarySection where parseJSON = genericParseJSON_ data ExecutableSection = ExecutableSection { executableSectionMain :: FilePath , executableSectionOtherModules :: Maybe (List String) } deriving (Eq, Show, Generic) instance HasFieldNames ExecutableSection instance FromJSON ExecutableSection where parseJSON = genericParseJSON_ data CommonOptions = CommonOptions { commonOptionsSourceDirs :: Maybe (List FilePath) , commonOptionsDependencies :: Maybe (List Dependency) , commonOptionsDefaultExtensions :: Maybe (List String) , commonOptionsOtherExtensions :: Maybe (List String) , commonOptionsGhcOptions :: Maybe (List GhcOption) , commonOptionsGhcProfOptions :: Maybe (List GhcProfOption) , commonOptionsCppOptions :: Maybe (List CppOption) , commonOptionsCSources :: Maybe (List FilePath) , commonOptionsExtraLibDirs :: Maybe (List FilePath) , commonOptionsExtraLibraries :: Maybe (List FilePath) , commonOptionsIncludeDirs :: Maybe (List FilePath) , commonOptionsInstallIncludes :: Maybe (List FilePath) , commonOptionsLdOptions :: Maybe (List LdOption) , commonOptionsBuildable :: Maybe Bool , commonOptionsWhen :: Maybe (List ConditionalSection) , commonOptionsBuildTools :: Maybe (List Dependency) } deriving (Eq, Show, Generic) instance HasFieldNames CommonOptions instance FromJSON CommonOptions where parseJSON = genericParseJSON_ data ConditionalSection = ThenElseConditional (CaptureUnknownFields ThenElse) | FlatConditional (CaptureUnknownFields (Section Condition)) deriving (Eq, Show) instance FromJSON ConditionalSection where parseJSON v | hasKey "then" v || hasKey "else" v = ThenElseConditional <$> parseJSON v | otherwise = FlatConditional <$> parseJSON v hasKey :: Text -> Value -> Bool hasKey key (Object o) = HashMap.member key o hasKey _ _ = False newtype Condition = Condition { conditionCondition :: String } deriving (Eq, Show, Generic) instance FromJSON Condition where parseJSON = genericParseJSON_ instance HasFieldNames Condition data ThenElse = ThenElse { _thenElseCondition :: String , _thenElseThen :: (CaptureUnknownFields (Section Empty)) , _thenElseElse :: (CaptureUnknownFields (Section Empty)) } deriving (Eq, Show, Generic) instance FromJSON (CaptureUnknownFields ThenElse) where parseJSON = captureUnknownFields instance HasFieldNames ThenElse instance FromJSON ThenElse where parseJSON = genericParseJSON_ data Empty = Empty deriving (Eq, Show) instance FromJSON Empty where parseJSON _ = return Empty instance HasFieldNames Empty where fieldNames _ = [] 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 , packageConfigLicenseFile :: Maybe String , packageConfigTestedWith :: Maybe String , packageConfigFlags :: Maybe (Map String (CaptureUnknownFields FlagSection)) , packageConfigExtraSourceFiles :: Maybe (List FilePath) , packageConfigDataFiles :: Maybe (List FilePath) , packageConfigGithub :: Maybe Text , packageConfigGit :: Maybe String , packageConfigLibrary :: Maybe (CaptureUnknownFields (Section LibrarySection)) , packageConfigExecutables :: Maybe (Map String (CaptureUnknownFields (Section ExecutableSection))) , packageConfigTests :: Maybe (Map String (CaptureUnknownFields (Section ExecutableSection))) , packageConfigBenchmarks :: Maybe (Map String (CaptureUnknownFields (Section ExecutableSection))) } deriving (Eq, Show, Generic) instance HasFieldNames PackageConfig 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 r <- decodeYaml file case r of Left err -> return (Left err) Right config -> do dir <- takeDirectory <$> canonicalizePath file Right <$> mkPackage dir config data Dependency = Dependency { dependencyName :: String , dependencyGitRef :: Maybe AddSource } deriving (Eq, Show, Ord, Generic) instance IsString Dependency where fromString name = Dependency name Nothing instance FromJSON Dependency where parseJSON v = case v of String _ -> fromString <$> parseJSON v Object o -> addSourceDependency o _ -> typeMismatch "String or an Object" v where addSourceDependency o = Dependency <$> name <*> (Just <$> (local <|> git)) where name :: Parser String name = o .: "name" local :: Parser AddSource local = Local <$> o .: "path" git :: Parser AddSource git = GitRef <$> url <*> ref <*> subdir url :: Parser String url = ((githubBaseUrl ++) <$> o .: "github") <|> (o .: "git") <|> fail "neither key \"git\" nor key \"github\" present" ref :: Parser String ref = o .: "ref" subdir :: Parser (Maybe FilePath) subdir = o .:? "subdir" data AddSource = GitRef GitUrl GitRef (Maybe FilePath) | Local FilePath deriving (Eq, Show, Ord) type GitUrl = String type GitRef = 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 , packageTestedWith :: Maybe String , packageFlags :: [Flag] , packageExtraSourceFiles :: [FilePath] , packageDataFiles :: [FilePath] , packageSourceRepository :: Maybe SourceRepository , packageLibrary :: Maybe (Section Library) , packageExecutables :: [Section Executable] , packageTests :: [Section Executable] , packageBenchmarks :: [Section Executable] } deriving (Eq, Show) data Library = Library { libraryExposed :: Maybe Bool , libraryExposedModules :: [String] , libraryOtherModules :: [String] , libraryReexportedModules :: [String] } deriving (Eq, Show) data Executable = Executable { executableName :: String , executableMain :: FilePath , executableOtherModules :: [String] } deriving (Eq, Show) data Section a = Section { sectionData :: a , sectionSourceDirs :: [FilePath] , sectionDependencies :: [Dependency] , sectionDefaultExtensions :: [String] , sectionOtherExtensions :: [String] , sectionGhcOptions :: [GhcOption] , sectionGhcProfOptions :: [GhcProfOption] , sectionCppOptions :: [CppOption] , sectionCSources :: [FilePath] , sectionExtraLibDirs :: [FilePath] , sectionExtraLibraries :: [FilePath] , sectionIncludeDirs :: [FilePath] , sectionInstallIncludes :: [FilePath] , sectionLdOptions :: [LdOption] , sectionBuildable :: Maybe Bool , sectionConditionals :: [Conditional] , sectionBuildTools :: [Dependency] } deriving (Eq, Show, Functor, Foldable, Traversable) data Conditional = Conditional { conditionalCondition :: String , conditionalThen :: Section () , conditionalElse :: Maybe (Section ()) } deriving (Eq, Show) instance HasFieldNames a => HasFieldNames (Section a) where fieldNames Proxy = fieldNames (Proxy :: Proxy a) ++ fieldNames (Proxy :: Proxy CommonOptions) data FlagSection = FlagSection { _flagSectionDescription :: Maybe String , _flagSectionManual :: Bool , _flagSectionDefault :: Bool } deriving (Eq, Show, Generic) instance HasFieldNames FlagSection instance FromJSON FlagSection where parseJSON = genericParseJSON_ data Flag = Flag { flagName :: String , flagDescription :: Maybe String , flagManual :: Bool , flagDefault :: Bool } deriving (Eq, Show) toFlag :: (String, FlagSection) -> Flag toFlag (name, FlagSection description manual def) = Flag name description manual def data SourceRepository = SourceRepository { sourceRepositoryUrl :: String , sourceRepositorySubdir :: Maybe String } deriving (Eq, Show) mkPackage :: FilePath -> (CaptureUnknownFields (Section PackageConfig)) -> IO ([String], Package) mkPackage dir (CaptureUnknownFields unknownFields globalOptions@Section{sectionData = PackageConfig{..}}) = do let name = fromMaybe (takeBaseName dir) packageConfigName mLibrary <- mapM (toLibrary dir name globalOptions) mLibrarySection executables <- toExecutables dir globalOptions (map (fmap captureUnknownFieldsValue) executableSections) tests <- toExecutables dir globalOptions (map (fmap captureUnknownFieldsValue) testsSections) benchmarks <- toExecutables dir globalOptions (map (fmap captureUnknownFieldsValue) benchmarkSections) licenseFileExists <- doesFileExist (dir "LICENSE") missingSourceDirs <- nub . sort <$> filterM (fmap not <$> doesDirectoryExist . (dir )) ( maybe [] sectionSourceDirs mLibrary ++ concatMap sectionSourceDirs executables ++ concatMap sectionSourceDirs tests ++ concatMap sectionSourceDirs benchmarks ) (extraSourceFilesWarnings, extraSourceFiles) <- expandGlobs dir (fromMaybeList packageConfigExtraSourceFiles) (dataFilesWarnings, dataFiles) <- expandGlobs dir (fromMaybeList packageConfigDataFiles) let pkg = 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 = packageConfigLicenseFile <|> (guard licenseFileExists >> Just "LICENSE") , packageTestedWith = packageConfigTestedWith , packageFlags = flags , packageExtraSourceFiles = extraSourceFiles , packageDataFiles = dataFiles , packageSourceRepository = sourceRepository , packageLibrary = mLibrary , packageExecutables = executables , packageTests = tests , packageBenchmarks = benchmarks } warnings = formatUnknownFields "package description" unknownFields ++ flagWarnings ++ maybe [] (formatUnknownFields "library section") (captureUnknownFieldsFields <$> packageConfigLibrary) ++ formatUnknownSectionFields "executable" executableSections ++ formatUnknownSectionFields "test" testsSections ++ formatMissingSourceDirs missingSourceDirs ++ extraSourceFilesWarnings ++ dataFilesWarnings return (warnings, pkg) where executableSections :: [(String, CaptureUnknownFields (Section ExecutableSection))] executableSections = toList packageConfigExecutables testsSections :: [(String, CaptureUnknownFields (Section ExecutableSection))] testsSections = toList packageConfigTests benchmarkSections :: [(String, CaptureUnknownFields (Section ExecutableSection))] benchmarkSections = toList packageConfigBenchmarks (flagWarnings, flags) = (concatMap formatUnknownFlagFields xs, map (toFlag . fmap captureUnknownFieldsValue) xs) where xs :: [(String, CaptureUnknownFields FlagSection)] xs = toList packageConfigFlags formatUnknownFlagFields :: (String, CaptureUnknownFields a) -> [String] formatUnknownFlagFields (name, fields) = map f (captureUnknownFieldsFields fields) where f field = "Ignoring unknown field " ++ show field ++ " for flag " ++ show name toList :: Maybe (Map String a) -> [(String, a)] toList = Map.toList . fromMaybe mempty mLibrarySection :: Maybe (Section LibrarySection) mLibrarySection = captureUnknownFieldsValue <$> packageConfigLibrary formatUnknownFields :: String -> [FieldName] -> [String] formatUnknownFields name = map f . sort where f field = "Ignoring unknown field " ++ show field ++ " in " ++ name formatUnknownSectionFields :: String -> [(String, CaptureUnknownFields a)] -> [String] formatUnknownSectionFields sectionType = concatMap f . map (fmap captureUnknownFieldsFields) where f :: (String, [String]) -> [String] f (sect, fields) = formatUnknownFields (sectionType ++ " section " ++ show sect) fields formatMissingSourceDirs = map f where f name = "Specified source-dir " ++ show name ++ " does not exist" sourceRepository :: Maybe SourceRepository sourceRepository = github <|> (`SourceRepository` Nothing) <$> packageConfigGit github :: Maybe SourceRepository github = 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 <$> github bugReports :: Maybe String bugReports = case packageConfigBugReports of Just Nothing -> Nothing _ -> join packageConfigBugReports <|> fromGithub where fromGithub = (++ "/issues") . sourceRepositoryUrl <$> github toLibrary :: FilePath -> String -> Section global -> Section LibrarySection -> IO (Section Library) toLibrary dir name globalOptions library = traverse fromLibrarySection sect where sect :: Section LibrarySection sect = mergeSections globalOptions library sourceDirs :: [FilePath] sourceDirs = sectionSourceDirs sect fromLibrarySection :: LibrarySection -> IO Library fromLibrarySection LibrarySection{..} = do modules <- concat <$> mapM (getModules dir) sourceDirs let (exposedModules, otherModules) = determineModules name modules librarySectionExposedModules librarySectionOtherModules reexportedModules = fromMaybeList librarySectionReexportedModules return (Library librarySectionExposed exposedModules otherModules reexportedModules) toExecutables :: FilePath -> Section global -> [(String, Section ExecutableSection)] -> IO [Section Executable] toExecutables dir globalOptions executables = mapM toExecutable sections where sections :: [(String, Section ExecutableSection)] sections = map (fmap $ mergeSections globalOptions) executables toExecutable :: (String, Section ExecutableSection) -> IO (Section Executable) toExecutable (name, sect@Section{..}) = do (executable, ghcOptions) <- fromExecutableSection sectionData return (sect {sectionData = executable, sectionGhcOptions = sectionGhcOptions ++ ghcOptions}) where fromExecutableSection :: ExecutableSection -> IO (Executable, [GhcOption]) fromExecutableSection ExecutableSection{..} = do modules <- maybe (filterMain . concat <$> mapM (getModules dir) sectionSourceDirs) (return . fromList) executableSectionOtherModules return (Executable name mainSrcFile modules, ghcOptions) where filterMain :: [String] -> [String] filterMain = maybe id (filter . (/=)) (toModule $ splitDirectories executableSectionMain) (mainSrcFile, ghcOptions) = parseMain executableSectionMain mergeSections :: Section global -> Section a -> Section a mergeSections globalOptions options = Section { sectionData = sectionData options , sectionSourceDirs = sectionSourceDirs globalOptions ++ sectionSourceDirs options , sectionDefaultExtensions = sectionDefaultExtensions globalOptions ++ sectionDefaultExtensions options , sectionOtherExtensions = sectionOtherExtensions globalOptions ++ sectionOtherExtensions options , sectionGhcOptions = sectionGhcOptions globalOptions ++ sectionGhcOptions options , sectionGhcProfOptions = sectionGhcProfOptions globalOptions ++ sectionGhcProfOptions options , sectionCppOptions = sectionCppOptions globalOptions ++ sectionCppOptions options , sectionCSources = sectionCSources globalOptions ++ sectionCSources options , sectionExtraLibDirs = sectionExtraLibDirs globalOptions ++ sectionExtraLibDirs options , sectionExtraLibraries = sectionExtraLibraries globalOptions ++ sectionExtraLibraries options , sectionIncludeDirs = sectionIncludeDirs globalOptions ++ sectionIncludeDirs options , sectionInstallIncludes = sectionInstallIncludes globalOptions ++ sectionInstallIncludes options , sectionLdOptions = sectionLdOptions globalOptions ++ sectionLdOptions options , sectionBuildable = sectionBuildable options <|> sectionBuildable globalOptions , sectionDependencies = sectionDependencies globalOptions ++ sectionDependencies options , sectionConditionals = sectionConditionals globalOptions ++ sectionConditionals options , sectionBuildTools = sectionBuildTools globalOptions ++ sectionBuildTools options } toSection :: a -> CommonOptions -> ([FieldName], Section a) toSection a CommonOptions{..} = ( concat unknownFields , Section { sectionData = a , sectionSourceDirs = fromMaybeList commonOptionsSourceDirs , sectionDefaultExtensions = fromMaybeList commonOptionsDefaultExtensions , sectionOtherExtensions = fromMaybeList commonOptionsOtherExtensions , sectionGhcOptions = fromMaybeList commonOptionsGhcOptions , sectionGhcProfOptions = fromMaybeList commonOptionsGhcProfOptions , sectionCppOptions = fromMaybeList commonOptionsCppOptions , sectionCSources = fromMaybeList commonOptionsCSources , sectionExtraLibDirs = fromMaybeList commonOptionsExtraLibDirs , sectionExtraLibraries = fromMaybeList commonOptionsExtraLibraries , sectionIncludeDirs = fromMaybeList commonOptionsIncludeDirs , sectionInstallIncludes = fromMaybeList commonOptionsInstallIncludes , sectionLdOptions = fromMaybeList commonOptionsLdOptions , sectionBuildable = commonOptionsBuildable , sectionDependencies = fromMaybeList commonOptionsDependencies , sectionConditionals = conditionals , sectionBuildTools = fromMaybeList commonOptionsBuildTools } ) where (unknownFields, conditionals) = unzip (map toConditional $ fromMaybeList commonOptionsWhen) toConditional :: ConditionalSection -> ([FieldName], Conditional) toConditional x = case x of ThenElseConditional (CaptureUnknownFields fields (ThenElse condition (CaptureUnknownFields fieldsThen then_) (CaptureUnknownFields fieldsElse else_))) -> (fields ++ fieldsThen ++ fieldsElse, Conditional condition (() <$ then_) (Just (() <$ else_))) FlatConditional (CaptureUnknownFields fields sect) -> (fields, Conditional (conditionCondition $ sectionData sect) (() <$ sect) Nothing) pathsModuleFromPackageName :: String -> String pathsModuleFromPackageName name = "Paths_" ++ map f name where f '-' = '_' f x = x determineModules :: String -> [String] -> Maybe (List String) -> Maybe (List String) -> ([String], [String]) determineModules name modules mExposedModules mOtherModules = case (mExposedModules, mOtherModules) of (Nothing, Nothing) -> (modules, []) _ -> (exposedModules, otherModules) where otherModules = maybe ((modules \\ exposedModules) ++ pathsModule) fromList mOtherModules exposedModules = maybe (modules \\ otherModules) fromList mExposedModules pathsModule = [pathsModuleFromPackageName name] \\ exposedModules getModules :: FilePath -> FilePath -> IO [String] getModules dir src_ = sort <$> do exists <- doesDirectoryExist (dir src_) if exists then do src <- canonicalizePath (dir src_) removeSetup src . toModules <$> getFilesRecursive src else return [] where toModules :: [[FilePath]] -> [String] toModules = catMaybes . map toModule removeSetup :: FilePath -> [String] -> [String] removeSetup src | src == dir = filter (/= "Setup") | otherwise = id fromMaybeList :: Maybe (List a) -> [a] fromMaybeList = maybe [] fromList hpack-0.14.1/src/Hpack/FormattingHints.hs0000644000000000000000000000741312706324120016344 0ustar0000000000000000{-# 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) hpack-0.14.1/src/Hpack/GenericsUtil.hs0000644000000000000000000000242612726536046015636 0ustar0000000000000000{-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Hpack.GenericsUtil ( HasTypeName , typeName , Selectors , selectors ) where import Data.Proxy import GHC.Generics class HasTypeName a where typeName :: Proxy a -> String instance (Datatype d, Generic a, Rep a ~ M1 D d m) => HasTypeName a where typeName _ = datatypeName (undefined :: M1 D d x y) selectors :: (Selectors (Rep a)) => Proxy a -> [String] selectors = f where f :: forall a. (Selectors (Rep a)) => Proxy a -> [String] f _ = selNames (Proxy :: Proxy (Rep a)) class Selectors a where selNames :: Proxy a -> [String] instance Selectors f => Selectors (M1 D x f) where selNames _ = selNames (Proxy :: Proxy f) instance Selectors f => Selectors (M1 C x f) where selNames _ = selNames (Proxy :: Proxy f) instance Selector s => Selectors (M1 S s (K1 R t)) where selNames _ = [selName (undefined :: M1 S s (K1 R t) ())] instance (Selectors a, Selectors b) => Selectors (a :*: b) where selNames _ = selNames (Proxy :: Proxy a) ++ selNames (Proxy :: Proxy b) instance Selectors U1 where selNames _ = [] hpack-0.14.1/src/Hpack/Haskell.hs0000644000000000000000000000174512551635302014616 0ustar0000000000000000module Hpack.Haskell ( isModule , isQualifiedIdentifier , isIdentifier ) where import Data.Char isModule :: [String] -> Bool isModule name = (not . null) name && all isModuleName name isModuleName :: String -> Bool isModuleName name = case name of x : xs -> isUpper x && all isIdChar xs _ -> False isQualifiedIdentifier :: [String] -> Bool isQualifiedIdentifier name = case reverse name of x : xs -> isIdentifier x && isModule xs _ -> False isIdentifier :: String -> Bool isIdentifier name = case name of x : xs -> isLower x && all isIdChar xs && name `notElem` reserved _ -> False reserved :: [String] reserved = [ "case" , "class" , "data" , "default" , "deriving" , "do" , "else" , "foreign" , "if" , "import" , "in" , "infix" , "infixl" , "infixr" , "instance" , "let" , "module" , "newtype" , "of" , "then" , "type" , "where" , "_" ] isIdChar :: Char -> Bool isIdChar c = isAlphaNum c || c == '_' || c == '\'' hpack-0.14.1/src/Hpack/Render.hs0000644000000000000000000001026512706324120014442 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# 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 Data.String import Data.List.Compat data Value = Literal String | CommaSeparatedList [String] | LineSeparatedList [String] | WordList [String] deriving (Eq, Show) data Element = Stanza String [Element] | Group Element Element | Field String Value deriving (Eq, Show) data Lines = SingleLine String | MultipleLines [String] deriving (Eq, Show) data CommaStyle = LeadingCommas | TrailingCommas deriving (Eq, Show) newtype Nesting = Nesting Int deriving (Eq, Show, Num, Enum) newtype Alignment = Alignment Int deriving (Eq, Show, Num) data RenderSettings = RenderSettings { renderSettingsIndentation :: Int , renderSettingsFieldAlignment :: Alignment , renderSettingsCommaStyle :: CommaStyle } deriving (Eq, Show) defaultRenderSettings :: RenderSettings defaultRenderSettings = RenderSettings 2 0 LeadingCommas render :: RenderSettings -> Nesting -> Element -> [String] render settings nesting (Stanza name elements) = indent settings nesting name : renderElements settings (succ nesting) elements render settings nesting (Group a b) = render settings nesting a ++ render settings nesting b render settings nesting (Field name value) = renderField settings nesting name value renderElements :: RenderSettings -> Nesting -> [Element] -> [String] renderElements settings nesting = concatMap (render settings nesting) renderField :: RenderSettings -> Nesting -> String -> Value -> [String] renderField settings@RenderSettings{..} nesting name value = case renderValue settings value of SingleLine "" -> [] SingleLine x -> [indent settings nesting (name ++ ": " ++ padding ++ x)] MultipleLines [] -> [] MultipleLines xs -> (indent settings nesting name ++ ":") : map (indent settings $ succ nesting) xs where Alignment fieldAlignment = renderSettingsFieldAlignment padding = replicate (fieldAlignment - length name - 2) ' ' renderValue :: RenderSettings -> Value -> Lines renderValue RenderSettings{..} v = case v of Literal s -> SingleLine s WordList ws -> SingleLine $ unwords ws LineSeparatedList xs -> renderLineSeparatedList renderSettingsCommaStyle xs CommaSeparatedList xs -> renderCommaSeparatedList renderSettingsCommaStyle xs renderLineSeparatedList :: CommaStyle -> [String] -> Lines renderLineSeparatedList style = MultipleLines . map (padding ++) where padding = case style of LeadingCommas -> " " TrailingCommas -> "" renderCommaSeparatedList :: CommaStyle -> [String] -> Lines renderCommaSeparatedList style = MultipleLines . case style of LeadingCommas -> map renderLeadingComma . zip (True : repeat False) TrailingCommas -> map renderTrailingComma . reverse . zip (True : repeat False) . reverse where renderLeadingComma :: (Bool, String) -> String renderLeadingComma (isFirst, x) | isFirst = " " ++ x | otherwise = ", " ++ x renderTrailingComma :: (Bool, String) -> String renderTrailingComma (isLast, x) | isLast = x | otherwise = x ++ "," instance IsString Value where fromString = Literal indent :: RenderSettings -> Nesting -> String -> String indent RenderSettings{..} (Nesting nesting) s = replicate (nesting * renderSettingsIndentation) ' ' ++ s sortFieldsBy :: [String] -> [Element] -> [Element] sortFieldsBy existingFieldOrder = map snd . sortOn fst . addSortKey . map (\a -> (existingIndex a, a)) where existingIndex :: Element -> Maybe Int existingIndex (Field name _) = name `elemIndex` existingFieldOrder existingIndex _ = Nothing addSortKey :: [(Maybe Int, a)] -> [((Int, Int), a)] addSortKey = go (-1) . zip [0..] where go :: Int -> [(Int, (Maybe Int, a))] -> [((Int, Int), a)] go n xs = case xs of [] -> [] (x, (Just y, a)) : ys -> ((y, x), a) : go y ys (x, (Nothing, a)) : ys -> ((n, x), a) : go n ys hpack-0.14.1/src/Hpack/Run.hs0000644000000000000000000002266412714052040013773 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE CPP #-} module Hpack.Run ( run , renderPackage , RenderSettings(..) , Alignment(..) , CommaStyle(..) , defaultRenderSettings #ifdef TEST , renderConditional , renderFlag , renderSourceRepository , formatDescription #endif ) where import Prelude () import Prelude.Compat import Control.Monad import Data.Char import Data.Maybe import Data.List.Compat import System.Exit.Compat import System.FilePath import Hpack.Util import Hpack.Config import Hpack.Render import Hpack.FormattingHints run :: FilePath -> IO ([String], FilePath, String) run dir = do mPackage <- readPackageConfig (dir packageConfig) case mPackage of Right (warnings, pkg) -> do let cabalFile = dir (packageName pkg ++ ".cabal") old <- tryReadFile cabalFile let FormattingHints{..} = sniffFormattingHints (fromMaybe "" old) alignment = fromMaybe 16 formattingHintsAlignment settings = formattingHintsRenderSettings output = renderPackage settings alignment formattingHintsFieldOrder formattingHintsSectionsFieldOrder pkg return (warnings, cabalFile, output) Left err -> die err renderPackage :: RenderSettings -> Alignment -> [String] -> [(String, [String])] -> Package -> String renderPackage settings alignment existingFieldOrder sectionsFieldOrder Package{..} = intercalate "\n" (unlines header : chunks) where chunks :: [String] chunks = map unlines . filter (not . null) . map (render settings 0) $ sortSectionFields sectionsFieldOrder stanzas header :: [String] header = concatMap (render settings {renderSettingsFieldAlignment = alignment} 0) fields extraSourceFiles :: Element extraSourceFiles = Field "extra-source-files" (LineSeparatedList packageExtraSourceFiles) dataFiles :: Element dataFiles = Field "data-files" (LineSeparatedList packageDataFiles) sourceRepository = maybe [] (return . renderSourceRepository) packageSourceRepository library = maybe [] (return . renderLibrary) packageLibrary stanzas :: [Element] stanzas = extraSourceFiles : dataFiles : sourceRepository ++ concat [ map renderFlag packageFlags , library , renderExecutables packageExecutables , renderTests packageTests , renderBenchmarks packageBenchmarks ] fields :: [Element] fields = sortFieldsBy existingFieldOrder . mapMaybe (\(name, value) -> Field name . Literal <$> value) $ [ ("name", Just packageName) , ("version", Just packageVersion) , ("synopsis", packageSynopsis) , ("description", (formatDescription alignment <$> packageDescription)) , ("category", packageCategory) , ("stability", packageStability) , ("homepage", packageHomepage) , ("bug-reports", packageBugReports) , ("author", formatList packageAuthor) , ("maintainer", formatList packageMaintainer) , ("copyright", formatList packageCopyright) , ("license", packageLicense) , ("license-file", packageLicenseFile) , ("tested-with", packageTestedWith) , ("build-type", Just "Simple") , ("cabal-version", cabalVersion) ] formatList :: [String] -> Maybe String formatList xs = guard (not $ null xs) >> (Just $ intercalate separator xs) where separator = let Alignment n = alignment in ",\n" ++ replicate n ' ' cabalVersion :: Maybe String cabalVersion = maximum [ Just ">= 1.10" , packageLibrary >>= libCabalVersion ] where libCabalVersion :: Section Library -> Maybe String libCabalVersion sect = ">= 1.21" <$ guard (hasReexportedModules sect) hasReexportedModules :: Section Library -> Bool hasReexportedModules = not . null . libraryReexportedModules . sectionData sortSectionFields :: [(String, [String])] -> [Element] -> [Element] sortSectionFields sectionsFieldOrder = go where go sections = case sections of [] -> [] Stanza name fields : xs | Just fieldOrder <- lookup name sectionsFieldOrder -> Stanza name (sortFieldsBy fieldOrder fields) : go xs x : xs -> x : go xs formatDescription :: Alignment -> String -> String formatDescription (Alignment alignment) description = case map emptyLineToDot $ lines description of x : xs -> intercalate "\n" (x : map (indentation ++) xs) [] -> "" where n = max alignment (length ("description: " :: String)) indentation = replicate n ' ' emptyLineToDot xs | isEmptyLine xs = "." | otherwise = xs isEmptyLine = all isSpace renderSourceRepository :: SourceRepository -> Element renderSourceRepository SourceRepository{..} = Stanza "source-repository head" [ Field "type" "git" , Field "location" (Literal sourceRepositoryUrl) , Field "subdir" (maybe "" Literal sourceRepositorySubdir) ] renderFlag :: Flag -> Element renderFlag Flag {..} = Stanza ("flag " ++ flagName) $ description ++ [ Field "manual" (Literal $ show flagManual) , Field "default" (Literal $ show flagDefault) ] where description = maybe [] (return . Field "description" . Literal) flagDescription renderExecutables :: [Section Executable] -> [Element] renderExecutables = map renderExecutable renderExecutable :: Section Executable -> Element renderExecutable sect@(sectionData -> Executable{..}) = Stanza ("executable " ++ executableName) (renderExecutableSection sect) renderTests :: [Section Executable] -> [Element] renderTests = map renderTest renderTest :: Section Executable -> Element renderTest sect@(sectionData -> Executable{..}) = Stanza ("test-suite " ++ executableName) (Field "type" "exitcode-stdio-1.0" : renderExecutableSection sect) renderBenchmarks :: [Section Executable] -> [Element] renderBenchmarks = map renderBenchmark renderBenchmark :: Section Executable -> Element renderBenchmark sect@(sectionData -> Executable{..}) = Stanza ("benchmark " ++ executableName) (Field "type" "exitcode-stdio-1.0" : renderExecutableSection sect) renderExecutableSection :: Section Executable -> [Element] renderExecutableSection sect@(sectionData -> Executable{..}) = mainIs : renderSection sect ++ [otherModules, defaultLanguage] where mainIs = Field "main-is" (Literal executableMain) otherModules = renderOtherModules executableOtherModules renderLibrary :: Section Library -> Element renderLibrary sect@(sectionData -> Library{..}) = Stanza "library" $ renderSection sect ++ maybe [] (return . renderExposed) libraryExposed ++ [ renderExposedModules libraryExposedModules , renderOtherModules libraryOtherModules , renderReexportedModules libraryReexportedModules , defaultLanguage ] renderExposed :: Bool -> Element renderExposed = Field "exposed" . Literal . show renderSection :: Section a -> [Element] renderSection Section{..} = [ renderSourceDirs sectionSourceDirs , renderDefaultExtensions sectionDefaultExtensions , renderOtherExtensions sectionOtherExtensions , renderGhcOptions sectionGhcOptions , renderGhcProfOptions sectionGhcProfOptions , renderCppOptions sectionCppOptions , Field "include-dirs" (LineSeparatedList sectionIncludeDirs) , Field "install-includes" (LineSeparatedList sectionInstallIncludes) , Field "c-sources" (LineSeparatedList sectionCSources) , Field "extra-lib-dirs" (LineSeparatedList sectionExtraLibDirs) , Field "extra-libraries" (LineSeparatedList sectionExtraLibraries) , renderLdOptions sectionLdOptions , renderDependencies sectionDependencies , renderBuildTools sectionBuildTools ] ++ maybe [] (return . renderBuildable) sectionBuildable ++ map renderConditional sectionConditionals renderConditional :: Conditional -> Element renderConditional (Conditional condition sect mElse) = case mElse of Nothing -> if_ Just else_ -> Group if_ (Stanza "else" $ renderSection else_) where if_ = Stanza ("if " ++ condition) (renderSection sect) defaultLanguage :: Element defaultLanguage = Field "default-language" "Haskell2010" renderSourceDirs :: [String] -> Element renderSourceDirs = Field "hs-source-dirs" . CommaSeparatedList renderExposedModules :: [String] -> Element renderExposedModules = Field "exposed-modules" . LineSeparatedList renderOtherModules :: [String] -> Element renderOtherModules = Field "other-modules" . LineSeparatedList renderReexportedModules :: [String] -> Element renderReexportedModules = Field "reexported-modules" . LineSeparatedList renderDependencies :: [Dependency] -> Element renderDependencies = Field "build-depends" . CommaSeparatedList . map dependencyName renderGhcOptions :: [GhcOption] -> Element renderGhcOptions = Field "ghc-options" . WordList renderGhcProfOptions :: [GhcProfOption] -> Element renderGhcProfOptions = Field "ghc-prof-options" . WordList renderCppOptions :: [CppOption] -> Element renderCppOptions = Field "cpp-options" . WordList renderLdOptions :: [LdOption] -> Element renderLdOptions = Field "ld-options" . WordList renderBuildable :: Bool -> Element renderBuildable = Field "buildable" . Literal . show renderDefaultExtensions :: [String] -> Element renderDefaultExtensions = Field "default-extensions" . WordList renderOtherExtensions :: [String] -> Element renderOtherExtensions = Field "other-extensions" . WordList renderBuildTools :: [Dependency] -> Element renderBuildTools = Field "build-tools" . CommaSeparatedList . map dependencyName hpack-0.14.1/src/Hpack/Util.hs0000644000000000000000000000730112706324120014135 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} module Hpack.Util ( List(..) , GhcOption , GhcProfOption , CppOption , LdOption , parseMain , toModule , getFilesRecursive , tryReadFile , expandGlobs , sort , lexicographically ) where import Prelude () import Prelude.Compat import Control.Applicative import Control.DeepSeq import Control.Exception import Control.Monad.Compat import Data.Aeson.Types import Data.Char import Data.Data import Data.List.Compat hiding (sort) import Data.Ord import System.Directory import System.FilePath import qualified System.FilePath.Posix as Posix import System.FilePath.Glob import Hpack.Haskell sort :: [String] -> [String] sort = sortBy (comparing lexicographically) lexicographically :: String -> (String, String) lexicographically x = (map toLower x, x) newtype List a = List {fromList :: [a]} deriving (Eq, Show, Data, Typeable) instance FromJSON a => FromJSON (List a) where parseJSON v = List <$> case v of Array _ -> parseJSON v _ -> return <$> parseJSON v type GhcOption = String type GhcProfOption = String type CppOption = String type LdOption = String parseMain :: String -> (FilePath, [GhcOption]) parseMain main = case reverse name of x : _ | isQualifiedIdentifier name && x `notElem` ["hs", "lhs"] -> (intercalate "/" (init name) ++ ".hs", ["-main-is " ++ main]) _ | isModule name -> (intercalate "/" name ++ ".hs", ["-main-is " ++ main]) _ -> (main, []) where name = splitOn '.' main splitOn :: Char -> String -> [String] splitOn c = go where go xs = case break (== c) xs of (ys, "") -> [ys] (ys, _:zs) -> ys : go zs 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 (isModule name) >> return (intercalate "." name) where stripSuffix :: String -> String -> Maybe String stripSuffix suffix x = reverse <$> stripPrefix (reverse suffix) (reverse x) getFilesRecursive :: FilePath -> IO [[String]] getFilesRecursive baseDir = 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 toPosixFilePath :: FilePath -> FilePath toPosixFilePath = Posix.joinPath . splitDirectories expandGlobs :: FilePath -> [String] -> IO ([String], [FilePath]) expandGlobs dir patterns = do files <- (fst <$> globDir compiledPatterns dir) >>= mapM removeDirectories let warnings = [warn pattern | ([], pattern) <- zip files patterns] return (warnings, combineResults files) where combineResults = nub . sort . map (toPosixFilePath . makeRelative dir) . concat warn pattern = "Specified pattern " ++ show pattern ++ " for extra-source-files does not match any files" compiledPatterns = map (compileWith options) patterns removeDirectories = filterM doesFileExist options = CompOptions { characterClasses = False , characterRanges = False , numberRanges = False , wildcards = True , recursiveWildcards = True , pathSepInRanges = False , errorRecovery = True } hpack-0.14.1/src/Hpack/Yaml.hs0000644000000000000000000000114612601277064014133 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} module Hpack.Yaml where import Data.Yaml decodeYaml :: FromJSON a => FilePath -> IO (Either String a) decodeYaml file = do result <- decodeFileEither file return $ either (Left . errToString) Right result 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 hpack-0.14.1/LICENSE0000644000000000000000000000206712706324120012060 0ustar0000000000000000Copyright (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 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. hpack-0.14.1/Setup.lhs0000755000000000000000000000011412515475744012676 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain hpack-0.14.1/hpack.cabal0000644000000000000000000000441412726545040013133 0ustar0000000000000000-- This file has been generated from package.yaml by hpack version 0.14.0. -- -- see: https://github.com/sol/hpack name: hpack version: 0.14.1 synopsis: An alternative format for Haskell packages category: Development homepage: https://github.com/sol/hpack#readme bug-reports: https://github.com/sol/hpack/issues maintainer: Simon Hengel license: MIT license-file: LICENSE build-type: Simple cabal-version: >= 1.10 source-repository head type: git location: https://github.com/sol/hpack library hs-source-dirs: src ghc-options: -Wall build-depends: base >= 4.7 && < 5 , base-compat >= 0.8 , deepseq , directory , filepath , Glob , text , containers , unordered-containers , yaml , aeson >= 0.8 exposed-modules: Hpack Hpack.Config Hpack.Run Hpack.Yaml other-modules: Hpack.FormattingHints Hpack.GenericsUtil Hpack.Haskell Hpack.Render Hpack.Util Paths_hpack default-language: Haskell2010 executable hpack main-is: Main.hs hs-source-dirs: driver ghc-options: -Wall build-depends: base >= 4.7 && < 5 , base-compat >= 0.8 , deepseq , directory , filepath , Glob , text , containers , unordered-containers , yaml , hpack , aeson >= 0.8 default-language: Haskell2010 test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs hs-source-dirs: test , src ghc-options: -Wall cpp-options: -DTEST build-depends: base >= 4.7 && < 5 , base-compat >= 0.8 , deepseq , directory , filepath , Glob , text , containers , unordered-containers , yaml , hspec == 2.* , QuickCheck , temporary , mockery >= 0.3 , interpolate , aeson-qq , aeson >= 0.10 other-modules: Helper Hpack.ConfigSpec Hpack.FormattingHintsSpec Hpack.GenericsUtilSpec Hpack.HaskellSpec Hpack.RenderSpec Hpack.RunSpec Hpack.UtilSpec HpackSpec Hpack Hpack.Config Hpack.FormattingHints Hpack.GenericsUtil Hpack.Haskell Hpack.Render Hpack.Run Hpack.Util Hpack.Yaml default-language: Haskell2010