stack2cabal 1.0.3 → 1.0.4
raw patch · 3 files changed
+398/−27 lines, 3 filesdep +HsYAMLdep +containersdep +http-clientdep −stackage-to-hackagedep ~Cabaldep ~basedep ~bytestring
Dependencies added: HsYAML, containers, http-client, http-client-tls, stack2cabal
Dependencies removed: stackage-to-hackage
Dependency ranges changed: Cabal, base, bytestring, directory, filepath
Files
- lib/StackageToHackage/Hackage.hs +100/−0
- lib/StackageToHackage/Stackage.hs +252/−0
- stack2cabal.cabal +46/−27
+ lib/StackageToHackage/Hackage.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}++-- | A simplistic model of cabal multi-package files and convertors from Stackage.+module StackageToHackage.Hackage+ ( stackToCabal+ , Project(..), printProject+ , Freeze(..), printFreeze+ ) where++import Data.List (sort)+import Data.List.Extra (nubOn)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NEL+import qualified Data.Map.Strict as M+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Semigroup+import Data.Semigroup (sconcat)+import Data.Text (Text)+import qualified Data.Text as T+import Distribution.Pretty (prettyShow)+import Distribution.Types.PackageId (PackageIdentifier(..))+import Distribution.Types.PackageName (PackageName, unPackageName)+import StackageToHackage.Stackage+import System.FilePath (addTrailingPathSeparator)++-- | Converts a stack.yaml (and list of local packages) to cabal.project and+-- cabal.project.freeze.+stackToCabal :: [PackageName] -> FilePath -> Stack -> IO (Project, Freeze)+stackToCabal ignore dir stack = do+ resolvers <- unroll dir stack+ let resolver = sconcat resolvers+ project = genProject stack resolver+ freeze = genFreeze resolver ignore+ pure (project, freeze)++-- TODO: something like stackToCabal that puts constraints into .cabal files++printProject :: Project -> Text+printProject (Project (Ghc ghc) pkgs srcs) =+ T.concat [ "-- Generated by stackage-to-hackage\n\n"+ , "with-compiler: ", ghc, "\n\n"+ , "packages:\n ", packages, "\n\n"+ , sources, "\n"+ , "allow-older: *\n"+ , "allow-newer: *\n"+ ]+ where+ packages = T.intercalate "\n , " (T.pack . addTrailingPathSeparator <$>+ NEL.toList pkgs)+ sources = T.intercalate "\n" (source =<< srcs)+ source Git{repo, commit, subdirs} =+ let base = T.concat [ "source-repository-package\n "+ , "type: git\n "+ , "location: ", repo, "\n "+ , "tag: ", commit, "\n"]+ in if null subdirs+ then [base]+ else (\d -> T.concat [base, " subdir: ", d, "\n"]) <$> subdirs++data Project = Project Ghc (NonEmpty FilePath) [Git] deriving (Show)++genProject :: Stack -> Resolver -> Project+genProject stack Resolver{compiler, deps} = Project+ (fromMaybe (Ghc "ghc") compiler)+ (localDirs stack)+ (nubOn repo $ mapMaybe pickGit deps)+ where+ pickGit (Hackage _ ) = Nothing+ pickGit (SourceDep g) = Just g++printFreeze :: Freeze -> Text+printFreeze (Freeze deps (Flags flags)) =+ T.concat [ "constraints:\n ", constraints, "\n"]+ where+ constraints = T.intercalate "\n , " (constrait <$> sort deps)+ constrait pkg =+ let name = (T.pack . unPackageName . pkgName $ pkg)+ ver = (T.pack . prettyShow . pkgVersion $ pkg)+ base = T.concat [name, " ==", ver]+ in case M.lookup name flags of+ Nothing -> base+ Just entries -> T.concat [ name, " ", (custom entries)+ , "\n , ", base]+ custom (M.toList -> lst) = T.intercalate " " $ (renderFlag <$> lst)+ renderFlag (name, True) = "+" <> name+ renderFlag (name, False) = "-" <> name++data Freeze = Freeze [PackageIdentifier] Flags deriving (Show)++genFreeze :: Resolver -> [PackageName] -> Freeze+genFreeze Resolver{deps, flags} ignore =+ let pkgs = filter noSelfs $ unPkgId <$> mapMaybe pick deps+ uniqpkgs = nubOn pkgName pkgs+ in Freeze uniqpkgs flags+ where pick (Hackage p) = Just p+ pick (SourceDep _) = Nothing+ noSelfs (pkgName -> n) = notElem n ignore
+ lib/StackageToHackage/Stackage.hs view
@@ -0,0 +1,252 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Duplicates a subset of the Stack ADT. It'd be nice if we could just re-use+-- the actual ADT, but stack isn't available as a library that we can build from+-- Hackage.+module StackageToHackage.Stackage where++import Control.Applicative (Alternative, empty, (<|>))+import Control.Monad.Extra (loopM, unlessM)+import qualified Data.ByteString as BS+import Data.ByteString.Lazy (toStrict)+import Data.List.NonEmpty (NonEmpty(..), head, nonEmpty,+ reverse, (<|))+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)+import Data.Semigroup+import Data.Text (Text, isSuffixOf, replace,+ takeWhile, unpack)+import Data.YAML (FromYAML, Mapping, Node(..),+ Parser, Scalar(..), decodeStrict,+ parseYAML, withMap, withStr,+ (.!=), (.:), (.:?))+import Distribution.Text (simpleParse)+import Distribution.Types.PackageId (PackageIdentifier(..))+import Network.HTTP.Client (httpLbs, parseRequest,+ responseBody)+import Network.HTTP.Client.TLS (getGlobalManager)+import Prelude hiding (head, reverse, takeWhile)+import System.Directory (XdgDirectory(..),+ createDirectoryIfMissing,+ doesFileExist, getXdgDirectory)+import System.FilePath (takeDirectory, (</>))++data Stack = Stack+ { resolver :: ResolverRef+ , compiler :: Maybe Ghc+ , packages :: [Package]+ , extraDeps :: [Dep]+ , flags :: Flags+ -- TODO ghcOptions+ } deriving (Show)++localDirs :: Stack -> NonEmpty FilePath+localDirs Stack{packages} =+ fromMaybe (pure ".") $ nonEmpty $ mapMaybe locals packages+ where+ locals (Local p) = Just p+ locals (Location _) = Nothing++newtype Ghc = Ghc Text+ deriving (Show)+ deriving newtype (FromYAML)++data Package = Local FilePath+ | Location Git+ deriving (Show)++data Git = Git+ { repo :: Repo+ , commit :: Commit+ , subdirs :: [Subdir]+ } deriving (Show)+type Repo = Text+type Commit = Text+type Subdir = Text++data Resolver = Resolver+ { resolver :: Maybe ResolverRef+ , compiler :: Maybe Ghc+ , deps :: [Dep]+ , flags :: Flags+ } deriving (Show)+instance Semigroup Resolver where+ (Resolver r c p f) <> (Resolver r' c' p' f') =+ Resolver (r <|> r') (c <|> c') (p <> p') (f <> f')++-- TODO: remote ResolverRefs+data ResolverRef = Canned Text+ | Snapshot Text+ deriving (Show)++-- http://hackage.haskell.org/package/Cabal-2.4.1.0/docs/Distribution-Types-PackageId.html#t:PackageIdentifier+-- http://hackage.haskell.org/package/Cabal-2.4.1.0/docs/Distribution-Parsec-Class.html#v:simpleParsec++data Dep = Hackage PkgId+ | SourceDep Git+ deriving (Show)++newtype Flags = Flags (Map PkgName (Map FlagName Bool))+ deriving (Show)+ deriving newtype (FromYAML, Semigroup)++type PkgName = Text+type FlagName = Text++-- the format used at https://github.com/commercialhaskell/stackage-snapshots+-- which is similar to the Resolver format.+data NewResolver = NewResolver+ { compiler :: Ghc+ , packages :: [NewDep]+ , flags :: Flags+ } deriving (Show)++data NewDep = NewDep PkgId+ deriving (Show)++--------------------------------------------------------------------------------+-- Resolvers++readStack :: BS.ByteString -> IO Stack+readStack text = either fail pure $ decode1Strict text++type RelativeResolvers = NonEmpty (Maybe FilePath, Resolver)+type Resolvers = NonEmpty Resolver++-- highest priority resolver first+unroll :: FilePath -> Stack -> IO Resolvers+unroll base stack = do+ let stack' = stack2resolver stack+ reverse <$> (loopM next (pure (Just base, stack')))+ where+ -- lowest priority (deepest) resolver first+ next :: RelativeResolvers -> IO (Either RelativeResolvers Resolvers)+ next rs = case head rs of+ (_, Resolver Nothing _ _ _) -> pure $ Right (snd <$> rs)+ (dir, Resolver (Just r) _ _ _) -> (Left . (<| rs)) <$> resolve dir r++-- if the Resolver is a local snapshot, also include its dir+resolve :: Maybe FilePath -> ResolverRef -> IO (Maybe FilePath, Resolver)+resolve _ (Canned lts) = do+ cached <- cache lts+ text <- (BS.readFile cached) <|> download+ update cached text+ either fail (\r -> pure (Nothing, r)) $ new2old <$> (decode1Strict $ text)+ where+ download =+ let path = unpack $ replace "." "/" (replace "-" "/" (replace "-0" "-" lts))+ raw = concat ["https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/", path, ".yaml"]+ in do+ manager <- getGlobalManager+ url <- parseRequest raw+ putStrLn ("Downloading: " <> raw)+ resp <- httpLbs url manager+ pure $ toStrict $ responseBody resp++ update file content = unlessM (doesFileExist file) (BS.writeFile file content)++resolve (Just base) (Snapshot path) = do+ let file = base </> (unpack path)+ dir = takeDirectory file+ text <- BS.readFile file+ either fail (\r -> pure (Just dir, r)) $ decode1Strict text++resolve Nothing _ = fail "Remote snapshots can't use relative paths."++cache :: Text -> IO FilePath+cache file = do+ dir <- getXdgDirectory XdgCache "stackage"+ createDirectoryIfMissing True dir+ pure $ dir </> (unpack file)++stack2resolver :: Stack -> Resolver+stack2resolver Stack{resolver, compiler, packages, extraDeps, flags} =+ Resolver (Just resolver) compiler (sourcedeps <> extraDeps) flags+ where sourcedeps = mapMaybe pick packages+ pick (Local _) = Nothing+ pick (Location g) = Just . SourceDep $ g++new2old :: NewResolver -> Resolver+new2old NewResolver{compiler, packages, flags} =+ Resolver Nothing (Just compiler) (new2old' <$> packages) flags+ where+ new2old' (NewDep pkg) = Hackage pkg++--------------------------------------------------------------------------------+-- YAML boilerplate++-- https://github.com/haskell-hvr/HsYAML/pull/5+decode1Strict :: FromYAML a => BS.ByteString -> Either String a+decode1Strict text = do+ as <- decodeStrict text+ maybe (Left "expected unique") Right $ listToMaybe as++instance FromYAML Stack where+ parseYAML = withMap "Stack" $ \m -> Stack+ <$> m .: "resolver"+ <*> m .:? "compiler"+ <*> m .:? "packages" .!= mempty+ <*> m .:? "extra-deps" .!= mempty+ <*> m .:? "flags" .!= (Flags M.empty)++instance FromYAML Git where+ parseYAML = withMap "Git" $ \m -> Git+ <$> m .: "git"+ <*> m .: "commit"+ <*> m .:? "subdirs" .!= []++instance FromYAML ResolverRef where+ parseYAML = withStr "ResolverRef" $ \s ->+ if isSuffixOf ".yaml" s+ then (pure . Snapshot) s+ else (pure . Canned) s++instance FromYAML Package where+ parseYAML n = (local n) <|> (location n)+ where+ local = withStr "Local" $ pure . Local . unpack+ location = withMap "Location" $ \m ->+ Location <$> m .: "location"++instance FromYAML Dep where+ parseYAML n = hackage <|> source+ where+ hackage = Hackage <$> parseYAML n+ source = SourceDep <$> parseYAML n++instance FromYAML Resolver where+ parseYAML = withMap "Resolver" $ \m -> Resolver+ <$> m .:? "resolver"+ <*> m .:? "compiler"+ <*> m .:? "packages" .!= mempty+ <*> m .:? "flags" .!= (Flags M.empty)++instance FromYAML NewDep where+ parseYAML = withMap "NewDep" $ \m -> hackage' =<< m .: "hackage"+ where+ hackage' n = NewDep <$> parseYAML n++instance FromYAML NewResolver where+ parseYAML = withMap "NewResolver" $ \m -> NewResolver+ <$> (m .: "compiler" <|> m ..: ("resolver", "compiler"))+ <*> m .:? "packages" .!= mempty+ <*> m .:? "flags" .!= (Flags M.empty)+ where+ (..:) :: FromYAML a => Mapping -> (Text, Text) -> Parser a+ m1 ..: (k1, k2) =+ case M.lookup (Scalar (SStr k1)) m1 of+ Just (Mapping _ m2) -> m2 .: k2+ _ -> fail $ "key " ++ show k1 ++ " not found"++newtype PkgId = PkgId { unPkgId :: PackageIdentifier } deriving (Show)+instance FromYAML PkgId where+ parseYAML = withStr "PackageIdentifier" $ \s ->+ PkgId <$> (hoistMaybe . simpleParse . unpack) (takeWhile ('@' /=) s)++hoistMaybe :: Alternative m => Maybe a -> m a+hoistMaybe = maybe empty pure
stack2cabal.cabal view
@@ -1,33 +1,52 @@-cabal-version: 2.2-name: stack2cabal-version: 1.0.3-synopsis: Convert stack projects to cabal.project + cabal.project.freeze-license: GPL-3.0-or-later-license-file: LICENSE-author: Tseen She-maintainer: Tseen She-copyright: 2018 Tseen She-bug-reports: https://gitlab.com/tseenshe/stack2cabal/merge_requests-tested-with: GHC ^>= 8.4.4 || ^>= 8.6.3-category: Building+cabal-version: 2.2+name: stack2cabal+version: 1.0.4+synopsis:+ Convert stack projects to cabal.project + cabal.project.freeze++license: GPL-3.0-or-later+license-file: LICENSE+author: Tseen She+maintainer: Tseen She+copyright: 2018 Tseen She+bug-reports: https://gitlab.com/tseenshe/stack2cabal/merge_requests+tested-with: GHC ^>=8.2.2 || ^>=8.4.4 || ^>=8.6.5+category: Building description: Convert @stack.yaml@ \/ @package.yaml@ to @cabal.project@ \/ @cabal.project.freeze@\/ @*.cabal@. -- https://www.haskell.org/cabal/users-guide/cabal-projectindex.html +common deps+ build-depends:+ , base >=4.10 && <5.0+ , bytestring+ , Cabal >=2.2 && <3.0+ , containers+ , directory+ , extra ^>=1.6.13+ , filepath+ , hpack ^>=0.31.0+ , HsYAML ^>=0.1.1.2+ , http-client ^>=0.5.14 || ^>=0.6.0+ , http-client-tls ^>=0.3.5.3+ , text ^>=1.2.3.1++ ghc-options: -Wall -Werror=missing-home-modules+ default-language: Haskell2010+ executable stack2cabal- hs-source-dirs: exe- main-is: Main.hs- build-depends: stackage-to-hackage ^>= 1.1.1- , base ^>= 4.11.1.0 || ^>= 4.12.0.0- , bytestring ^>= 0.10.8.2- , Cabal ^>= 2.4.1.0- , directory ^>= 1.3.3.1- , extra ^>= 1.6.13- , filepath ^>= 1.4.2.1- , hpack == 0.31.1- , text ^>= 1.2.3.1- ghc-options: -Wall- -Werror=missing-home-modules- default-language: Haskell2010- ghc-options: -threaded+ import: deps+ hs-source-dirs: exe+ main-is: Main.hs+ build-depends: stack2cabal+ ghc-options: -threaded++library+ import: deps+ hs-source-dirs: lib++ -- cabal-fmt: expand lib+ exposed-modules:+ StackageToHackage.Hackage+ StackageToHackage.Stackage