diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for jenga -## 0.1.0.0 -- YYYY-mm-dd +## 0.1.1.0 -- 2017-05-14 + +* Make it build with ghc 8.2.0rc2 and later. + +## 0.1.0.0 -- 2017-03-05 * First version. Released on an unsuspecting world. diff --git a/Jenga/Cabal.hs b/Jenga/Cabal.hs --- a/Jenga/Cabal.hs +++ b/Jenga/Cabal.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module Jenga.Cabal ( dependencyName , readPackageDependencies @@ -12,18 +13,22 @@ import Data.Text (Text) import qualified Data.Text as T -import Distribution.Package (Dependency (..), PackageIdentifier (..), PackageName (..)) +import Distribution.Package (Dependency (..), PackageIdentifier (..), unPackageName) import Distribution.PackageDescription ( Benchmark, CondTree (..), ConfVar, Executable, GenericPackageDescription (..) , PackageDescription (..), Library, TestSuite ) +#if MIN_VERSION_Cabal (2,0,0) +import Distribution.PackageDescription.Parse (readGenericPackageDescription) +#else import Distribution.PackageDescription.Parse (readPackageDescription) +import Distribution.Verbosity (Verbosity) +#endif import Distribution.Verbosity (normal) - readPackageDependencies :: FilePath -> IO [Dependency] readPackageDependencies fpath = do - genpkg <- readPackageDescription normal fpath + genpkg <- readGenericPackageDescription normal fpath pure $ sortNubByName $ filterPackageName (package $ packageDescription genpkg) @@ -46,18 +51,24 @@ packageName (Dependency pn _) = pn dependencyName :: Dependency -> Text -dependencyName (Dependency (PackageName name) _) = T.pack name +dependencyName (Dependency name _) = T.pack $ unPackageName name extractLibraryDeps :: Maybe (CondTree ConfVar [Dependency] Library) -> [Dependency] extractLibraryDeps Nothing = [] extractLibraryDeps (Just x) = condTreeConstraints x -extractExecutableDeps :: [(String, CondTree ConfVar [Dependency] Executable)] -> [Dependency] +extractExecutableDeps :: [(a, CondTree ConfVar [Dependency] Executable)] -> [Dependency] extractExecutableDeps = concatMap (condTreeConstraints . snd) -extractTestSuiteDeps :: [(String, CondTree ConfVar [Dependency] TestSuite)] -> [Dependency] +extractTestSuiteDeps :: [(a, CondTree ConfVar [Dependency] TestSuite)] -> [Dependency] extractTestSuiteDeps = concatMap (condTreeConstraints . snd) -extractBenchmarkDeps :: [(String, CondTree ConfVar [Dependency] Benchmark)] -> [Dependency] +extractBenchmarkDeps :: [(a, CondTree ConfVar [Dependency] Benchmark)] -> [Dependency] extractBenchmarkDeps = concatMap (condTreeConstraints . snd) + +#if MIN_VERSION_Cabal (2,0,0) +#else +readGenericPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription +readGenericPackageDescription = readPackageDescription +#endif diff --git a/Jenga/HTTP.hs b/Jenga/HTTP.hs --- a/Jenga/HTTP.hs +++ b/Jenga/HTTP.hs @@ -1,20 +1,17 @@ {-# LANGUAGE OverloadedStrings #-} module Jenga.HTTP where -import Control.Monad (when, void) - -import Data.Aeson (eitherDecode') - -import Network.HTTP.Client.Conduit -import Network.HTTP.Types.Header (hAccept) -import Network.HTTP.Types.Status (status200) +import Control.Monad (when, void) -import Jenga.PackageList +import Data.Aeson (eitherDecode') +import qualified Data.Text as T +import Jenga.PackageList +import Jenga.Stack -newtype StackResolver - = StackResolver String - deriving (Eq, Show) +import Network.HTTP.Client.Conduit +import Network.HTTP.Types.Header (hAccept) +import Network.HTTP.Types.Status (status200) @@ -22,14 +19,14 @@ stackageUrl = "https://www.stackage.org/" -- Should use an ErrorT here. -getStackageResolverPkgList :: StackResolver -> IO (Either String PackageList) -getStackageResolverPkgList (StackResolver sr) = do +getStackageResolverPkgList :: StackConfig -> IO (Either String PackageList) +getStackageResolverPkgList scfg = do -- TODO: swap out for something that doesn't `fail`. - request <- parseRequest $ stackageUrl ++ sr + request <- parseRequest $ stackageUrl ++ T.unpack (stackResolver scfg) withManager $ do response <- httpLbs $ request { requestHeaders = (hAccept, "application/json") : requestHeaders request } when (responseStatus response /= status200) $ void . error $ "getStackageResolverPkgList: status " ++ show (responseStatus response) - pure $ eitherDecode' (responseBody response) + pure $ mergeExtraDeps scfg <$> eitherDecode' (responseBody response) diff --git a/Jenga/PackageList.hs b/Jenga/PackageList.hs --- a/Jenga/PackageList.hs +++ b/Jenga/PackageList.hs @@ -4,16 +4,19 @@ ( PackageInfo (..) , PackageList (..) , lookupPackages + , mergeExtraDeps ) where -import Data.Aeson +import Data.Aeson (FromJSON (..), Value (..), (.:)) import Data.Aeson.Types (typeMismatch) +import qualified Data.List as DL import Data.Map.Strict (Map) import qualified Data.Map.Strict as DM import Data.Text (Text) +import Jenga.Stack data PackageList = PackageList { ghcVersion :: Text @@ -39,9 +42,9 @@ -- Temporary data type. Not exported. data Snapshot = Snapshot - { ghc :: Text - , created :: Text - , name :: Text + { snapshotGhc :: Text + , snapshotCreated :: Text + , snapshotName :: Text } @@ -65,7 +68,7 @@ parseJSON (Object v) = do s <- v .: "snapshot" pkgs <- v .: "packages" - pure $ PackageList (ghc s) (created s) (name s) $ mkPackageMap pkgs + pure $ PackageList (snapshotGhc s) (snapshotCreated s) (snapshotName s) $ mkPackageMap pkgs parseJSON invalid = typeMismatch "PackageList" invalid @@ -86,3 +89,13 @@ case DM.lookup k pmap of Nothing -> Left k Just x -> Right (k, x) + + +mergeExtraDeps :: StackConfig -> PackageList -> PackageList +mergeExtraDeps scfg plist = + case stackExtraDeps scfg of + [] -> plist + xs -> plist { packageMap = DL.foldl' mergef (packageMap plist) xs } + where + mergef m (StackExtraDep name ver) = + DM.insertWith (\ a _ -> a) name (PackageInfo ver "extra-dep" False) m diff --git a/Jenga/Render.hs b/Jenga/Render.hs new file mode 100644 --- /dev/null +++ b/Jenga/Render.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE OverloadedStrings #-} +module Jenga.Render + ( LazyText (..) + , renderAsCabalConfig + , renderAsMafiaLock + ) where + +import qualified Data.List as DL +import Data.Text (Text) +import qualified Data.Text.Lazy as LT + +import Jenga.PackageList + + +newtype LazyText + = LazyText { unLazyText :: LT.Text } + + +renderAsCabalConfig :: [(Text, PackageInfo)] -> LazyText +renderAsCabalConfig pkgs = + LazyText . LT.fromChunks $ "constraints: " : cabalLines + where + cabalLines = DL.concat . DL.intersperse [",\n "] $ DL.map renderPackage pkgs + +renderAsMafiaLock :: [(Text, PackageInfo)] -> LazyText +renderAsMafiaLock pkgs = + LazyText . LT.fromChunks $ DL.intercalate ["\n"] mafiaLines + where + mafiaLines = ["# mafia-lock-file-version: 0"] : DL.map renderPackage pkgs + +renderPackage :: (Text, PackageInfo) -> [Text] +renderPackage (name, pkg) = + [ name, " == ", packageVersion pkg ] + diff --git a/Jenga/Stack.hs b/Jenga/Stack.hs --- a/Jenga/Stack.hs +++ b/Jenga/Stack.hs @@ -1,28 +1,57 @@ +{-# LANGUAGE OverloadedStrings #-} + module Jenga.Stack - ( readResolver + ( StackConfig (..) + , StackExtraDep (..) + , readStackConfig ) where --- Read the resolver from the stack.yaml file in the current directory. --- This is unashamedly savage. +import Data.Aeson (FromJSON (..), Value (..), (.:)) +import Data.Aeson.Types (typeMismatch) -import Data.Char (isSpace) import qualified Data.List as DL +import Data.Monoid ((<>)) -import Jenga.HTTP +import Data.Text (Text) +import qualified Data.Text as T +import Data.Yaml (ParseException, Parser) +import qualified Data.Yaml as Y -readResolver :: IO (Maybe StackResolver) -readResolver = -- Is this the *only* file name? - extract <$> readFile "stack.yaml" +data StackConfig = StackConfig + { stackResolver :: !Text + , stackExtraDeps :: ![StackExtraDep] + } + deriving (Eq, Show) +instance FromJSON StackConfig where + parseJSON (Object v) = StackConfig + <$> v .: "resolver" + <*> v .: "extra-deps" -extract :: String -> Maybe StackResolver -extract xs = - case filter (DL.isPrefixOf "resolver:") (lines xs) of - [x] -> Just .StackResolver $ cleanup x - _ -> Nothing - where - cleanup = DL.takeWhile (not . isSpace) - . DL.dropWhile (isSpace) - . DL.drop 1 - . DL.dropWhile (/= ':') + parseJSON invalid = typeMismatch "StackConfig" invalid + + +data StackExtraDep + = StackExtraDep !Text !Text + deriving (Eq, Show) + +instance FromJSON StackExtraDep where + parseJSON (String s) = parseStackExtraDep s + parseJSON invalid = typeMismatch "StackExtraDep" invalid + +parseStackExtraDep :: Text -> Parser StackExtraDep +parseStackExtraDep str = do + -- Extra-deps are of the form 'packageMame-version' where packageName itself + -- may have a dash in it. + let xs = T.splitOn "-" str + if DL.length xs >= 2 + then pure $ StackExtraDep (T.intercalate "-" $ init xs) (last xs) + else fail $ "Can't find version number in extra-dep : " <> T.unpack str + +readStackConfig :: IO (Either ParseException StackConfig) +readStackConfig = Y.decodeFileEither stackYamlFile + + +stackYamlFile :: FilePath +stackYamlFile = "stack.yaml" diff --git a/jenga.cabal b/jenga.cabal --- a/jenga.cabal +++ b/jenga.cabal @@ -1,49 +1,52 @@ -- Initial jenga.cabal generated by cabal init. For further documentation, -- see http://haskell.org/cabal/users-guide/ -name: jenga -version: 0.1.0.0 -synopsis: Generate a cabal freeze file from a stack.yaml +name: jenga +version: 0.1.1.0 +synopsis: Generate a cabal freeze file from a stack.yaml -- description: -homepage: https://github.com/erikd/jenga -license: BSD2 -license-file: LICENSE -author: Erik de Castro Lopo -maintainer: erikd@mega-nerd.com +homepage: https://github.com/erikd/jenga +license: BSD2 +license-file: LICENSE +author: Erik de Castro Lopo +maintainer: erikd@mega-nerd.com -- copyright: -category: Development -build-type: Simple -extra-source-files: ChangeLog.md -cabal-version: >= 1.10 +category: Development +build-type: Simple +extra-source-files: ChangeLog.md +cabal-version: >= 1.10 library - ghc-options: -Wall -fwarn-tabs - default-language: Haskell2010 + ghc-options: -Wall -fwarn-tabs + default-language: Haskell2010 - build-depends: base >= 4.8 && < 4.10 + build-depends: base >= 4.8 && < 5 , aeson == 1.1.* - , Cabal == 1.24.* + , Cabal >= 1.24 && < 2.1 , containers == 0.5.* , bytestring == 0.10.* , http-conduit == 2.2.* , http-types == 0.9.* , text == 1.2.* + , yaml == 0.8.* exposed-modules: Jenga.Cabal , Jenga.PackageList , Jenga.HTTP + , Jenga.Render , Jenga.Stack other-extensions: OverloadedStrings executable jenga - ghc-options: -Wall -fwarn-tabs - default-language: Haskell2010 + ghc-options: -Wall -fwarn-tabs + default-language: Haskell2010 hs-source-dirs: main main-is: jenga.hs - build-depends: base + build-depends: base , jenga + , optparse-applicative == 0.13.* , text diff --git a/main/jenga.hs b/main/jenga.hs --- a/main/jenga.hs +++ b/main/jenga.hs @@ -4,64 +4,89 @@ import Data.Either (partitionEithers) import qualified Data.List as DL +import Data.Monoid ((<>)) import Data.Text (Text) -import qualified Data.Text.IO as T +import qualified Data.Text.Lazy.IO as T import Jenga.Cabal import Jenga.HTTP import Jenga.PackageList +import Jenga.Render import Jenga.Stack +import Options.Applicative + ( Parser, ParserInfo, execParser, flag, fullDesc + , header, help, helper, info, long, metavar, short, strOption) + import System.IO (hPutStrLn, stderr) -import System.Environment (getArgs) main :: IO () -main = do - args <- getArgs - case args of - [cf] -> process cf - _ -> usageExit +main = + execParser opts >>= process + where + opts :: ParserInfo Command + opts = info (helper <*> pCommand) + ( fullDesc <> header "jenaga - Generate a cabal freeze file from a stack.yaml" + ) +-- ----------------------------------------------------------------------------- -usageExit :: IO () -usageExit = - putStrLn $ "\nUsage: jenga \n" +data OutputFormat + = OutputCabal + | OutputMafia -process :: FilePath -> IO () -process cabalFile = do - deps <- fmap dependencyName <$> readPackageDependencies cabalFile - mr <- readResolver +data Command = Command FilePath OutputFormat + +pCommand :: Parser Command +pCommand = Command <$> cabalFileP <*> outputFormatP + +cabalFileP :: Parser FilePath +cabalFileP = strOption + ( short 'i' + <> long "input" + <> metavar "INPUT_CABAL_FILE" + <> help "The input cabal file." + ) + +outputFormatP :: Parser OutputFormat +outputFormatP = + flag OutputCabal OutputMafia + ( short 'm' + <> long "mafia" + <> help "Render the output as a mafia lock file (rendering as a cabal.config is the default)." + ) + +-- ----------------------------------------------------------------------------- + +process :: Command -> IO () +process (Command cabalpath fmt) = do + deps <- fmap dependencyName <$> readPackageDependencies cabalpath + mr <- readStackConfig case mr of - Nothing -> putStrLn "Not able to find resolver version in 'stack.yaml' file." - Just r -> processResolver deps r + Left err -> putStrLn $ show err + Right cfg -> processResolver fmt deps cfg -processResolver :: [Text] -> StackResolver -> IO () -processResolver deps sr = do - mpl <- getStackageResolverPkgList sr +processResolver :: OutputFormat -> [Text] -> StackConfig -> IO () +processResolver fmt deps scfg = do + mpl <- getStackageResolverPkgList scfg case mpl of Left s -> putStrLn $ "Error parse JSON: " ++ s - Right pl -> processPackageList deps pl + Right pl -> processPackageList fmt deps pl -processPackageList :: [Text] -> PackageList -> IO () -processPackageList deps plist = do +processPackageList :: OutputFormat -> [Text] -> PackageList -> IO () +processPackageList fmt deps plist = do let (missing, found) = partitionEithers $ lookupPackages plist deps unless (DL.null missing) $ reportMissing missing - printCabalFreeze found + T.putStrLn . unLazyText $ + case fmt of + OutputCabal -> renderAsCabalConfig found + OutputMafia -> renderAsMafiaLock found reportMissing :: [Text] -> IO () reportMissing [] = putStrLn "No missing packages found." reportMissing xs = hPutStrLn stderr $ "The packages " ++ show xs ++ " could not be found in the specified stack resolver data." - -printCabalFreeze :: [(Text, PackageInfo)] -> IO () -printCabalFreeze xs = do - putStr "constraints:" - T.putStrLn . mconcat . DL.intersperse ",\n" $ DL.map render xs - where - render (name, pkg) = - mconcat [ " ", name, " == ", packageVersion pkg ] -