jenga 0.1.0.0 → 0.1.1.0

raw patch · 8 files changed

+213/−97 lines, 8 filesdep +optparse-applicativedep +yamldep ~Cabaldep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: optparse-applicative, yaml

Dependency ranges changed: Cabal, base

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−1
• Jenga/Cabal.hs +18/−7
• Jenga/HTTP.hs +12/−15
• Jenga/PackageList.hs +18/−5
• Jenga/Render.hs +34/−0
• Jenga/Stack.hs +47/−18
• jenga.cabal +22/−19
• main/jenga.hs +57/−32

@@ -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.

@@ -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

@@ -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)

@@ -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

@@ -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 ]+

@@ -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"

@@ -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

@@ -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 <cabal file>\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 ]-