diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2014-2016 Simon Hengel + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/driver/Main.hs b/driver/Main.hs new file mode 100644 --- /dev/null +++ b/driver/Main.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import qualified Hpack + +main :: IO () +main = Hpack.main diff --git a/hpack-convert.cabal b/hpack-convert.cabal new file mode 100644 --- /dev/null +++ b/hpack-convert.cabal @@ -0,0 +1,133 @@ +-- This file has been generated from package.yaml by hpack version 0.14.1. +-- +-- see: https://github.com/sol/hpack + +name: hpack-convert +version: 0.14.1 +synopsis: Convert Cabal manifests into hpack's package.yamls +category: Development +homepage: https://github.com/yamadapc/hpack-convert#readme +bug-reports: https://github.com/yamadapc/hpack-convert/issues +maintainer: Pedro Tacla Yamada +license: MIT +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +source-repository head + type: git + location: https://github.com/yamadapc/hpack-convert + +library + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + base >= 4.7 && < 5 + , base-compat >= 0.8 + , Cabal + , pretty + , deepseq + , directory + , filepath + , Glob + , text + , containers + , unordered-containers + , yaml + , bytestring + , vector + , aeson >= 0.8 + exposed-modules: + Hpack + Hpack.Config + Hpack.Run + Hpack.Yaml + other-modules: + Hpack.Convert + Hpack.Convert.Run + Hpack.FormattingHints + Hpack.GenericsUtil + Hpack.Haskell + Hpack.Render + Hpack.Util + Paths_hpack_convert + default-language: Haskell2010 + +executable hpack-convert + main-is: Main.hs + hs-source-dirs: + driver + ghc-options: -Wall + build-depends: + base >= 4.7 && < 5 + , base-compat >= 0.8 + , Cabal + , pretty + , deepseq + , directory + , filepath + , Glob + , text + , containers + , unordered-containers + , yaml + , bytestring + , vector + , hpack-convert + , 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 + , Cabal + , pretty + , deepseq + , directory + , filepath + , Glob + , text + , containers + , unordered-containers + , yaml + , bytestring + , vector + , hspec == 2.* + , QuickCheck + , temporary + , mockery >= 0.3 + , interpolate + , aeson-qq + , aeson >= 0.10 + other-modules: + Helper + Hpack.ConfigSpec + Hpack.ConvertSpec + Hpack.FormattingHintsSpec + Hpack.GenericsUtilSpec + Hpack.HaskellSpec + Hpack.RenderSpec + Hpack.RunSpec + Hpack.UtilSpec + HpackSpec + Hpack + Hpack.Config + Hpack.Convert + Hpack.Convert.Run + Hpack.FormattingHints + Hpack.GenericsUtil + Hpack.Haskell + Hpack.Render + Hpack.Run + Hpack.Util + Hpack.Yaml + default-language: Haskell2010 diff --git a/src/Hpack.hs b/src/Hpack.hs new file mode 100644 --- /dev/null +++ b/src/Hpack.hs @@ -0,0 +1,131 @@ +{-# 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_convert (version) +import Hpack.Config +import Hpack.Convert.Run +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 + _ -> runConvert + +printHelp :: IO () +printHelp = do + hPutStrLn stderr $ unlines [ + "Usage: hpack-convert [ dir | cabalfile ]" + , " hpack-convert --version" + , " hpack-convert --help" + ] + +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 diff --git a/src/Hpack/Config.hs b/src/Hpack/Config.hs new file mode 100644 --- /dev/null +++ b/src/Hpack/Config.hs @@ -0,0 +1,1022 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE UndecidableInstances #-} +module Hpack.Config ( + packageConfig +, readPackageConfig +, encodePackage +, writePackage +, 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 +import Data.Aeson.Types +import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString +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 (elemIndex, intersect, isPrefixOf, nub, + sortBy, (\\)) +import Data.Maybe +import Data.Ord +import Data.String +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Vector as Vector +import qualified Data.Yaml.Pretty as Yaml +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/" + +jsonOptions :: String -> Options +jsonOptions name = defaultOptions { fieldLabelModifier = hyphenize name + , omitNothingFields = True + } + +genericToJSON_ :: forall a. (Generic a, GToJSON (Rep a), HasTypeName a) => a -> Value +genericToJSON_ = + removeEmptyObjects . + removeEmptyArrays . + genericToJSON (jsonOptions name) + where + name :: String + name = typeName (Proxy :: Proxy a) + +removeEmptyObjects :: Value -> Value +removeEmptyObjects (Object o) = Object $ HashMap.filter (/= Object mempty) o +removeEmptyObjects v = v + +removeEmptyArrays :: Value -> Value +removeEmptyArrays (Object o) = Object $ HashMap.filter (/= Array mempty) o +removeEmptyArrays v = v + +genericParseJSON_ :: forall a. (Generic a, GFromJSON (Rep a), HasTypeName a) => Value -> Parser a +genericParseJSON_ = genericParseJSON (jsonOptions 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) +, commonOptionsCCOptions :: Maybe (List CCOption) +, 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, Generic) + +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, Generic) + +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 ToJSON Package where + toJSON p = + removeEmptyArrays $ + removeEmptyObjects $ + (\(Object o) -> Object $ case packageSourceRepository p of + Just repo -> + let srepo = (sourceRepositoryUrl repo) ++ + (fromMaybe "" (sourceRepositorySubdir repo)) + in + if githubBaseUrl `isPrefixOf` srepo + then let dropIfGH (Just (String v)) + | githubBaseUrl `isPrefixOf` T.unpack v = Nothing + dropIfGH v = v + in + HashMap.insert "github" (String (T.pack (drop (length githubBaseUrl) srepo))) $ + HashMap.alter dropIfGH "bug-reports" $ + HashMap.alter dropIfGH "homepage" o + else HashMap.insert "git" (String (T.pack srepo)) o + Nothing -> o + ) $ + (\(Object o) -> Object $ HashMap.delete "source-repository" o) $ + (\(Object o) -> Object $ HashMap.mapWithKey convertSingletons o) $ + (\(Object o) -> + Object $ + HashMap.alter + (\l -> case l of + Just "LICENSE" -> Nothing + _ -> l) + "license-file" + o + ) $ + pullCommonFields "build-tools" $ + pullCommonFields "conditionals" $ + pullCommonFields "buildable" $ + pullCommonFields "ld-options" $ + pullCommonFields "install-includes" $ + pullCommonFields "include-dirs" $ + pullCommonFields "extra-libraries" $ + pullCommonFields "extra-lib-dirs" $ + pullCommonFields "c-sources" $ + pullCommonFields "cc-options" $ + pullCommonFields "cpp-options" $ + pullCommonFields "ghc-prof-options" $ + pullCommonFields "ghc-options" $ + pullCommonFields "other-extensions" $ + pullCommonFields "default-extensions" $ + pullCommonFields "other-modules" $ + pullCommonFields "source-dirs" $ + pullCommonFields "dependencies" (genericToJSON_ p) + +pullCommonFields :: Text -> Value -> Value +pullCommonFields field topLevel@(Object topLevelObj) = + let commonField = let deps = mapMaybe getField [ "library" + , "executables" + , "benchmarks" + , "tests" + ] + in maybe [] (\h -> foldl intersect h deps) (listToMaybe deps) + in mergeObjects (Object (filterCommon commonField)) $ + mergeObjects topLevel (object [ field .= commonField ]) + where + filterCommon :: [Value] -> HashMap.HashMap Text Value + filterCommon commonField = + let helper :: Maybe Value -> Maybe Value + helper (Just (Array vs)) = + let v = Vector.filter (not . (`elem` commonField)) vs + in if Vector.null v then Nothing else Just (Array v) + helper Nothing = Nothing + helper (Just v) = Just v + outerHelper = (\(Object sectObj) -> Object $ HashMap.alter helper field sectObj) + outermostHelper = (\(Object e) -> Object $ HashMap.map outerHelper e) + o' = HashMap.adjust outerHelper "library" topLevelObj + o'' = HashMap.adjust outermostHelper "executables" o' + o''' = HashMap.adjust outermostHelper "benchmarks" o'' + o'''' = HashMap.adjust outermostHelper "tests" o''' + in o'''' + getField "library" = + case (HashMap.lookup "library" topLevelObj >>= unObject) of + Nothing -> Nothing + Just lib -> do + return $ fromMaybe [] (HashMap.lookup field lib >>= unArray) + getField name = + case (HashMap.lookup name topLevelObj >>= unObject) of + Nothing -> Nothing + Just sect -> do + blocks <- mapM unObject (map snd (HashMap.toList sect)) + return $ concat $ mapMaybe (HashMap.lookup field >=> unArray) blocks + unArray (Array v) = Just (Vector.toList v) + unArray _ = Nothing + unObject (Object o) = Just o + unObject _ = Nothing +pullCommonFields _ v = v + +omitBuildableTrue :: Value -> Value +omitBuildableTrue (Object o) = Object (HashMap.filterWithKey f o) + where + f "buildable" (Bool True) = False + f _ _ = True +omitBuildableTrue v = v + +omitSection :: Value -> Value +omitSection (Object o) = Object $ + HashMap.mapWithKey convertSingletons $ + HashMap.filterWithKey omitSectionEntry o +omitSection v = v + +convertSingletons :: Text -> Value -> Value +convertSingletons "ghc-options" (Array a) = convertSingleton a +convertSingletons "cpp-options" (Array a) = convertSingleton a +convertSingletons "cc-options" (Array a) = convertSingleton a +convertSingletons "c-sources" (Array a) = convertSingleton a +convertSingletons "ld-options" (Array a) = convertSingleton a +convertSingletons "ghc-prof-options" (Array a) = convertSingleton a +convertSingletons "extra-lib-dirs" (Array a) = convertSingleton a +convertSingletons "extra-libraries" (Array a) = convertSingleton a +convertSingletons "copyright" (Array a) = convertSingleton a +convertSingletons "maintainer" (Array a) = convertSingleton a +convertSingletons "author" (Array a) = convertSingleton a +convertSingletons "source-dirs" (Array a) = convertSingleton a +convertSingletons _ v = v + +convertSingleton :: Vector.Vector Value -> Value +convertSingleton a = + if Vector.length a == 1 + then Vector.head a + else Array a + +omitSectionEntry :: Text -> Value -> Bool +omitSectionEntry "license-file" "LICENSE" = False +omitSectionEntry "data" _ = False +omitSectionEntry "conditionals" _ = False +omitSectionEntry "name" _ = False +omitSectionEntry "exposed" (Bool True) = False +omitSectionEntry "other-modules" _ = False +omitSectionEntry _ _ = True + +mergeObjects :: Value -> Value -> Value +mergeObjects (Object o1) (Object o2) = Object (o1 `mappend` o2) +mergeObjects (Object o1) _ = Object o1 +mergeObjects _ (Object o2) = Object o2 +mergeObjects v _ = v + +instance ToJSON [Section Executable] where + toJSON ss = Object $ + HashMap.fromList $ map helper ss + where + helper sect@Section{..} = ( T.pack (executableName sectionData) + , toJSON sect + ) + +instance {-# OVERLAPS #-} ToJSON (Section ()) where + toJSON sect@Section{..} = + (omitSection + (mergeObjects + (mergeObjects + (genericToJSON_ sect) + (toJSON sectionData)) + (object $ case sectionConditionals of + [] -> [] + cs -> case toJSON (omitRedundantBuildables cs) of + Array [] -> [] + Array csObjs -> case Vector.filter (/= Object mempty) csObjs of + [] -> [] + csV -> ["when" .= csV] + v -> ["when" .= v]))) + where + omitRedundantBuildables = map $ \(Conditional c i e) -> + Conditional c (omitRedundantBuildable i) (omitRedundantBuildable <$> e) + omitRedundantBuildable s + | fromMaybe True sectionBuildable == + fromMaybe True (Hpack.Config.sectionBuildable s) = + s {sectionBuildable = Nothing} + omitRedundantBuildable s = s + +instance (Generic (Section a), GToJSON (Rep (Section a)), HasTypeName (Section a), + ToJSON a) => ToJSON (Section a) where + toJSON sect@Section{..} = + omitBuildableTrue (omitSection + (mergeObjects + (mergeObjects + (genericToJSON_ sect) + (toJSON sectionData)) + (object $ case sectionConditionals of + [] -> [] + cs -> case toJSON (omitRedundantBuildables cs) of + Array [] -> [] + Array csObjs -> case Vector.filter (/= Object mempty) csObjs of + [] -> [] + csV -> ["when" .= csV] + csArr -> ["when" .= csArr]))) + where + omitRedundantBuildables = map $ \(Conditional c i e) -> + Conditional c (omitRedundantBuildable i) (omitRedundantBuildable <$> e) + omitRedundantBuildable s + | fromMaybe True sectionBuildable == + fromMaybe True (Hpack.Config.sectionBuildable s) = + s {sectionBuildable = Nothing} + omitRedundantBuildable s = s + +instance ToJSON Conditional where + toJSON (Conditional cnd ifSection Nothing) = case toJSON ifSection of + -- If an empty block is generated strip it out + Object [] -> object [] + ifSectionObj -> mergeObjects (object [ "condition" .= toJSON cnd ]) ifSectionObj + toJSON (Conditional cnd ifSection (Just elseSection)) = case toJSON ifSection of + -- If an empty block is at the if statement negate the condition + Object [] -> toJSON (Conditional ("!(" ++ cnd ++ ")") elseSection Nothing) + ifSectionObj -> case toJSON elseSection of + Object [] -> toJSON (Conditional cnd ifSection Nothing) + elseSectionObj -> + object [ "condition" .= toJSON cnd + , "then" .= ifSectionObj + , "else" .= elseSectionObj + ] + +instance ToJSON AddSource where + toJSON = genericToJSON_ + +instance ToJSON Dependency where + toJSON (Dependency d Nothing) = fromString d + toJSON (Dependency d (Just ref)) = + object ([ "name" .= d + ] `mappend` case toJSON ref of + Object ps -> HashMap.toList ps + _ -> mempty) + +instance ToJSON Executable where + toJSON = genericToJSON_ + +instance ToJSON Library where + toJSON = genericToJSON_ + +instance ToJSON [Flag] where + toJSON fs = Object $ + HashMap.fromList $ map helper fs + where + helper Flag{..} = ( T.pack flagName + , object [ "description" .= toJSON flagDescription + , "manual" .= toJSON flagManual + , "default" .= toJSON flagDefault + ] + ) + +instance ToJSON SourceRepository where + toJSON = genericToJSON_ + +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) + +encodePackage :: Package -> ByteString +encodePackage pkg = Yaml.encodePretty config pkg + where + config = Yaml.setConfCompare keyWeight Yaml.defConfig + keys = [ "condition" + , "then" + , "else" + , "name" + , "version" + , "synopsis" + , "description" + , "category" + , "author" + , "maintainer" + , "copyright" + , "license" + , "license-file" + , "github" + , "homepage" + , "git" + , "bug-reports" + , "main" + , "source-dirs" + , "extra-source-files" + , "c-sources" + , "default-extensions" + , "other-extensions" + , "ghc-options" + , "ghc-prof-options" + , "cc-options" + , "cpp-options" + , "ld-options" + , "extra-lib-dirs" + , "extra-libraries" + , "include-dirs" + , "install-includes" + , "build-tools" + , "exposed-modules" + , "dependencies" + , "buildable" + , "when" + , "library" + , "executables" + , "tests" + , "benchmarks" + ] + keyWeight k1 k2 = + fromMaybe maxBound (elemIndex k1 keys) + `compare` + fromMaybe maxBound (elemIndex k2 keys) + +writePackage :: FilePath -> Package -> IO () +writePackage fp pkg = ByteString.writeFile fp (encodePackage pkg) + +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, Generic) + +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, Generic) + +data Library = Library { + libraryExposed :: Maybe Bool +, libraryExposedModules :: [String] +, libraryOtherModules :: [String] +, libraryReexportedModules :: [String] +} deriving (Eq, Show, Generic) + +data Executable = Executable { + executableName :: String +, executableMain :: FilePath +, executableOtherModules :: [String] +} deriving (Eq, Show, Generic) + +data Section a = Section { + sectionData :: a +, sectionSourceDirs :: [FilePath] +, sectionDependencies :: [Dependency] +, sectionDefaultExtensions :: [String] +, sectionOtherExtensions :: [String] +, sectionGhcOptions :: [GhcOption] +, sectionGhcProfOptions :: [GhcProfOption] +, sectionCppOptions :: [CppOption] +, sectionCCOptions :: [CCOption] +, 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, Generic) + +data Conditional = Conditional { + conditionalCondition :: String +, conditionalThen :: Section () +, conditionalElse :: Maybe (Section ()) +} deriving (Eq, Show, Generic) + +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, Generic) + +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, Generic) + +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 + , sectionCCOptions = sectionCCOptions globalOptions ++ sectionCCOptions 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 + , sectionCCOptions = fromMaybeList commonOptionsCCOptions + , 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 diff --git a/src/Hpack/Convert.hs b/src/Hpack/Convert.hs new file mode 100644 --- /dev/null +++ b/src/Hpack/Convert.hs @@ -0,0 +1,264 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +module Hpack.Convert where + +import Control.Applicative +import Data.Maybe +import qualified Data.Version as Version +import qualified Distribution.Compiler as Compiler +import qualified Distribution.InstalledPackageInfo as Cabal +import qualified Distribution.Package as Cabal +import qualified Distribution.PackageDescription as Cabal +import qualified Distribution.PackageDescription.Parse as Cabal +import qualified Distribution.Text as Cabal +import qualified Distribution.Version as Cabal +import Hpack.Config hiding (package) +import Text.PrettyPrint (fsep, (<+>)) + +-- * Public API + +-- | Reads a 'Package' from cabal's 'GenericPackageDescription' representation +-- of a @.cabal@ file +fromPackageDescription :: Cabal.GenericPackageDescription -> Package +fromPackageDescription Cabal.GenericPackageDescription{..} = + let Cabal.PackageDescription{..} = packageDescription + in + Package { packageName = Cabal.unPackageName (Cabal.pkgName package) + , packageVersion = Version.showVersion (Cabal.pkgVersion package) + , packageSynopsis = nullNothing synopsis + , packageDescription = nullNothing description + , packageHomepage = nullNothing homepage + , packageBugReports = nullNothing bugReports + , packageCategory = nullNothing category + , packageStability = nullNothing stability + , packageAuthor = maybeToList (nullNothing author) + , packageMaintainer = maybeToList (nullNothing maintainer) + , packageCopyright = maybeToList (nullNothing copyright) + , packageLicense = Just (show (Cabal.disp license)) + , packageLicenseFile = listToMaybe licenseFiles + , packageTestedWith = + show . + fsep . map (\(f, vr) -> Cabal.disp f <+> Cabal.disp vr ) <$> + nullNothing testedWith + , packageFlags = + map (\Cabal.MkFlag{..} -> + let Cabal.FlagName fn = flagName + in Flag { flagName = fn + , flagDescription = + nullNothing flagDescription + , flagManual = flagManual + , flagDefault = flagDefault + }) + genPackageFlags + , packageExtraSourceFiles = extraSrcFiles + , packageDataFiles = dataFiles + , packageSourceRepository = fromSourceRepos sourceRepos + , packageLibrary = fromCondLibrary condLibrary + , packageExecutables = fromCondExecutables condExecutables + , packageTests = fromCondTestSuites condTestSuites + , packageBenchmarks = fromCondBenchmarks condBenchmarks + } + +-- | Reads a 'Package' from a @.cabal@ manifest string +fromPackageDescriptionString :: String -> Either ConvertError Package +fromPackageDescriptionString pkgStr = + case Cabal.parsePackageDescription pkgStr of + Cabal.ParseFailed e -> Left (ConvertCabalParseError e) + Cabal.ParseOk _ gpkg -> Right (fromPackageDescription gpkg) + +data ConvertError = ConvertCabalParseError Cabal.PError + deriving(Show, Eq) + +-- data ConvertWarning = CWIgnoreSection String +-- | CWIgnoreCondition String +-- | CWIgnoreSourceRepo Cabal.SourceRepo +-- | CWSourceRepoWithoutUrl Cabal.SourceRepo + +-- * Private functions for converting each section + +fromSourceRepos :: [Cabal.SourceRepo] -> Maybe SourceRepository +fromSourceRepos [] = Nothing +fromSourceRepos (_repo@Cabal.SourceRepo{..}:_more) = + -- ( + Just SourceRepository { sourceRepositoryUrl = fromMaybe "" repoLocation + -- TODO - this is broken (?) + , sourceRepositorySubdir = repoSubdir + } + -- TODO - Warnings + -- , case repoLocation of + -- Nothing -> [CWSourceRepoWithoutUrl repo] + -- _ -> [] + -- ++ map CWIgnoreSourceRepo more + -- ) + +fromDependency :: Cabal.Dependency -> Dependency +fromDependency (Cabal.Dependency pn Cabal.AnyVersion) = + Dependency (show (Cabal.disp pn)) Nothing +fromDependency (Cabal.Dependency pn vr) = + Dependency (show (Cabal.disp pn <+> Cabal.disp vr)) Nothing + +fromCondLibrary :: Maybe (Cabal.CondTree Cabal.ConfVar [Cabal.Dependency] Cabal.Library) -> Maybe (Section Library) +fromCondLibrary mcondLibrary = do + condLibrary@(Cabal.CondNode Cabal.Library{libBuildInfo} _ components) <- mcondLibrary + l <- libFromCondLibrary condLibrary + return (sectionWithBuildInfo l libBuildInfo) + { sectionConditionals = map fromCondComponentHasBuildInfo components + } + +fromCondExecutables :: [(String, Cabal.CondTree Cabal.ConfVar [Cabal.Dependency] Cabal.Executable)] -> [Section Executable] +fromCondExecutables = map fromCondExecutableTup + +fromCondTestSuites :: [(String, Cabal.CondTree Cabal.ConfVar [Cabal.Dependency] Cabal.TestSuite)] -> [Section Executable] +fromCondTestSuites = mapMaybe fromCondTestSuiteTup + +fromCondBenchmarks :: [(String, Cabal.CondTree Cabal.ConfVar [Cabal.Dependency] Cabal.Benchmark)] -> [Section Executable] +fromCondBenchmarks = mapMaybe fromCondBenchmarkTup + +fromCondExecutableTup :: (String, Cabal.CondTree Cabal.ConfVar [Cabal.Dependency] Cabal.Executable) -> Section Executable +fromCondExecutableTup etup@(_, Cabal.CondNode Cabal.Executable{buildInfo} _ components) = + let e = exeFromCondExecutableTup etup + in (sectionWithBuildInfo e buildInfo) + { sectionConditionals = map fromCondComponentHasBuildInfo components + } + +fromCondTestSuiteTup :: (String, Cabal.CondTree Cabal.ConfVar [Cabal.Dependency] Cabal.TestSuite) -> Maybe (Section Executable) +fromCondTestSuiteTup ttup@(_, Cabal.CondNode Cabal.TestSuite{testBuildInfo} _ components) = do + te <- testExeFromCondExecutableTup ttup + return (sectionWithBuildInfo te testBuildInfo) + { sectionConditionals = map fromCondComponentHasBuildInfo components + } + +fromCondBenchmarkTup :: (String, Cabal.CondTree Cabal.ConfVar [Cabal.Dependency] Cabal.Benchmark) -> Maybe (Section Executable) +fromCondBenchmarkTup btup@(_, Cabal.CondNode Cabal.Benchmark{benchmarkBuildInfo} _ components) = do + be <- benchExeFromCondExecutableTup btup + return (sectionWithBuildInfo be benchmarkBuildInfo) + { sectionConditionals = map fromCondComponentHasBuildInfo components + } + +-- * Conditional Mapping +class HasBuildInfo a where + getBuildInfo :: a -> Cabal.BuildInfo + +instance HasBuildInfo Cabal.Library where + getBuildInfo Cabal.Library{libBuildInfo} = libBuildInfo + +instance HasBuildInfo Cabal.Executable where + getBuildInfo Cabal.Executable{buildInfo} = buildInfo + +instance HasBuildInfo Cabal.TestSuite where + getBuildInfo Cabal.TestSuite{testBuildInfo} = testBuildInfo + +instance HasBuildInfo Cabal.Benchmark where + getBuildInfo Cabal.Benchmark{benchmarkBuildInfo} = benchmarkBuildInfo + +fromCondHasBuildInfo :: HasBuildInfo a => Cabal.CondTree Cabal.ConfVar [Cabal.Dependency] a -> Section () +fromCondHasBuildInfo (Cabal.CondNode hbi _ components) = + let bi = getBuildInfo hbi + in (sectionWithBuildInfo () bi) + { sectionConditionals = map fromCondComponentHasBuildInfo components + } + +fromCondComponentHasBuildInfo :: (HasBuildInfo a) + => ( Cabal.Condition Cabal.ConfVar + , Cabal.CondTree Cabal.ConfVar [Cabal.Dependency] a + , Maybe (Cabal.CondTree Cabal.ConfVar [Cabal.Dependency] a) + ) + -> Conditional +fromCondComponentHasBuildInfo (cond, ifTree, elseTree) = + Conditional { conditionalCondition = fromCondition cond + , conditionalThen = fromCondHasBuildInfo ifTree + , conditionalElse = fromCondHasBuildInfo <$> elseTree + } + +fromCondition :: Cabal.Condition Cabal.ConfVar -> String +fromCondition (Cabal.Var c) = case c of + Cabal.OS os -> "os(" ++ show (Cabal.disp os) ++ ")" + Cabal.Flag (Cabal.FlagName fl) -> "flag(" ++ fl ++ ")" + Cabal.Arch ar -> "arch(" ++ show (Cabal.disp ar) ++ ")" + Cabal.Impl cc vr -> "impl(" ++ show (Cabal.disp cc <+> Cabal.disp vr) ++ ")" +fromCondition (Cabal.CNot c) = "!(" ++ fromCondition c ++ ")" +fromCondition (Cabal.COr c1 c2) = "(" ++ fromCondition c1 ++ ") || (" ++ fromCondition c2 ++ ")" +fromCondition (Cabal.CAnd c1 c2) = "(" ++ fromCondition c1 ++ ") && (" ++ fromCondition c2 ++ ")" +fromCondition (Cabal.Lit b) = show b + + +-- * Private helpers + +-- | Builds a 'Package' 'Section' from a data entity and a 'BuildInfo' entity +sectionWithBuildInfo :: a -> Cabal.BuildInfo -> Section a +sectionWithBuildInfo d Cabal.BuildInfo{..} = + Section { sectionData = d + , sectionSourceDirs = hsSourceDirs + , sectionDependencies = map fromDependency targetBuildDepends + , sectionDefaultExtensions = map (show . Cabal.disp) + defaultExtensions + , sectionOtherExtensions = map (show . Cabal.disp) otherExtensions + , sectionGhcOptions = fromMaybe [] $ + lookup Compiler.GHC options + , sectionGhcProfOptions = fromMaybe [] $ + lookup Compiler.GHC profOptions + , sectionCppOptions = cppOptions + , sectionCCOptions = ccOptions + , sectionCSources = cSources + , sectionExtraLibDirs = extraLibDirs + , sectionExtraLibraries = extraLibs + , sectionIncludeDirs = includeDirs + , sectionInstallIncludes = installIncludes + , sectionLdOptions = ldOptions + , sectionBuildable = Just buildable + -- TODO ^^ ???? + , sectionConditionals = [] + -- TODO ^^ ???? + , sectionBuildTools = map fromDependency buildTools + } + +libFromCondLibrary :: Cabal.CondTree Cabal.ConfVar [Cabal.Dependency] Cabal.Library -> Maybe Library +libFromCondLibrary (Cabal.CondNode (Cabal.Library{..}) _ _) = do + let Cabal.BuildInfo{..} = libBuildInfo + return Library { libraryExposed = Just libExposed + , libraryExposedModules = map (show . Cabal.disp) + exposedModules + , libraryOtherModules = map (show . Cabal.disp) otherModules + , libraryReexportedModules = map (show . Cabal.disp) + reexportedModules + } + +exeFromCondExecutableTup :: (String, Cabal.CondTree Cabal.ConfVar [Cabal.Dependency] Cabal.Executable) -> Executable +exeFromCondExecutableTup (name, Cabal.CondNode Cabal.Executable{..} _ _) = + Executable { executableName = name + , executableMain = modulePath + , executableOtherModules = map (show . Cabal.disp) + (Cabal.otherModules buildInfo) + } + +testExeFromCondExecutableTup :: (String, Cabal.CondTree Cabal.ConfVar [Cabal.Dependency] Cabal.TestSuite) -> Maybe Executable +testExeFromCondExecutableTup (name, Cabal.CondNode Cabal.TestSuite{..} _ _) = + case testInterface of + Cabal.TestSuiteExeV10 _ mainIs -> Just + Executable { executableName = name + , executableMain = mainIs + , executableOtherModules = map (show . Cabal.disp) + (Cabal.otherModules testBuildInfo) + } + _ -> Nothing + +benchExeFromCondExecutableTup :: (String, Cabal.CondTree Cabal.ConfVar [Cabal.Dependency] Cabal.Benchmark) -> Maybe Executable +benchExeFromCondExecutableTup (name, Cabal.CondNode Cabal.Benchmark{..} _ _) = + case benchmarkInterface of + Cabal.BenchmarkExeV10 _ mainIs -> Just + Executable { executableName = name + , executableMain = mainIs + , executableOtherModules = map (show . Cabal.disp) + (Cabal.otherModules benchmarkBuildInfo) + } + _ -> Nothing + +-- | Returns Nothing if a list is empty and Just the list otherwise +-- +-- >>> nullNothing [] +-- Nothing +-- >>> nullNothing [1, 2, 3] +-- Just [1, 2, 3] +nullNothing :: [a] -> Maybe [a] +nullNothing s = const s <$> listToMaybe s diff --git a/src/Hpack/Convert/Run.hs b/src/Hpack/Convert/Run.hs new file mode 100644 --- /dev/null +++ b/src/Hpack/Convert/Run.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE TupleSections #-} +module Hpack.Convert.Run + ( runConvert + ) + where + +import Control.Applicative +import Control.Monad +import Data.List +import Data.Maybe +import System.Directory +import System.Environment +import System.Exit +import System.FilePath +import System.FilePath.Glob + +import Hpack.Config +import Hpack.Convert + +runConvert :: IO () +runConvert = do + as <- getArgs + (dir, cabalFileFP) <- case as of + (dir:_) -> do + isFile <- doesFileExist dir + if takeExtension dir == ".cabal" && isFile + then return (takeDirectory dir, dir) + else (dir,) <$> findCabalFileFP dir + _ -> do + cwd <- getCurrentDirectory + cabalFileFP <- findCabalFileFP cwd + return (cwd, cabalFileFP) + pkg <- runConvert' dir cabalFileFP + writePackage (dir "package.yaml") pkg + putStrLn $ "generated package.yaml based on " ++ cabalFileFP + +findCabalFileFP :: FilePath -> IO FilePath +findCabalFileFP dir = do + mcabalFileFP <- listToMaybe <$> globDir1 (compile "*.cabal") dir + case mcabalFileFP of + Nothing -> die "No cabal file in the current directory" + Just cabalFileFP -> return cabalFileFP + +runConvert' :: FilePath -> FilePath -> IO Package +runConvert' dir cabalFileFP = do + mpackageYaml <- find (== "package.yaml") <$> getDirectoryContents dir + + when (isJust mpackageYaml) $ + die $ (dir "package.yaml") ++ " already exists" + + old <- readFile cabalFileFP + case fromPackageDescriptionString old of + Left err -> die (show err) + Right pkg -> return pkg diff --git a/src/Hpack/FormattingHints.hs b/src/Hpack/FormattingHints.hs new file mode 100644 --- /dev/null +++ b/src/Hpack/FormattingHints.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} +module Hpack.FormattingHints ( + FormattingHints (..) +, sniffFormattingHints +#ifdef TEST +, extractFieldOrder +, extractSectionsFieldOrder +, breakLines +, unindent +, sniffAlignment +, splitField +, sniffIndentation +, sniffCommaStyle +#endif +) where + +import Prelude () +import Prelude.Compat + +import Data.Char +import Data.Maybe +import Data.List.Compat +import Control.Applicative + +import Hpack.Render +-- import Hpack.Util + +data FormattingHints = FormattingHints { + formattingHintsFieldOrder :: [String] +, formattingHintsSectionsFieldOrder :: [(String, [String])] +, formattingHintsAlignment :: Maybe Alignment +, formattingHintsRenderSettings :: RenderSettings +} deriving (Eq, Show) + +sniffFormattingHints :: String -> FormattingHints +sniffFormattingHints (breakLines -> input) = FormattingHints { + formattingHintsFieldOrder = extractFieldOrder input +, formattingHintsSectionsFieldOrder = extractSectionsFieldOrder input +, formattingHintsAlignment = sniffAlignment input +, formattingHintsRenderSettings = sniffRenderSettings input +} + +breakLines :: String -> [String] +breakLines = filter (not . null) . map (reverse . dropWhile isSpace . reverse) . lines + +extractFieldOrder :: [String] -> [String] +extractFieldOrder = map fst . catMaybes . map splitField + +extractSectionsFieldOrder :: [String] -> [(String, [String])] +extractSectionsFieldOrder = map (fmap extractFieldOrder) . splitSections + where + splitSections input = case break startsWithSpace input of + ([], []) -> [] + (xs, ys) -> case span startsWithSpace ys of + (fields, zs) -> case reverse xs of + name : _ -> (name, unindent fields) : splitSections zs + _ -> splitSections zs + + startsWithSpace :: String -> Bool + startsWithSpace xs = case xs of + y : _ -> isSpace y + _ -> False + +unindent :: [String] -> [String] +unindent input = map (drop indentation) input + where + indentation = minimum $ map (length . takeWhile isSpace) input + +sniffAlignment :: [String] -> Maybe Alignment +sniffAlignment input = case nub . catMaybes . map indentation . catMaybes . map splitField $ input of + [n] -> Just (Alignment n) + _ -> Nothing + where + + indentation :: (String, String) -> Maybe Int + indentation (name, value) = case span isSpace value of + (_, "") -> Nothing + (xs, _) -> (Just . succ . length $ name ++ xs) + +splitField :: String -> Maybe (String, String) +splitField field = case span isNameChar field of + (xs, ':':ys) -> Just (xs, ys) + _ -> Nothing + where + isNameChar = (`elem` nameChars) + nameChars = ['a'..'z'] ++ ['A'..'Z'] ++ "-" + +sniffIndentation :: [String] -> Maybe Int +sniffIndentation input = sniffFrom "library" <|> sniffFrom "executable" + where + sniffFrom :: String -> Maybe Int + sniffFrom section = case findSection . removeEmptyLines $ input of + _ : x : _ -> Just . length $ takeWhile isSpace x + _ -> Nothing + where + findSection = dropWhile (not . isPrefixOf section) + + removeEmptyLines :: [String] -> [String] + removeEmptyLines = filter $ any (not . isSpace) + +sniffCommaStyle :: [String] -> Maybe CommaStyle +sniffCommaStyle input + | any startsWithComma input = Just LeadingCommas + | any (startsWithComma . reverse) input = Just TrailingCommas + | otherwise = Nothing + where + startsWithComma = isPrefixOf "," . dropWhile isSpace + +sniffRenderSettings :: [String] -> RenderSettings +sniffRenderSettings input = RenderSettings indentation fieldAlignment commaStyle + where + indentation = fromMaybe (renderSettingsIndentation defaultRenderSettings) (sniffIndentation input) + fieldAlignment = renderSettingsFieldAlignment defaultRenderSettings + commaStyle = fromMaybe (renderSettingsCommaStyle defaultRenderSettings) (sniffCommaStyle input) diff --git a/src/Hpack/GenericsUtil.hs b/src/Hpack/GenericsUtil.hs new file mode 100644 --- /dev/null +++ b/src/Hpack/GenericsUtil.hs @@ -0,0 +1,46 @@ +{-# 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 _ = [] diff --git a/src/Hpack/Haskell.hs b/src/Hpack/Haskell.hs new file mode 100644 --- /dev/null +++ b/src/Hpack/Haskell.hs @@ -0,0 +1,55 @@ +module 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 == '\'' diff --git a/src/Hpack/Render.hs b/src/Hpack/Render.hs new file mode 100644 --- /dev/null +++ b/src/Hpack/Render.hs @@ -0,0 +1,135 @@ +{-# 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 diff --git a/src/Hpack/Run.hs b/src/Hpack/Run.hs new file mode 100644 --- /dev/null +++ b/src/Hpack/Run.hs @@ -0,0 +1,275 @@ +{-# 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 + , renderCCOptions sectionCCOptions + , 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 + +renderCCOptions :: [CCOption] -> Element +renderCCOptions = Field "cc-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 diff --git a/src/Hpack/Util.hs b/src/Hpack/Util.hs new file mode 100644 --- /dev/null +++ b/src/Hpack/Util.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module Hpack.Util ( + List(..) +, GhcOption +, GhcProfOption +, CppOption +, CCOption +, 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 CCOption = 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 + } diff --git a/src/Hpack/Yaml.hs b/src/Hpack/Yaml.hs new file mode 100644 --- /dev/null +++ b/src/Hpack/Yaml.hs @@ -0,0 +1,16 @@ +{-# 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 diff --git a/test/Helper.hs b/test/Helper.hs new file mode 100644 --- /dev/null +++ b/test/Helper.hs @@ -0,0 +1,26 @@ +module 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 diff --git a/test/Hpack/ConfigSpec.hs b/test/Hpack/ConfigSpec.hs new file mode 100644 --- /dev/null +++ b/test/Hpack/ConfigSpec.hs @@ -0,0 +1,1052 @@ +{-# 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 cc-options" $ do + withPackageConfig_ [i| + cc-options: -Wall + library: + cc-options: -fLIB + + executables: + foo: + main: Main.hs + cc-options: -O2 + + + tests: + spec: + main: Spec.hs + cc-options: -O0 + |] + (`shouldBe` package { + packageLibrary = Just (section library) {sectionCCOptions = ["-Wall", "-fLIB"]} + , packageExecutables = [(section $ executable "foo" "Main.hs") {sectionCCOptions = ["-Wall", "-O2"]}] + , packageTests = [(section $ executable "spec" "Spec.hs") {sectionCCOptions = ["-Wall", "-O0"]}] + } + ) + + 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}|] + + context "toJSON :: Conditinal -> Value" $ do + it "serializes conditionals properly" $ do + let s = emptySection { sectionBuildable = Just False } + toJSON (Conditional "os(darwin)" s Nothing) + `shouldBe` object [ "condition" .= String "os(darwin)" + , "buildable" .= Bool False + ] + + it "serializes conditionals with an else branch properly" $ do + let s = emptySection { sectionBuildable = Just False } + toJSON (Conditional "os(darwin)" s (Just s)) + `shouldBe` object [ "condition" .= String "os(darwin)" + , "then" .= object [ "buildable" .= Bool False + ] + , "else" .= object [ "buildable" .= Bool False + ] + ] + + + context "toJSON :: Section a -> Value" $ + it "serializes conditionals properly" $ do + let s = emptySection { sectionConditionals = [ Conditional "os(darwin)" emptySection { sectionBuildable = Just False } Nothing] + } + toJSON s + `shouldBe` object [ "when" .= array [ object [ "condition" .= String "os(darwin)" + , "buildable" .= Bool False + ] + ] + ] + +emptySection :: Section () +emptySection = Section { sectionData = () + , sectionSourceDirs = [] + , sectionDependencies = [] + , sectionDefaultExtensions = [] + , sectionOtherExtensions = [] + , sectionGhcOptions = [] + , sectionGhcProfOptions = [] + , sectionCppOptions = [] + , sectionCCOptions = [] + , sectionCSources = [] + , sectionExtraLibDirs = [] + , sectionExtraLibraries = [] + , sectionIncludeDirs = [] + , sectionInstallIncludes = [] + , sectionLdOptions = [] + , sectionBuildable = Nothing + , sectionConditionals = [] + , sectionBuildTools = [] + } diff --git a/test/Hpack/ConvertSpec.hs b/test/Hpack/ConvertSpec.hs new file mode 100644 --- /dev/null +++ b/test/Hpack/ConvertSpec.hs @@ -0,0 +1,449 @@ +{-# LANGUAGE OverloadedStrings #-} +module Hpack.ConvertSpec (spec) where + +import Prelude () +import Prelude.Compat + +import Control.Monad +import qualified Data.ByteString as ByteString hiding (pack, unpack) +import qualified Data.ByteString.Char8 as ByteString (unpack) +import System.Directory +import System.FilePath +import Test.Hspec + +import Hpack.Config +import Hpack.Convert + +spec :: Spec +spec = + describe "fromPackageDescriptionString" $ do + describe "generated from ./test/data/*.{cabal,yaml}" $ do + cabalFiles <- runIO $ do + fs <- getDirectoryContents "./test/data" + return $ map ("./test/data" ) + (filter ((== ".cabal") . takeExtension) fs) + + forM_ cabalFiles $ \cabalFp -> do + let expectationFp = cabalFp ++ ".yaml" + readPackageFromCabal fp = do + cc <- readFile fp + let Right pkg = fromPackageDescriptionString cc + return pkg + expectationExists <- runIO $ doesFileExist expectationFp + + if not expectationExists + then do + it ("parses " ++ cabalFp) + (pendingWith ("no expected output file at " ++ expectationFp)) + it ("produces the same output from " ++ cabalFp ++ " as from " ++ expectationFp) + (pendingWith ("no expected output file at " ++ expectationFp)) + else do + it ("parses " ++ cabalFp) $ do + pkg <- readPackageFromCabal cabalFp + ecc <- ByteString.readFile expectationFp + -- ByteString.writeFile (cabalFp ++ ".yaml.out") bpkg + encodePackage pkg `shouldBe` ecc + + it ("produces the same output from " ++ cabalFp ++ " as from " ++ expectationFp) $ do + pkg <- readPackageFromCabal cabalFp + Right (_, pkg') <- readPackageConfig expectationFp + -- ByteString.writeFile (cabalFp ++ ".yaml.out.2") (encodePackage pkg') + + -- This is here to make sure encoding is consistent with the cabal + -- file encoding + ByteString.unpack (encodePackage pkg') `shouldBe` ByteString.unpack (encodePackage pkg) + + describe "simple generated cabal file" $ do + it "cabal init -m" $ do + pkgDescription <- readFile "./test/data/cabal-init-minimal.cabal" + let pkg = fromPackageDescriptionString pkgDescription + pkg `shouldBe` Right Package { packageName = "cabal-init-minimal" + , packageVersion = "0.1.0.0" + , packageSynopsis = Nothing + , packageDescription = Nothing + , packageHomepage = Nothing + , packageBugReports = Nothing + , packageCategory = Nothing + , packageStability = Nothing + , packageAuthor = [ "Pedro Tacla Yamada" ] + , packageMaintainer = [ "tacla.yamada@gmail.com" ] + , packageCopyright = [] + , packageLicense = Just "PublicDomain" + , packageLicenseFile = Nothing + , packageTestedWith = Nothing + , packageFlags = [] + , packageExtraSourceFiles = ["ChangeLog.md"] + , packageDataFiles = [] + , packageSourceRepository = Nothing + , packageLibrary = Just Section { sectionData = Library { libraryExposed = Just True + , libraryExposedModules = [] + , libraryOtherModules = [] + , libraryReexportedModules = [] + } + , sectionSourceDirs = ["src"] + , sectionDependencies = [ Dependency "base >=4.8 && <4.9" Nothing ] + , sectionDefaultExtensions = [] + , sectionOtherExtensions = [] + , sectionGhcOptions = [] + , sectionGhcProfOptions = [] + , sectionCppOptions = [] + , sectionCCOptions = [] + , sectionCSources = [] + , sectionExtraLibDirs = [] + , sectionExtraLibraries = [] + , sectionIncludeDirs = [] + , sectionInstallIncludes = [] + , sectionLdOptions = [] + , sectionBuildable = Just True + , sectionConditionals = [] + , sectionBuildTools = [] + } + , packageExecutables = [] + , packageTests = [] + , packageBenchmarks = [] + } + + it "cabal init -m with executables" $ do + pkgDescription <- readFile "./test/data/cabal-init-with-executables.cabal" + let pkg = fromPackageDescriptionString pkgDescription + pkg `shouldBe` Right Package { packageName = "cabal-init-minimal" + , packageVersion = "0.1.0.0" + , packageSynopsis = Nothing + , packageDescription = Nothing + , packageHomepage = Nothing + , packageBugReports = Nothing + , packageCategory = Nothing + , packageStability = Nothing + , packageAuthor = [ "Pedro Tacla Yamada" ] + , packageMaintainer = [ "tacla.yamada@gmail.com" ] + , packageCopyright = [] + , packageLicense = Just "PublicDomain" + , packageLicenseFile = Nothing + , packageTestedWith = Nothing + , packageFlags = [] + , packageExtraSourceFiles = ["ChangeLog.md"] + , packageDataFiles = [] + , packageSourceRepository = Nothing + , packageLibrary = Nothing + , packageExecutables = [ + Section { sectionData = Executable { executableName = "hello-world" + , executableMain = "HelloWorld.hs" + , executableOtherModules = [] + } + , sectionSourceDirs = [ "src" ] + , sectionDependencies = [ Dependency "base >=4.8 && <4.9" Nothing ] + , sectionDefaultExtensions = [] + , sectionOtherExtensions = [] + , sectionGhcOptions = [] + , sectionGhcProfOptions = [] + , sectionCppOptions = [] + , sectionCCOptions = [] + , sectionCSources = [] + , sectionExtraLibDirs = [] + , sectionExtraLibraries = [] + , sectionIncludeDirs = [] + , sectionInstallIncludes = [] + , sectionLdOptions = [] + , sectionBuildable = Just True + , sectionConditionals = [] + , sectionBuildTools = [] + } + ] + , packageTests = [] + , packageBenchmarks = [] + } + + it "cabal init -m with test-suites" $ do + pkgDescription <- readFile "./test/data/cabal-init-with-tests.cabal" + let pkg = fromPackageDescriptionString pkgDescription + pkg `shouldBe` Right Package { packageName = "cabal-init-minimal" + , packageVersion = "0.1.0.0" + , packageSynopsis = Nothing + , packageDescription = Nothing + , packageHomepage = Nothing + , packageBugReports = Nothing + , packageCategory = Nothing + , packageStability = Nothing + , packageAuthor = [ "Pedro Tacla Yamada" ] + , packageMaintainer = [ "tacla.yamada@gmail.com" ] + , packageCopyright = [] + , packageLicense = Just "PublicDomain" + , packageLicenseFile = Nothing + , packageTestedWith = Nothing + , packageFlags = [] + , packageExtraSourceFiles = ["ChangeLog.md"] + , packageDataFiles = [] + , packageSourceRepository = Nothing + , packageLibrary = Nothing + , packageExecutables = [ + Section { sectionData = Executable { executableName = "hello-world" + , executableMain = "HelloWorld.hs" + , executableOtherModules = [] + } + , sectionSourceDirs = [ "src" ] + , sectionDependencies = [ Dependency "base >=4.8 && <4.9" Nothing ] + , sectionDefaultExtensions = [] + , sectionOtherExtensions = [] + , sectionGhcOptions = [] + , sectionGhcProfOptions = [] + , sectionCppOptions = [] + , sectionCCOptions = [] + , sectionCSources = [] + , sectionExtraLibDirs = [] + , sectionExtraLibraries = [] + , sectionIncludeDirs = [] + , sectionInstallIncludes = [] + , sectionLdOptions = [] + , sectionBuildable = Just True + , sectionConditionals = [] + , sectionBuildTools = [] + } + ] + , packageTests = [ + Section { sectionData = Executable { executableName = "hello-world-spec" + , executableMain = "Spec.hs" + , executableOtherModules = [] + } + , sectionSourceDirs = [ "src", "test" ] + , sectionDependencies = [ Dependency "base >=4.8 && <4.9" Nothing ] + , sectionDefaultExtensions = [] + , sectionOtherExtensions = [] + , sectionGhcOptions = [] + , sectionGhcProfOptions = [] + , sectionCppOptions = [] + , sectionCCOptions = [] + , sectionCSources = [] + , sectionExtraLibDirs = [] + , sectionExtraLibraries = [] + , sectionIncludeDirs = [] + , sectionInstallIncludes = [] + , sectionLdOptions = [] + , sectionBuildable = Just True + , sectionConditionals = [] + , sectionBuildTools = [] + } + ] + , packageBenchmarks = [] + } + + it "cabal init -m with benchmarks" $ do + pkgDescription <- readFile "./test/data/cabal-init-with-benchmarks.cabal" + let pkg = fromPackageDescriptionString pkgDescription + pkg `shouldBe` Right Package { packageName = "cabal-init-minimal" + , packageVersion = "0.1.0.0" + , packageSynopsis = Nothing + , packageDescription = Nothing + , packageHomepage = Nothing + , packageBugReports = Nothing + , packageCategory = Nothing + , packageStability = Nothing + , packageAuthor = [ "Pedro Tacla Yamada" ] + , packageMaintainer = [ "tacla.yamada@gmail.com" ] + , packageCopyright = [] + , packageLicense = Just "PublicDomain" + , packageLicenseFile = Nothing + , packageTestedWith = Nothing + , packageFlags = [] + , packageExtraSourceFiles = ["ChangeLog.md"] + , packageDataFiles = [] + , packageSourceRepository = Nothing + , packageLibrary = Nothing + , packageExecutables = [ + Section { sectionData = Executable { executableName = "hello-world" + , executableMain = "HelloWorld.hs" + , executableOtherModules = [] + } + , sectionSourceDirs = [ "src" ] + , sectionDependencies = [ Dependency "base >=4.8 && <4.9" Nothing ] + , sectionDefaultExtensions = [] + , sectionOtherExtensions = [] + , sectionGhcOptions = [] + , sectionGhcProfOptions = [] + , sectionCppOptions = [] + , sectionCCOptions = [] + , sectionCSources = [] + , sectionExtraLibDirs = [] + , sectionExtraLibraries = [] + , sectionIncludeDirs = [] + , sectionInstallIncludes = [] + , sectionLdOptions = [] + , sectionBuildable = Just True + , sectionConditionals = [] + , sectionBuildTools = [] + } + ] + , packageTests = [ + Section { sectionData = Executable { executableName = "hello-world-spec" + , executableMain = "Spec.hs" + , executableOtherModules = [] + } + , sectionSourceDirs = [ "src", "test" ] + , sectionDependencies = [ Dependency "base >=4.8 && <4.9" Nothing ] + , sectionDefaultExtensions = [] + , sectionOtherExtensions = [] + , sectionGhcOptions = [] + , sectionGhcProfOptions = [] + , sectionCppOptions = [] + , sectionCCOptions = [] + , sectionCSources = [] + , sectionExtraLibDirs = [] + , sectionExtraLibraries = [] + , sectionIncludeDirs = [] + , sectionInstallIncludes = [] + , sectionLdOptions = [] + , sectionBuildable = Just True + , sectionConditionals = [] + , sectionBuildTools = [] + } + ] + , packageBenchmarks = [ + Section { sectionData = Executable { executableName = "hello-world-benchmark" + , executableMain = "Bench.hs" + , executableOtherModules = [] + } + , sectionSourceDirs = [ "src", "benchmarks" ] + , sectionDependencies = [ Dependency "base >=4.8 && <4.9" Nothing ] + , sectionDefaultExtensions = [] + , sectionOtherExtensions = [] + , sectionGhcOptions = [] + , sectionGhcProfOptions = [] + , sectionCppOptions = [] + , sectionCCOptions = [] + , sectionCSources = [] + , sectionExtraLibDirs = [] + , sectionExtraLibraries = [] + , sectionIncludeDirs = [] + , sectionInstallIncludes = [] + , sectionLdOptions = [] + , sectionBuildable = Just True + , sectionConditionals = [] + , sectionBuildTools = [] + } + ] + } + + it "cabal init -m with conditionals" $ do + pkgDescription <- readFile "./test/data/cabal-init-with-conditionals.cabal" + let pkg = fromPackageDescriptionString pkgDescription + pkg `shouldBe` Right Package { packageName = "cabal-init-minimal" + , packageVersion = "0.1.0.0" + , packageSynopsis = Nothing + , packageDescription = Nothing + , packageHomepage = Nothing + , packageBugReports = Nothing + , packageCategory = Nothing + , packageStability = Nothing + , packageAuthor = [ "Pedro Tacla Yamada" ] + , packageMaintainer = [ "tacla.yamada@gmail.com" ] + , packageCopyright = [] + , packageLicense = Just "PublicDomain" + , packageLicenseFile = Nothing + , packageTestedWith = Nothing + , packageFlags = [] + , packageExtraSourceFiles = ["ChangeLog.md"] + , packageDataFiles = [] + , packageSourceRepository = Nothing + , packageLibrary = Nothing + , packageExecutables = [ + Section { sectionData = Executable { executableName = "hello-world" + , executableMain = "HelloWorld.hs" + , executableOtherModules = [] + } + , sectionSourceDirs = [ "src" ] + , sectionDependencies = [ Dependency "base >=4.8 && <4.9" Nothing ] + , sectionDefaultExtensions = [] + , sectionOtherExtensions = [] + , sectionGhcOptions = [] + , sectionGhcProfOptions = [] + , sectionCppOptions = [] + , sectionCCOptions = [] + , sectionCSources = [] + , sectionExtraLibDirs = [] + , sectionExtraLibraries = [] + , sectionIncludeDirs = [] + , sectionInstallIncludes = [] + , sectionLdOptions = [] + , sectionBuildable = Just True + , sectionConditionals = [ Conditional "os(osx)" (emptySection {sectionBuildable = Just False}) Nothing + ] + , sectionBuildTools = [] + } + ] + , packageTests = [] + , packageBenchmarks = [] + } + + it "cabal init -m with conditionals and an else branch" $ do + pkgDescription <- readFile "./test/data/cabal-init-with-conditionals-and-else.cabal" + let pkg = fromPackageDescriptionString pkgDescription + pkg `shouldBe` Right Package { packageName = "cabal-init-minimal" + , packageVersion = "0.1.0.0" + , packageSynopsis = Nothing + , packageDescription = Nothing + , packageHomepage = Nothing + , packageBugReports = Nothing + , packageCategory = Nothing + , packageStability = Nothing + , packageAuthor = [ "Pedro Tacla Yamada" ] + , packageMaintainer = [ "tacla.yamada@gmail.com" ] + , packageCopyright = [] + , packageLicense = Just "PublicDomain" + , packageLicenseFile = Nothing + , packageTestedWith = Nothing + , packageFlags = [] + , packageExtraSourceFiles = ["ChangeLog.md"] + , packageDataFiles = [] + , packageSourceRepository = Nothing + , packageLibrary = Nothing + , packageExecutables = [ + Section { sectionData = Executable { executableName = "hello-world" + , executableMain = "HelloWorld.hs" + , executableOtherModules = [] + } + , sectionSourceDirs = [ "src" ] + , sectionDependencies = [ Dependency "base >=4.8 && <4.9" Nothing ] + , sectionDefaultExtensions = [] + , sectionOtherExtensions = [] + , sectionGhcOptions = [] + , sectionGhcProfOptions = [] + , sectionCppOptions = [] + , sectionCCOptions = [] + , sectionCSources = [] + , sectionExtraLibDirs = [] + , sectionExtraLibraries = [] + , sectionIncludeDirs = [] + , sectionInstallIncludes = [] + , sectionLdOptions = [] + , sectionBuildable = Just True + , sectionConditionals = [ + Conditional "os(osx)" + (emptySection {sectionSourceDirs = ["osx"]}) + (Just emptySection {sectionSourceDirs = ["notosx"]}) + ] + , sectionBuildTools = [] + } + ] + , packageTests = [] + , packageBenchmarks = [] + } + +emptySection :: Section () +emptySection = Section { sectionData = () + , sectionSourceDirs = [] + , sectionDependencies = [] + , sectionDefaultExtensions = [] + , sectionOtherExtensions = [] + , sectionGhcOptions = [] + , sectionGhcProfOptions = [] + , sectionCppOptions = [] + , sectionCCOptions = [] + , sectionCSources = [] + , sectionExtraLibDirs = [] + , sectionExtraLibraries = [] + , sectionIncludeDirs = [] + , sectionInstallIncludes = [] + , sectionLdOptions = [] + , sectionBuildable = Just True + , sectionConditionals = [] + , sectionBuildTools = [] + } diff --git a/test/Hpack/FormattingHintsSpec.hs b/test/Hpack/FormattingHintsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Hpack/FormattingHintsSpec.hs @@ -0,0 +1,166 @@ +module Hpack.FormattingHintsSpec (spec) where + +import Test.Hspec + +import Hpack.FormattingHints +import Hpack.Render + +spec :: Spec +spec = do + describe "extractFieldOrder" $ do + it "extracts field order hints" $ do + let input = [ + "name: cabalize" + , "version: 0.0.0" + , "license:" + , "license-file: " + , "build-type: Simple" + , "cabal-version: >= 1.10" + ] + extractFieldOrder input `shouldBe` [ + "name" + , "version" + , "license" + , "license-file" + , "build-type" + , "cabal-version" + ] + + describe "extractSectionsFieldOrder" $ do + it "splits input into sections" $ do + let input = [ + "name: cabalize" + , "version: 0.0.0" + , "" + , "library" + , " foo: 23" + , " bar: 42" + , "" + , "executable foo" + , " bar: 23" + , " baz: 42" + ] + extractSectionsFieldOrder input `shouldBe` [("library", ["foo", "bar"]), ("executable foo", ["bar", "baz"])] + + describe "breakLines" $ do + it "breaks input into lines" $ do + let input = unlines [ + "foo" + , "" + , " " + , " bar " + , " baz" + ] + breakLines input `shouldBe` [ + "foo" + , " bar" + , " baz" + ] + + describe "unindent" $ do + it "unindents" $ do + let input = [ + " foo" + , " bar" + , " baz" + ] + unindent input `shouldBe` [ + " foo" + , "bar" + , " baz" + ] + + describe "sniffAlignment" $ do + it "sniffs field alignment from given cabal file" $ do + let input = [ + "name: cabalize" + , "version: 0.0.0" + , "license: MIT" + , "license-file: LICENSE" + , "build-type: Simple" + , "cabal-version: >= 1.10" + ] + sniffAlignment input `shouldBe` Just 16 + + it "ignores fields without a value on the same line" $ do + let input = [ + "name: cabalize" + , "version: 0.0.0" + , "description: " + , " foo" + , " bar" + ] + sniffAlignment input `shouldBe` Just 16 + + describe "splitField" $ do + it "splits fields" $ do + splitField "foo: bar" `shouldBe` Just ("foo", " bar") + + it "accepts fields names with dashes" $ do + splitField "foo-bar: baz" `shouldBe` Just ("foo-bar", " baz") + + it "rejects fields names with spaces" $ do + splitField "foo bar: baz" `shouldBe` Nothing + + it "rejects invalid fields" $ do + splitField "foo bar" `shouldBe` Nothing + + describe "sniffIndentation" $ do + it "sniff alignment from executable section" $ do + let input = [ + "name: foo" + , "version: 0.0.0" + , "" + , "executable foo" + , " build-depends: bar" + ] + sniffIndentation input `shouldBe` Just 4 + + it "sniff alignment from library section" $ do + let input = [ + "name: foo" + , "version: 0.0.0" + , "" + , "library" + , " build-depends: bar" + ] + sniffIndentation input `shouldBe` Just 4 + + it "ignores empty lines" $ do + let input = [ + "executable foo" + , "" + , " build-depends: bar" + ] + sniffIndentation input `shouldBe` Just 4 + + it "ignores whitespace lines" $ do + let input = [ + "executable foo" + , " " + , " build-depends: bar" + ] + sniffIndentation input `shouldBe` Just 4 + + describe "sniffCommaStyle" $ do + it "detects leading commas" $ do + let input = [ + "executable foo" + , " build-depends:" + , " bar" + , " , baz" + ] + sniffCommaStyle input `shouldBe` Just LeadingCommas + + it "detects trailing commas" $ do + let input = [ + "executable foo" + , " build-depends:" + , " bar, " + , " baz" + ] + sniffCommaStyle input `shouldBe` Just TrailingCommas + + context "when detection fails" $ do + it "returns Nothing" $ do + sniffCommaStyle [] `shouldBe` Nothing diff --git a/test/Hpack/GenericsUtilSpec.hs b/test/Hpack/GenericsUtilSpec.hs new file mode 100644 --- /dev/null +++ b/test/Hpack/GenericsUtilSpec.hs @@ -0,0 +1,24 @@ +{-# 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" diff --git a/test/Hpack/HaskellSpec.hs b/test/Hpack/HaskellSpec.hs new file mode 100644 --- /dev/null +++ b/test/Hpack/HaskellSpec.hs @@ -0,0 +1,31 @@ +module 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 diff --git a/test/Hpack/RenderSpec.hs b/test/Hpack/RenderSpec.hs new file mode 100644 --- /dev/null +++ b/test/Hpack/RenderSpec.hs @@ -0,0 +1,158 @@ +{-# 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)] diff --git a/test/Hpack/RunSpec.hs b/test/Hpack/RunSpec.hs new file mode 100644 --- /dev/null +++ b/test/Hpack/RunSpec.hs @@ -0,0 +1,325 @@ +{-# 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" + ] diff --git a/test/Hpack/UtilSpec.hs b/test/Hpack/UtilSpec.hs new file mode 100644 --- /dev/null +++ b/test/Hpack/UtilSpec.hs @@ -0,0 +1,151 @@ +{-# 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"], []) diff --git a/test/HpackSpec.hs b/test/HpackSpec.hs new file mode 100644 --- /dev/null +++ b/test/HpackSpec.hs @@ -0,0 +1,73 @@ +module HpackSpec (spec) where + +import Prelude () +import Prelude.Compat + +import Control.Monad.Compat +import Control.DeepSeq +import Data.Version (Version (..), showVersion) + +import Test.Hspec +import Test.Mockery.Directory +import Test.QuickCheck + +import Hpack +import Hpack.Config +import Hpack.Convert + +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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}