stack2cabal 1.0.6 → 1.0.11
raw patch · 9 files changed
+851/−348 lines, 9 filesdep +exceptionsdep +filepatterndep +fuzzy-datesdep ~Cabaldep ~HsYAMLdep ~extranew-uploaderPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: exceptions, filepattern, fuzzy-dates, hourglass, optparse-applicative, process, safe, temporary
Dependency ranges changed: Cabal, HsYAML, extra, hpack, http-client, text
API changes (from Hackage documentation)
- StackageToHackage.Hackage: data Freeze
- StackageToHackage.Hackage: instance GHC.Show.Show StackageToHackage.Hackage.Freeze
- StackageToHackage.Hackage: instance GHC.Show.Show StackageToHackage.Hackage.Project
- StackageToHackage.Stackage: Canned :: Text -> ResolverRef
- StackageToHackage.Stackage: Flags :: Map PkgName (Map FlagName Bool) -> Flags
- StackageToHackage.Stackage: Ghc :: Text -> Ghc
- StackageToHackage.Stackage: Git :: Repo -> Commit -> [Subdir] -> Git
- StackageToHackage.Stackage: Hackage :: PkgId -> Dep
- StackageToHackage.Stackage: Local :: FilePath -> Package
- StackageToHackage.Stackage: Location :: Git -> Package
- StackageToHackage.Stackage: NewDep :: PkgId -> NewDep
- StackageToHackage.Stackage: NewResolver :: Ghc -> [NewDep] -> Flags -> NewResolver
- StackageToHackage.Stackage: PkgId :: PackageIdentifier -> PkgId
- StackageToHackage.Stackage: Resolver :: Maybe ResolverRef -> Maybe Ghc -> [Dep] -> Flags -> Resolver
- StackageToHackage.Stackage: Snapshot :: Text -> ResolverRef
- StackageToHackage.Stackage: SourceDep :: Git -> Dep
- StackageToHackage.Stackage: Stack :: ResolverRef -> Maybe Ghc -> [Package] -> [Dep] -> Flags -> Stack
- StackageToHackage.Stackage: [$sel:commit:Git] :: Git -> Commit
- StackageToHackage.Stackage: [$sel:compiler:NewResolver] :: NewResolver -> Ghc
- StackageToHackage.Stackage: [$sel:compiler:Resolver] :: Resolver -> Maybe Ghc
- StackageToHackage.Stackage: [$sel:compiler:Stack] :: Stack -> Maybe Ghc
- StackageToHackage.Stackage: [$sel:deps:Resolver] :: Resolver -> [Dep]
- StackageToHackage.Stackage: [$sel:extraDeps:Stack] :: Stack -> [Dep]
- StackageToHackage.Stackage: [$sel:flags:NewResolver] :: NewResolver -> Flags
- StackageToHackage.Stackage: [$sel:flags:Resolver] :: Resolver -> Flags
- StackageToHackage.Stackage: [$sel:flags:Stack] :: Stack -> Flags
- StackageToHackage.Stackage: [$sel:packages:NewResolver] :: NewResolver -> [NewDep]
- StackageToHackage.Stackage: [$sel:packages:Stack] :: Stack -> [Package]
- StackageToHackage.Stackage: [$sel:repo:Git] :: Git -> Repo
- StackageToHackage.Stackage: [$sel:resolver:Resolver] :: Resolver -> Maybe ResolverRef
- StackageToHackage.Stackage: [$sel:resolver:Stack] :: Stack -> ResolverRef
- StackageToHackage.Stackage: [$sel:subdirs:Git] :: Git -> [Subdir]
- StackageToHackage.Stackage: [$sel:unPkgId:PkgId] :: PkgId -> PackageIdentifier
- StackageToHackage.Stackage: data Dep
- StackageToHackage.Stackage: data Git
- StackageToHackage.Stackage: data NewDep
- StackageToHackage.Stackage: data NewResolver
- StackageToHackage.Stackage: data Package
- StackageToHackage.Stackage: data Resolver
- StackageToHackage.Stackage: data ResolverRef
- StackageToHackage.Stackage: data Stack
- StackageToHackage.Stackage: hoistMaybe :: Alternative m => Maybe a -> m a
- StackageToHackage.Stackage: instance Data.YAML.FromYAML StackageToHackage.Stackage.Dep
- StackageToHackage.Stackage: instance Data.YAML.FromYAML StackageToHackage.Stackage.Flags
- StackageToHackage.Stackage: instance Data.YAML.FromYAML StackageToHackage.Stackage.Ghc
- StackageToHackage.Stackage: instance Data.YAML.FromYAML StackageToHackage.Stackage.Git
- StackageToHackage.Stackage: instance Data.YAML.FromYAML StackageToHackage.Stackage.NewDep
- StackageToHackage.Stackage: instance Data.YAML.FromYAML StackageToHackage.Stackage.NewResolver
- StackageToHackage.Stackage: instance Data.YAML.FromYAML StackageToHackage.Stackage.Package
- StackageToHackage.Stackage: instance Data.YAML.FromYAML StackageToHackage.Stackage.PkgId
- StackageToHackage.Stackage: instance Data.YAML.FromYAML StackageToHackage.Stackage.Resolver
- StackageToHackage.Stackage: instance Data.YAML.FromYAML StackageToHackage.Stackage.ResolverRef
- StackageToHackage.Stackage: instance Data.YAML.FromYAML StackageToHackage.Stackage.Stack
- StackageToHackage.Stackage: instance GHC.Base.Semigroup StackageToHackage.Stackage.Flags
- StackageToHackage.Stackage: instance GHC.Base.Semigroup StackageToHackage.Stackage.Resolver
- StackageToHackage.Stackage: instance GHC.Show.Show StackageToHackage.Stackage.Dep
- StackageToHackage.Stackage: instance GHC.Show.Show StackageToHackage.Stackage.Flags
- StackageToHackage.Stackage: instance GHC.Show.Show StackageToHackage.Stackage.Ghc
- StackageToHackage.Stackage: instance GHC.Show.Show StackageToHackage.Stackage.Git
- StackageToHackage.Stackage: instance GHC.Show.Show StackageToHackage.Stackage.NewDep
- StackageToHackage.Stackage: instance GHC.Show.Show StackageToHackage.Stackage.NewResolver
- StackageToHackage.Stackage: instance GHC.Show.Show StackageToHackage.Stackage.Package
- StackageToHackage.Stackage: instance GHC.Show.Show StackageToHackage.Stackage.PkgId
- StackageToHackage.Stackage: instance GHC.Show.Show StackageToHackage.Stackage.Resolver
- StackageToHackage.Stackage: instance GHC.Show.Show StackageToHackage.Stackage.ResolverRef
- StackageToHackage.Stackage: instance GHC.Show.Show StackageToHackage.Stackage.Stack
- StackageToHackage.Stackage: newtype Flags
- StackageToHackage.Stackage: newtype Ghc
- StackageToHackage.Stackage: newtype PkgId
- StackageToHackage.Stackage: type Commit = Text
- StackageToHackage.Stackage: type FlagName = Text
- StackageToHackage.Stackage: type PkgName = Text
- StackageToHackage.Stackage: type RelativeResolvers = NonEmpty (Maybe FilePath, Resolver)
- StackageToHackage.Stackage: type Repo = Text
- StackageToHackage.Stackage: type Resolvers = NonEmpty Resolver
- StackageToHackage.Stackage: type Subdir = Text
+ StackageToHackage.Hackage: [ghcOpts] :: Project -> GhcOptions
+ StackageToHackage.Hackage: [ghc] :: Project -> Ghc
+ StackageToHackage.Hackage: [pkgs] :: Project -> NonEmpty FilePath
+ StackageToHackage.Hackage: [srcs] :: Project -> [Git]
+ StackageToHackage.Hackage: newtype Freeze
+ StackageToHackage.Hackage.Types: FlagSetting :: PkgName -> Map FlagName Bool -> Constraint
+ StackageToHackage.Hackage.Types: Freeze :: [Constraint] -> Freeze
+ StackageToHackage.Hackage.Types: Project :: Ghc -> NonEmpty FilePath -> [Git] -> GhcOptions -> Project
+ StackageToHackage.Hackage.Types: VersionPin :: PackageIdentifier -> Constraint
+ StackageToHackage.Hackage.Types: [ghcOpts] :: Project -> GhcOptions
+ StackageToHackage.Hackage.Types: [ghc] :: Project -> Ghc
+ StackageToHackage.Hackage.Types: [pkgs] :: Project -> NonEmpty FilePath
+ StackageToHackage.Hackage.Types: [srcs] :: Project -> [Git]
+ StackageToHackage.Hackage.Types: data Constraint
+ StackageToHackage.Hackage.Types: data Project
+ StackageToHackage.Hackage.Types: instance GHC.Classes.Eq StackageToHackage.Hackage.Types.Constraint
+ StackageToHackage.Hackage.Types: instance GHC.Classes.Ord StackageToHackage.Hackage.Types.Constraint
+ StackageToHackage.Hackage.Types: instance GHC.Show.Show StackageToHackage.Hackage.Types.Constraint
+ StackageToHackage.Hackage.Types: instance GHC.Show.Show StackageToHackage.Hackage.Types.Freeze
+ StackageToHackage.Hackage.Types: instance GHC.Show.Show StackageToHackage.Hackage.Types.Project
+ StackageToHackage.Hackage.Types: newtype Freeze
+ StackageToHackage.Hpack: execHpack :: FilePath -> IO Result
+ StackageToHackage.Hpack: hpackInput :: FilePath -> FilePath
+ StackageToHackage.Prelude: hoistMaybe :: Alternative m => Maybe a -> m a
+ StackageToHackage.Stackage.Types: Canned :: Text -> ResolverRef
+ StackageToHackage.Stackage.Types: Flags :: Map PkgName (Map FlagName Bool) -> Flags
+ StackageToHackage.Stackage.Types: Ghc :: Text -> Ghc
+ StackageToHackage.Stackage.Types: GhcOptions :: Maybe GhcFlags -> Maybe GhcFlags -> Maybe GhcFlags -> PackageGhcOpts -> GhcOptions
+ StackageToHackage.Stackage.Types: Git :: Repo -> Commit -> [Subdir] -> Git
+ StackageToHackage.Stackage.Types: Hackage :: PkgId -> Dep
+ StackageToHackage.Stackage.Types: Local :: FilePath -> Package
+ StackageToHackage.Stackage.Types: LocalDep :: FilePath -> Dep
+ StackageToHackage.Stackage.Types: Location :: Git -> Package
+ StackageToHackage.Stackage.Types: NewDep :: PkgId -> NewDep
+ StackageToHackage.Stackage.Types: NewResolver :: Ghc -> [NewDep] -> Flags -> NewResolver
+ StackageToHackage.Stackage.Types: PackageGhcOpts :: Map PkgId GhcFlags -> PackageGhcOpts
+ StackageToHackage.Stackage.Types: PkgId :: PackageIdentifier -> PkgId
+ StackageToHackage.Stackage.Types: Resolver :: Maybe ResolverRef -> Maybe Ghc -> [Dep] -> Flags -> Resolver
+ StackageToHackage.Stackage.Types: Snapshot :: Text -> ResolverRef
+ StackageToHackage.Stackage.Types: SourceDep :: Git -> Dep
+ StackageToHackage.Stackage.Types: Stack :: ResolverRef -> Maybe Ghc -> [Package] -> [Dep] -> Flags -> GhcOptions -> Stack
+ StackageToHackage.Stackage.Types: [$sel:commit:Git] :: Git -> Commit
+ StackageToHackage.Stackage.Types: [$sel:compiler:NewResolver] :: NewResolver -> Ghc
+ StackageToHackage.Stackage.Types: [$sel:compiler:Resolver] :: Resolver -> Maybe Ghc
+ StackageToHackage.Stackage.Types: [$sel:compiler:Stack] :: Stack -> Maybe Ghc
+ StackageToHackage.Stackage.Types: [$sel:deps:Resolver] :: Resolver -> [Dep]
+ StackageToHackage.Stackage.Types: [$sel:everything:GhcOptions] :: GhcOptions -> Maybe GhcFlags
+ StackageToHackage.Stackage.Types: [$sel:extraDeps:Stack] :: Stack -> [Dep]
+ StackageToHackage.Stackage.Types: [$sel:flags:NewResolver] :: NewResolver -> Flags
+ StackageToHackage.Stackage.Types: [$sel:flags:Resolver] :: Resolver -> Flags
+ StackageToHackage.Stackage.Types: [$sel:flags:Stack] :: Stack -> Flags
+ StackageToHackage.Stackage.Types: [$sel:ghcOptions:Stack] :: Stack -> GhcOptions
+ StackageToHackage.Stackage.Types: [$sel:locals:GhcOptions] :: GhcOptions -> Maybe GhcFlags
+ StackageToHackage.Stackage.Types: [$sel:packages:NewResolver] :: NewResolver -> [NewDep]
+ StackageToHackage.Stackage.Types: [$sel:packages:Stack] :: Stack -> [Package]
+ StackageToHackage.Stackage.Types: [$sel:packagesGhcOpts:GhcOptions] :: GhcOptions -> PackageGhcOpts
+ StackageToHackage.Stackage.Types: [$sel:repo:Git] :: Git -> Repo
+ StackageToHackage.Stackage.Types: [$sel:resolver:Resolver] :: Resolver -> Maybe ResolverRef
+ StackageToHackage.Stackage.Types: [$sel:resolver:Stack] :: Stack -> ResolverRef
+ StackageToHackage.Stackage.Types: [$sel:subdirs:Git] :: Git -> [Subdir]
+ StackageToHackage.Stackage.Types: [$sel:targets:GhcOptions] :: GhcOptions -> Maybe GhcFlags
+ StackageToHackage.Stackage.Types: [$sel:unPkgId:PkgId] :: PkgId -> PackageIdentifier
+ StackageToHackage.Stackage.Types: data Dep
+ StackageToHackage.Stackage.Types: data GhcOptions
+ StackageToHackage.Stackage.Types: data Git
+ StackageToHackage.Stackage.Types: data NewResolver
+ StackageToHackage.Stackage.Types: data Package
+ StackageToHackage.Stackage.Types: data Resolver
+ StackageToHackage.Stackage.Types: data ResolverRef
+ StackageToHackage.Stackage.Types: data Stack
+ StackageToHackage.Stackage.Types: emptyGhcOptions :: GhcOptions
+ StackageToHackage.Stackage.Types: instance GHC.Base.Monoid StackageToHackage.Stackage.Types.PackageGhcOpts
+ StackageToHackage.Stackage.Types: instance GHC.Base.Semigroup StackageToHackage.Stackage.Types.Flags
+ StackageToHackage.Stackage.Types: instance GHC.Base.Semigroup StackageToHackage.Stackage.Types.PackageGhcOpts
+ StackageToHackage.Stackage.Types: instance GHC.Base.Semigroup StackageToHackage.Stackage.Types.Resolver
+ StackageToHackage.Stackage.Types: instance GHC.Classes.Eq StackageToHackage.Stackage.Types.PkgId
+ StackageToHackage.Stackage.Types: instance GHC.Classes.Ord StackageToHackage.Stackage.Types.PkgId
+ StackageToHackage.Stackage.Types: instance GHC.Show.Show StackageToHackage.Stackage.Types.Dep
+ StackageToHackage.Stackage.Types: instance GHC.Show.Show StackageToHackage.Stackage.Types.Flags
+ StackageToHackage.Stackage.Types: instance GHC.Show.Show StackageToHackage.Stackage.Types.Ghc
+ StackageToHackage.Stackage.Types: instance GHC.Show.Show StackageToHackage.Stackage.Types.GhcOptions
+ StackageToHackage.Stackage.Types: instance GHC.Show.Show StackageToHackage.Stackage.Types.Git
+ StackageToHackage.Stackage.Types: instance GHC.Show.Show StackageToHackage.Stackage.Types.NewDep
+ StackageToHackage.Stackage.Types: instance GHC.Show.Show StackageToHackage.Stackage.Types.NewResolver
+ StackageToHackage.Stackage.Types: instance GHC.Show.Show StackageToHackage.Stackage.Types.Package
+ StackageToHackage.Stackage.Types: instance GHC.Show.Show StackageToHackage.Stackage.Types.PackageGhcOpts
+ StackageToHackage.Stackage.Types: instance GHC.Show.Show StackageToHackage.Stackage.Types.PkgId
+ StackageToHackage.Stackage.Types: instance GHC.Show.Show StackageToHackage.Stackage.Types.Resolver
+ StackageToHackage.Stackage.Types: instance GHC.Show.Show StackageToHackage.Stackage.Types.ResolverRef
+ StackageToHackage.Stackage.Types: instance GHC.Show.Show StackageToHackage.Stackage.Types.Stack
+ StackageToHackage.Stackage.Types: newtype Flags
+ StackageToHackage.Stackage.Types: newtype Ghc
+ StackageToHackage.Stackage.Types: newtype NewDep
+ StackageToHackage.Stackage.Types: newtype PackageGhcOpts
+ StackageToHackage.Stackage.Types: newtype PkgId
+ StackageToHackage.Stackage.Types: type Commit = Text
+ StackageToHackage.Stackage.Types: type FlagName = Text
+ StackageToHackage.Stackage.Types: type GhcFlags = Text
+ StackageToHackage.Stackage.Types: type PkgName = Text
+ StackageToHackage.Stackage.Types: type RelativeResolvers = NonEmpty (Maybe FilePath, Resolver)
+ StackageToHackage.Stackage.Types: type Repo = Text
+ StackageToHackage.Stackage.Types: type Resolvers = NonEmpty Resolver
+ StackageToHackage.Stackage.Types: type Subdir = Text
+ StackageToHackage.Stackage.YAML: fakePos :: Pos
+ StackageToHackage.Stackage.YAML: instance Data.YAML.FromYAML StackageToHackage.Stackage.Types.Dep
+ StackageToHackage.Stackage.YAML: instance Data.YAML.FromYAML StackageToHackage.Stackage.Types.Flags
+ StackageToHackage.Stackage.YAML: instance Data.YAML.FromYAML StackageToHackage.Stackage.Types.Ghc
+ StackageToHackage.Stackage.YAML: instance Data.YAML.FromYAML StackageToHackage.Stackage.Types.GhcOptions
+ StackageToHackage.Stackage.YAML: instance Data.YAML.FromYAML StackageToHackage.Stackage.Types.Git
+ StackageToHackage.Stackage.YAML: instance Data.YAML.FromYAML StackageToHackage.Stackage.Types.NewDep
+ StackageToHackage.Stackage.YAML: instance Data.YAML.FromYAML StackageToHackage.Stackage.Types.NewResolver
+ StackageToHackage.Stackage.YAML: instance Data.YAML.FromYAML StackageToHackage.Stackage.Types.Package
+ StackageToHackage.Stackage.YAML: instance Data.YAML.FromYAML StackageToHackage.Stackage.Types.PackageGhcOpts
+ StackageToHackage.Stackage.YAML: instance Data.YAML.FromYAML StackageToHackage.Stackage.Types.PkgId
+ StackageToHackage.Stackage.YAML: instance Data.YAML.FromYAML StackageToHackage.Stackage.Types.Resolver
+ StackageToHackage.Stackage.YAML: instance Data.YAML.FromYAML StackageToHackage.Stackage.Types.ResolverRef
+ StackageToHackage.Stackage.YAML: instance Data.YAML.FromYAML StackageToHackage.Stackage.Types.Stack
- StackageToHackage.Hackage: Freeze :: [PackageIdentifier] -> Flags -> Freeze
+ StackageToHackage.Hackage: Freeze :: [Constraint] -> Freeze
- StackageToHackage.Hackage: Project :: Ghc -> NonEmpty FilePath -> [Git] -> Project
+ StackageToHackage.Hackage: Project :: Ghc -> NonEmpty FilePath -> [Git] -> GhcOptions -> Project
- StackageToHackage.Hackage: printProject :: Project -> Maybe Text -> Text
+ StackageToHackage.Hackage: printProject :: Bool -> Maybe Elapsed -> Project -> Maybe Text -> IO Text
- StackageToHackage.Hackage: stackToCabal :: [PackageName] -> FilePath -> Stack -> IO (Project, Freeze)
+ StackageToHackage.Hackage: stackToCabal :: Bool -> Bool -> FilePath -> Stack -> IO (Project, Freeze)
Files
- exe/Main.hs +124/−52
- lib/StackageToHackage/Hackage.hs +285/−76
- lib/StackageToHackage/Hackage/Types.hs +38/−0
- lib/StackageToHackage/Hpack.hs +25/−0
- lib/StackageToHackage/Prelude.hs +7/−0
- lib/StackageToHackage/Stackage.hs +90/−202
- lib/StackageToHackage/Stackage/Types.hs +116/−0
- lib/StackageToHackage/Stackage/YAML.hs +131/−0
- stack2cabal.cabal +35/−18
exe/Main.hs view
@@ -1,66 +1,138 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE RecordWildCards #-} module Main where -import Control.Monad (filterM)-import Control.Monad.Extra (ifM)-import qualified Data.ByteString as BS-import qualified Data.List.NonEmpty as NEL-import Data.Maybe (mapMaybe)-import Data.Text (Text)-import qualified Data.Text as T-import Data.Text.Encoding (decodeUtf8, encodeUtf8)-import Distribution.Types.PackageName (mkPackageName)-import Hpack (Force(..), Options(..),- defaultOptions, hpackResult,- setTarget)-import Prelude hiding (lines)-import StackageToHackage.Hackage (printFreeze, printProject,- stackToCabal)-import StackageToHackage.Stackage (localDirs, readStack)-import System.Directory (doesDirectoryExist,- doesFileExist,- getCurrentDirectory,- listDirectory)-import System.FilePath (takeBaseName, takeExtension,- (</>))+import StackageToHackage.Hackage (printFreeze, printProject, stackToCabal)+import StackageToHackage.Hpack (hpackInput, execHpack)+import StackageToHackage.Stackage (localDirs, readStack) +import Control.Exception (throwIO)+import Control.Monad (filterM, when)+import Data.Dates.Parsing (parseDateTime, defaultConfigIO)+import Data.Foldable (traverse_)+import Data.Hourglass (timeConvert, Elapsed)+import Data.Maybe (mapMaybe)+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Options.Applicative+import Prelude hiding (lines)+import System.Directory (doesFileExist, makeAbsolute)+import System.FilePath (takeDirectory, (</>))++import qualified Data.ByteString as BS+import qualified Data.List.NonEmpty as NEL+import qualified Data.Text as T+++version :: String+#ifdef CURRENT_PACKAGE_VERSION+version = CURRENT_PACKAGE_VERSION+#else+version = "unknown"+#endif+++data Opts = Opts+ { input :: FilePath+ , output :: Maybe FilePath+ , inspectRemotes :: Bool+ , pinGHC :: Bool+ , runHpack :: Bool+ , hackageIndexDate :: Maybe String -- ^ fuzzy date string+ }+++optsP :: Parser Opts+optsP =+ Opts+ <$> strOption+ (short 'f'+ <> long "file"+ <> metavar "STACK_YAML"+ <> help "Path to stack.yaml file"+ <> value "stack.yaml"+ <> showDefaultWith show+ )+ <*> optional+ (strOption+ (short 'o'+ <> long "output-file"+ <> metavar "CABAL_PROJECT"+ <> help+ "Path to output file (default: <project-dir>/cabal.project)"+ <> showDefaultWith show+ )+ )+ <*> (not <$> switch+ (long "no-inspect-remotes"+ <> help+ "Don't check package names from remote git sources (this is faster, but may leave incorrect versions in cabal.project.freeze if remote packages overwrite stack resolver versions)"+ )+ )+ <*> (not <$> switch+ (long "no-pin-ghc" <> help "Don't pin the GHC version")+ )+ <*> (not <$> switch (long "no-run-hpack" <> help "Don't run hpack"))+ <*> optional+ (strOption+ (short 'p'+ <> long "pin-hackage-index"+ <> metavar "FUZZY_DATE"+ <> help "Pin hackage index state (values like \"now\" and \"yesterday\" work)"+ )+ )++ main :: IO () main = do- dir <- getCurrentDirectory- stack <- readStack =<< BS.readFile (dir </> "stack.yaml")- let subs = NEL.toList $ (dir </>) <$> localDirs stack- hpacks <- filterM (\d -> doesFileExist $ hpackInput d) $ subs- _ <- traverse runHpack hpacks- cabals <- concat <$> traverse (globExt ".cabal") subs- -- we could use the hpack output to figure out which cabal files to use, but- -- that misses projects that have explicit .cabal files, so just scan.- let ignore = (mkPackageName . takeBaseName) <$> cabals- (project, freeze) <- stackToCabal ignore dir stack- hack <- extractHack . decodeUtf8 <$> BS.readFile (dir </> "stack.yaml")- BS.writeFile (dir </> "cabal.project") (encodeUtf8 $ printProject project hack)- BS.writeFile (dir </> "cabal.project.freeze") (encodeUtf8 $ printFreeze freeze)- where- hpackInput sub = sub </> "package.yaml"- opts = defaultOptions {optionsForce = Force}- runHpack sub = hpackResult $ setTarget (hpackInput sub) opts+ let versionHelp = infoOption version (long "version" <> help "Show version" <> hidden) + customExecParser (prefs showHelpOnError) (info (optsP <**> helper <**> versionHelp) idm) >>= \Opts {..} -> do+ -- read stack file+ inDir <- makeAbsolute (takeDirectory input)+ stack <- readStack =<< BS.readFile input++ let subs = NEL.toList $ (inDir </>) <$> localDirs stack+ when runHpack $ do+ hpacks <-+ filterM (doesFileExist . hpackInput) subs+ traverse_ execHpack hpacks++ -- run conversion+ config <- defaultConfigIO+ let dt :: Maybe Elapsed+ dt = hackageIndexDate >>= \d -> fmap timeConvert+ $ either (const Nothing) Just+ $ parseDateTime config d+ case (hackageIndexDate, dt) of+ (Just d, Nothing) ->+ throwIO $ userError ("Warning: failed to convert hackage index state date \""+ <> d <> "\"")+ _ -> pure ()+ (project, freeze) <- stackToCabal inspectRemotes runHpack inDir stack+ hack <- extractHack . decodeUtf8 <$> BS.readFile+ (inDir </> "stack.yaml")+ printText <- printProject pinGHC dt project hack++ -- write files+ outFile <- case output of+ Just output' -> makeAbsolute output'+ Nothing -> pure (inDir </> "cabal.project")+ BS.writeFile outFile (encodeUtf8 printText)+ BS.writeFile+ (outFile <> ".freeze")+ (encodeUtf8 $ printFreeze freeze)++ -- Backdoor allowing the stack.yaml to contain arbitrary text that will be -- included in the cabal.project extractHack :: Text -> Maybe Text extractHack (T.split ('\n' ==) -> lines) =- let (_, region) = break (T.isPrefixOf "#+BEGIN_STACK2CABAL") lines- (hack, _) = break (T.isPrefixOf "#+END_STACK2CABAL") region- verbatim = mapMaybe (T.stripPrefix "# ") hack- in if null verbatim- then Nothing- else Just $ T.intercalate "\n" verbatim--globExt :: String -> FilePath -> IO [FilePath]-globExt ext path = do- files <- ifM (doesDirectoryExist path) (listDirectory path) (pure [])- pure $ filter ((ext ==) . takeExtension) files-+ let (_, region) = break (T.isPrefixOf "#+BEGIN_STACK2CABAL") lines+ (hack, _) = break (T.isPrefixOf "#+END_STACK2CABAL") region+ verbatim = mapMaybe (T.stripPrefix "# ") hack+ in if null verbatim then Nothing else Just $ T.intercalate "\n" verbatim
lib/StackageToHackage/Hackage.hs view
@@ -5,99 +5,308 @@ -- | A simplistic model of cabal multi-package files and convertors from Stackage. module StackageToHackage.Hackage- ( stackToCabal- , Project(..), printProject- , Freeze(..), printFreeze- ) where+ ( Freeze(..)+ , Project(..)+ , printFreeze+ , printProject+ , stackToCabal+ )+where -import Data.List (sort)-import Data.List.Extra (nubOrdOn)-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.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)+import StackageToHackage.Stackage ( localDirs, unroll )+import StackageToHackage.Stackage.Types+ ( Resolver(Resolver, compiler, deps, flags)+ , PkgId(unPkgId)+ , GhcFlags+ , GhcOptions(GhcOptions)+ , PackageGhcOpts(PackageGhcOpts)+ , Flags(..)+ , Dep(..)+ , Git(..)+ , Ghc(Ghc)+ , Stack(ghcOptions)+ )+import StackageToHackage.Hpack (hpackInput, execHpack)+import StackageToHackage.Hackage.Types+ ( Constraint(..), Freeze(..), Project(..) ) +import Control.Exception (throwIO)+import Control.Monad (forM, when, void)+import Control.Monad.Catch (handleIOError)+import Data.Hourglass (timePrint, ISO8601_DateAndTime(..), Elapsed)+import Data.List (nub, sort)+import Data.List.Extra (nubOrdOn)+import Data.List.NonEmpty (NonEmpty((:|)))+import Data.Maybe (fromMaybe, mapMaybe, catMaybes)+import Data.Semigroup ( Semigroup(sconcat) )+import Data.Text (Text)+import Distribution.PackageDescription.Parsec (readGenericPackageDescription)+import Distribution.Pretty (prettyShow)+import Distribution.Types.GenericPackageDescription+ (GenericPackageDescription(..))+import Distribution.Types.PackageDescription (PackageDescription(..))+import Distribution.Types.PackageId (PackageIdentifier(..))+import Distribution.Types.PackageName (PackageName, unPackageName)+import Distribution.Verbosity (silent)+import Safe (headMay)+import System.Exit (ExitCode(..))+import System.FilePath ((</>))+import System.FilePattern.Directory (getDirectoryFiles)+import System.IO (hPutStrLn, stderr)+import System.IO.Temp (withSystemTempDirectory)+import System.Process+ (withCreateProcess, proc, waitForProcess, StdStream(..), CreateProcess(..))++import qualified Data.List.NonEmpty as NEL+import qualified Data.Map.Strict as M+import qualified Data.Text as T+import System.Directory (doesFileExist)++ -- | 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)+stackToCabal :: Bool -- ^ whether to inspect remotes+ -> Bool -- ^ whether to run hpack+ -> FilePath+ -> Stack+ -> IO (Project, Freeze)+stackToCabal inspectRemotes runHpack dir stack = do+ resolvers <- unroll dir stack+ let resolver = sconcat resolvers+ project = genProject stack resolver+ localPkgs <-+ fmap catMaybes+ . traverse (\f -> getPackageIdent (dir </> f))+ . NEL.toList+ . pkgs+ $ project+ remotePkgs <- if inspectRemotes+ then getRemotePkgs (srcs project) runHpack+ else pure []+ let ignore = sort . nub . fmap pkgName $ (localPkgs ++ remotePkgs)+ let freeze = genFreeze resolver ignore+ pure (project, freeze) -printProject :: Project -> Maybe Text -> Text-printProject (Project (Ghc ghc) pkgs srcs) hack =- 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"- ] <> verbatim hack++printProject :: Bool -- ^ whether to pin GHC+ -> Maybe Elapsed -- ^ hackage index date to pin+ -> Project+ -> Maybe Text+ -> IO Text+printProject pinGHC indexDate (Project (Ghc ghc) pkgs srcs ghcOpts) hack = do+ ghcOpts' <- printGhcOpts ghcOpts+ pure $ T.concat+ $ ["-- Generated by stackage-to-hackage\n\n"]+ <> withHackageIndex+ <> withCompiler+ <> [ "packages:\n ", packages, "\n\n", sources+ , "\n", "allow-older: *\n", "allow-newer: *\n"+ ]+ <> ghcOpts'+ <> verbatim hack where+ withHackageIndex :: [Text]+ withHackageIndex+ | (Just utc) <- indexDate = ["index-state: ", printUTC utc, "\n\n"]+ | otherwise = []+ where+ printUTC :: Elapsed -> Text+ printUTC = T.pack . timePrint ISO8601_DateAndTime++ withCompiler :: [Text]+ withCompiler+ | pinGHC = ["with-compiler: ", ghc, "\n\n"]+ | otherwise = []++ verbatim :: Maybe Text -> [Text] verbatim Nothing = []- verbatim (Just txt) = ["\n-- Verbatim\n", txt]- packages = T.intercalate "\n , " (T.pack . addTrailingPathSeparator <$>- NEL.toList pkgs)+ verbatim (Just txt) = ["\n-- Verbatim\n", txt, "\n"]++ packages :: Text+ packages = T.intercalate "\n , " (T.pack . addTrailingPathSeparator' <$> NEL.toList pkgs)+ where+ addTrailingPathSeparator' :: FilePath -> FilePath+ addTrailingPathSeparator' x =+ if hasTrailingPathSeparator' x then x else x ++ ['/']++ hasTrailingPathSeparator' :: FilePath -> Bool+ hasTrailingPathSeparator' "" = False+ hasTrailingPathSeparator' x = last x == '/'++ sources :: Text 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)+ source :: Git -> [Text]+ 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 + -- Get the ghc options. This requires IO, because we have to figure out+ -- the local package names.+ printGhcOpts :: GhcOptions -> IO [GhcFlags]+ printGhcOpts (GhcOptions locals _ everything (PackageGhcOpts packagesGhcOpts)) = do+ -- locals are basically pkgs since cabal-install-3.4.0.0+ localsPrint <- case locals of+ Just x -> fmap concat $ forM pkgs $ \pkg -> do+ name <- fmap (unPackageName . pkgName)+ <$> getPackageIdent pkg+ pure $ maybe []+ (\n -> if M.member n $ M.mapKeys+ (unPackageName . pkgName . unPkgId)+ packagesGhcOpts+ then []+ else [ "\npackage ", T.pack n, "\n ", "ghc-options: ", x, "\n" ]+ )+ name+ Nothing -> pure []+ let everythingPrint = case everything of+ Just x -> ["\npackage ", "*", "\n ", "ghc-options: ", x, "\n"]+ Nothing -> []+ let pkgSpecificPrint = M.foldrWithKey+ (\k a b -> [ "\npackage ", T.pack . unPackageName . pkgName . unPkgId $ k+ , "\n "+ , "ghc-options: "+ , a+ , "\n"+ ]+ <> b) [] packagesGhcOpts+ pure (everythingPrint <> localsPrint <> pkgSpecificPrint)++ genProject :: Stack -> Resolver -> Project-genProject stack Resolver{compiler, deps} = Project- (fromMaybe (Ghc "ghc") compiler)- (localDirs stack)- (nubOrdOn repo $ mapMaybe pickGit deps)+genProject stack Resolver { compiler, deps } = Project+ (fromMaybe (Ghc "ghc") compiler)+ (localDirs stack `appendList` localDeps deps)+ (nubOrdOn repo $ mapMaybe pickGit deps)+ (ghcOptions stack) where- pickGit (Hackage _ ) = Nothing+ pickGit :: Dep -> Maybe Git+ pickGit (Hackage _) = Nothing+ pickGit (LocalDep _) = Nothing pickGit (SourceDep g) = Just g --- TODO if there is a dependency listed in the snapshot or LTS but the user--- provides a git repo or local package, we are generating the wrong version--- constraint. We would need to parse the .cabal of all git repos in the same--- way that we exclude self packages.+ localDeps :: [Dep] -> [FilePath]+ localDeps = mapMaybe fromLocalDeps++ fromLocalDeps :: Dep -> Maybe FilePath+ fromLocalDeps (Hackage _) = Nothing+ fromLocalDeps (SourceDep _) = Nothing+ fromLocalDeps (LocalDep d) = Just d++ appendList :: NonEmpty a -> [a] -> NonEmpty a+ appendList (x :| xs) ys = x :| (xs ++ ys)++ printFreeze :: Freeze -> Text-printFreeze (Freeze deps (Flags flags)) =- T.concat [ "constraints: ", constraints, "\n"]+printFreeze (Freeze constraints) = T.concat+ ["constraints: ", printConstraints, "\n"] where+ spacing :: Text spacing = ",\n "- constraints = T.intercalate spacing (constrait <$> sort deps)- constrait pkg =- let name = (T.pack . unPackageName . pkgName $ pkg)- ver = (T.pack . prettyShow . pkgVersion $ pkg)- base = T.concat ["any.", name, " ==", ver]- in case M.lookup name flags of- Nothing -> base- Just entries -> T.concat [name, " ", (custom entries), spacing, base]- custom (M.toList -> lst) = T.intercalate " " $ (renderFlag <$> lst)- renderFlag (name, True) = "+" <> name++ printConstraints :: Text+ printConstraints = T.intercalate spacing . fmap printConstraint $ constraints++ printConstraint :: Constraint -> Text+ printConstraint (VersionPin pkg) =+ let name = (T.pack . unPackageName . pkgName $ pkg)+ ver = (T.pack . prettyShow . pkgVersion $ pkg)+ in T.concat ["any.", name, " ==", ver]+ printConstraint (FlagSetting name flags)+ = T.concat [name, " ", custom flags]++ custom :: M.Map Text Bool -> Text+ custom (M.toList -> lst) = T.intercalate " " (renderFlag <$> lst)++ renderFlag :: (Text, Bool) -> Text+ 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 = nubOrdOn pkgName pkgs- in Freeze uniqpkgs flags- where pick (Hackage p) = Just p- pick (SourceDep _) = Nothing- noSelfs (pkgName -> n) = notElem n ignore+genFreeze :: Resolver+ -> [PackageName] -- ^ ignore these (local packages)+ -> Freeze+genFreeze Resolver { deps, flags } ignore =+ let pkgs = filter noSelfs $ unPkgId <$> mapMaybe pick deps+ uniqpkgs = nubOrdOn pkgName pkgs+ in Freeze (toConstraints uniqpkgs flags)+ where+ pick :: Dep -> Maybe PkgId+ pick (Hackage p) = Just p+ pick (SourceDep _) = Nothing+ pick (LocalDep _) = Nothing++ noSelfs :: PackageIdentifier -> Bool+ noSelfs (pkgName -> n) = n `notElem` ignore++ toConstraints :: [PackageIdentifier] -> Flags -> [Constraint]+ toConstraints deps' (Flags flags') =+ let cdeps = fmap VersionPin deps'+ cflags = M.elems $ M.mapWithKey FlagSetting flags'+ in sort (cdeps ++ cflags)+++-- | Acquire all package identifiers from a list of subdirs+-- of a git repository.+getRemotePkg :: Git -> Bool -> IO [PackageIdentifier]+getRemotePkg git@(Git (T.unpack -> repo) (T.unpack -> commit) (fmap T.unpack -> subdirs)) runHpack+ = withSystemTempDirectory "stack2cabal" $ \dir ->+ handleIOError+ (\_ -> hPutStrLn stderr+ ("Warning: failed to resolve remote .cabal files of: " <> show git)+ >> pure []+ ) $ do+ callProcess "git" ["clone", repo, dir]+ callProcess "git" ["-C", dir, "reset", "--hard", commit]+ case subdirs of+ [] -> do+ when runHpack $ do+ b <- doesFileExist (hpackInput dir)+ when b $ void $ execHpack dir+ (Just pid) <- getPackageIdent dir+ pure [pid]+ _ ->+ forM subdirs $ \subdir -> do+ let fullDir = dir </> subdir+ when runHpack $ do+ b <- doesFileExist (hpackInput fullDir)+ when b $ void $ execHpack fullDir+ (Just pid) <- getPackageIdent fullDir+ pure pid+ where+ callProcess :: FilePath -> [String] -> IO ()+ callProcess cmd args = do+ exit_code <- withCreateProcess (proc cmd args)+ { delegate_ctlc = True+ , std_out = UseHandle stderr+ } $ \_ _ _ p -> waitForProcess p+ case exit_code of+ ExitSuccess -> return ()+ ExitFailure r ->+ throwIO+ . userError+ $ ("Process \"" <> cmd <> "\" failed with: " <> show r)+++-- | Get package identifier from project directory.+getPackageIdent :: FilePath -- ^ absolute path to project repository+ -> IO (Maybe PackageIdentifier)+getPackageIdent dir =+ handleIOError+ (\_ -> hPutStrLn stderr ("Warning: failed to resolve .cabal file in " <> dir)+ >> pure Nothing+ ) $ do+ cabalFile <- headMay <$> getDirectoryFiles dir ["*.cabal"]+ forM cabalFile $ \f ->+ package . packageDescription+ <$> readGenericPackageDescription silent (dir </> f)+++-- | Get all remote VCS packages.+getRemotePkgs :: [Git] -> Bool -> IO [PackageIdentifier]+getRemotePkgs srcs runHpack = fmap concat $ forM srcs $ \src -> getRemotePkg src runHpack
+ lib/StackageToHackage/Hackage/Types.hs view
@@ -0,0 +1,38 @@+module StackageToHackage.Hackage.Types where++import StackageToHackage.Stackage.Types (Ghc, Git, GhcOptions, PkgName, FlagName)++import Data.List.NonEmpty (NonEmpty)+import Data.Map.Strict (Map)+import Distribution.Types.PackageId (PackageIdentifier(..))+import Distribution.Types.PackageName (unPackageName)++import qualified Data.Text as T+++data Project = Project+ { ghc :: Ghc+ , pkgs :: NonEmpty FilePath+ , srcs :: [Git]+ , ghcOpts :: GhcOptions+ } deriving (Show)+++newtype Freeze = Freeze [Constraint] deriving (Show)+++data Constraint = VersionPin PackageIdentifier+ | FlagSetting PkgName (Map FlagName Bool)+ deriving (Show, Eq)++instance Ord Constraint where+ compare (VersionPin pkg1) (VersionPin pkg2) = compare pkg1 pkg2+ compare (FlagSetting pkg1 _) (FlagSetting pkg2 _) = compare pkg1 pkg2+ compare (VersionPin pkg1) (FlagSetting pkg2 _) =+ case compare (T.pack . unPackageName . pkgName $ pkg1) pkg2 of+ EQ -> GT+ x -> x+ compare (FlagSetting pkg1 _) (VersionPin pkg2) =+ case compare pkg1 (T.pack . unPackageName . pkgName $ pkg2) of+ EQ -> LT+ x -> x
+ lib/StackageToHackage/Hpack.hs view
@@ -0,0 +1,25 @@+module StackageToHackage.Hpack (execHpack, hpackInput) where+++import Hpack+ ( defaultOptions+ , hpackResult+ , setTarget+ , Options(optionsForce)+ , Result+ , Force(Force)+ )+import System.FilePath ((</>))+import System.IO (hPutStrLn, stderr)+++hpackInput :: FilePath -> FilePath+hpackInput sub = sub </> "package.yaml"++opts :: Options+opts = defaultOptions { optionsForce = Force }++execHpack :: FilePath -> IO Result+execHpack sub = do+ hPutStrLn stderr ("Running hpack in: " <> sub)+ hpackResult $ setTarget (hpackInput sub) opts
+ lib/StackageToHackage/Prelude.hs view
@@ -0,0 +1,7 @@+module StackageToHackage.Prelude where++import Control.Applicative (Alternative, empty)+++hoistMaybe :: Alternative m => Maybe a -> m a+hoistMaybe = maybe empty pure
lib/StackageToHackage/Stackage.hs view
@@ -1,7 +1,5 @@-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} -- | Duplicates a subset of the Stack ADT. It'd be nice if we could just re-use@@ -9,244 +7,134 @@ -- 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, (</>))+import StackageToHackage.Stackage.Types+import StackageToHackage.Stackage.YAML () -data Stack = Stack- { resolver :: ResolverRef- , compiler :: Maybe Ghc- , packages :: [Package]- , extraDeps :: [Dep]- , flags :: Flags- -- TODO ghcOptions- } deriving (Show)+import Control.Applicative ((<|>))+import Control.Monad.Extra (loopM, unlessM)+import Data.ByteString.Lazy (toStrict)+import Data.List.NonEmpty (NonEmpty(..), head, nonEmpty, reverse, (<|))+import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)+import Data.Semigroup+import Data.Text (Text, replace, unpack, isPrefixOf)+import Data.YAML (FromYAML, decodeStrict)+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, (</>))+import System.IO (stderr, hPutStrLn) +import qualified Data.ByteString as BS++ localDirs :: Stack -> NonEmpty FilePath-localDirs Stack{packages} =- fromMaybe (pure ".") $ nonEmpty $ mapMaybe locals packages+localDirs Stack { packages } = fromMaybe (pure ".") $ nonEmpty $ mapMaybe+ locals+ packages where- locals (Local p) = Just p+ 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')))+ 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+ (_, 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"]+ 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+ manager <- getGlobalManager+ url <- parseRequest raw+ hPutStrLn stderr ("Downloading: " <> raw)+ resp <- httpLbs url manager+ pure $ toStrict $ responseBody resp - update file content = unlessM (doesFileExist file) (BS.writeFile file content)+ 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 (Just base) (Snapshot path)+ | isPrefixOf "http://" path || isPrefixOf "https://" path = parseFromURL+ | otherwise = parseFromFile+ where+ parseFromFile = do+ let file = base </> unpack path+ dir = takeDirectory file+ text <- BS.readFile file+ either fail (\r -> pure (Just dir, r)) $ decode1Strict text+ parseFromURL = do+ text <- download+ either fail (\r -> pure (Nothing, r)) $ decode1Strict text+ download = do+ manager <- getGlobalManager+ url <- parseRequest (unpack path)+ hPutStrLn stderr ("Downloading: " <> unpack path)+ resp <- httpLbs url manager+ pure $ toStrict $ responseBody resp 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)+ 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+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+new2old NewResolver { compiler, packages, flags } = Resolver+ Nothing+ (Just compiler)+ (new2old' <$> packages)+ flags+ where new2old' (NewDep pkg) = Hackage pkg ----------------------------------------------------------------------------------- YAML boilerplate+-- YAML -- 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+ as <- case decodeStrict text of+ Left e -> Left $ snd e+ Right a -> Right a+ maybe (Left "expected unique") Right $ listToMaybe as
+ lib/StackageToHackage/Stackage/Types.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module StackageToHackage.Stackage.Types where++import Control.Applicative ((<|>))+import Data.List.NonEmpty (NonEmpty(..))+import Data.Map.Strict (Map)+import Data.Semigroup+import Data.Text (Text)+import Distribution.Types.PackageId (PackageIdentifier(..))+import Prelude hiding (head, reverse, takeWhile)+++data Stack = Stack+ { resolver :: ResolverRef+ , compiler :: Maybe Ghc+ , packages :: [Package]+ , extraDeps :: [Dep]+ , flags :: Flags+ , ghcOptions :: GhcOptions+ } deriving (Show)+++newtype Ghc = Ghc Text+ deriving (Show)+++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+++-- 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+ | LocalDep FilePath+ deriving (Show)+++newtype Flags = Flags (Map PkgName (Map FlagName Bool))+ deriving (Show)+ deriving newtype (Semigroup)+++newtype PackageGhcOpts = PackageGhcOpts (Map PkgId GhcFlags)+ deriving (Show)+ deriving newtype (Semigroup, Monoid)+++data GhcOptions = GhcOptions+ { locals :: Maybe GhcFlags+ , targets :: Maybe GhcFlags -- cabal doesn't know about these+ , everything :: Maybe GhcFlags+ , packagesGhcOpts :: PackageGhcOpts+ } deriving (Show)++emptyGhcOptions :: GhcOptions+emptyGhcOptions = GhcOptions Nothing Nothing Nothing mempty++type PkgName = Text+type FlagName = Text+type GhcFlags = Text+++newtype NewDep = NewDep PkgId deriving (Show)+++newtype PkgId = PkgId { unPkgId :: PackageIdentifier } deriving (Show, Ord, Eq)++--------------------------------------------------------------------------------+-- Resolvers++-- 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 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)+++type RelativeResolvers = NonEmpty (Maybe FilePath, Resolver)+type Resolvers = NonEmpty Resolver
+ lib/StackageToHackage/Stackage/YAML.hs view
@@ -0,0 +1,131 @@+{-# OPTIONS_GHC -Wno-orphans #-}++{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}++module StackageToHackage.Stackage.YAML where++import StackageToHackage.Prelude+import StackageToHackage.Stackage.Types+++import Control.Applicative ((<|>))+import Data.Semigroup+import Data.Text (Text, isSuffixOf, takeWhile, unpack)+import Data.YAML+ ( FromYAML+ , Mapping+ , Node(..)+ , Parser+ , Pos(..)+ , Scalar(..)+ , parseYAML+ , withMap+ , withStr+ , (.!=)+ , (.:)+ , (.:?)+ )+import Distribution.Text (simpleParse)+import Prelude hiding (head, reverse, takeWhile)++import qualified Data.Map.Strict as M+++fakePos :: Pos+fakePos = Pos+ { posByteOffset = -1 , posCharOffset = -1 , posLine = 1 , posColumn = 0 }+++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+ <*> m .:? "ghc-options" .!= emptyGhcOptions++instance FromYAML GhcOptions where+ parseYAML = withMap "GhcOptions" $ \m -> do+ locals <- m .:? "$locals"+ targets <- m .:? "$targets"+ everything <- m .:? "$everything"+ packagesGhcOpts <- PackageGhcOpts <$>+ M.foldrWithKey (\k a action -> do+ m1 <- withStr "val" (\val -> do+ key <- parseYAML k+ pure (M.singleton key val)) a+ m2 <- action+ pure (m1 <> m2)+ ) (pure M.empty) (newMap m)+ pure $ GhcOptions{..}+ where+ newMap m =+ node "$everything" `M.delete`+ (node "$targets" `M.delete`+ (node "$locals" `M.delete` m))+ node = Scalar fakePos . SStr++instance FromYAML Git where+ parseYAML = withMap "Git" $ \m -> Git+ <$> m .: "git"+ <*> m .: "commit"+ <*> m .:? "subdirs" .!= []++instance FromYAML ResolverRef where+ parseYAML = withStr "ResolverRef" $ \s ->+ if ".yaml" `isSuffixOf` 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 <|> local+ where+ hackage = Hackage <$> parseYAML n+ source = SourceDep <$> parseYAML n+ local = LocalDep . unpack <$> 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 Pos -> (Text, Text) -> Parser a+ m1 ..: (k1, k2) =+ case M.lookup (Scalar fakePos (SStr k1)) m1 of+ Just (Mapping _ _ m2) -> m2 .: k2+ _ -> fail $ "key " ++ show k1 ++ " not found"++instance FromYAML PkgId where+ parseYAML = withStr "PackageIdentifier" $ \s ->+ PkgId <$> (hoistMaybe . simpleParse . unpack) (takeWhile ('@' /=) s)+++deriving instance FromYAML Ghc+deriving instance FromYAML PackageGhcOpts+deriving instance FromYAML Flags
stack2cabal.cabal view
@@ -1,20 +1,24 @@ cabal-version: 2.2 name: stack2cabal-version: 1.0.6+version: 1.0.11 synopsis: Convert stack projects to cabal.project + cabal.project.freeze -license: GPL-3.0-or-later+license: GPL-3.0-only 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+maintainer: Julian Ospald+copyright: 2018 Tseen She, 2020 Julian Ospald+bug-reports: https://github.com/hasufell/stack2cabal/issues+tested-with: GHC ^>=8.6.5 || ^>=8.8.4 || ^>=8.10.2 category: Building description: Convert @stack.yaml@ \/ @package.yaml@ to @cabal.project@ \/ @cabal.project.freeze@\/ @*.cabal@. +source-repository head+ type: git+ location: https://github.com/hasufell/stack2cabal.git+ -- https://www.haskell.org/cabal/users-guide/cabal-projectindex.html flag ghcflags@@ -24,25 +28,33 @@ common deps build-depends:- , base >=4.10 && <5.0+ , base >=4.10 && <5.0 , bytestring- , Cabal >=2.2 && <3.1+ , Cabal >=3.0 && <3.4 , containers , directory- , extra ^>=1.6.13+ , exceptions+ , extra >=1.6.13 , filepath- , hpack ^>=0.31.0 || ^>= 0.32.0 || ^>= 0.33.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+ , filepattern >=0.1.2+ , fuzzy-dates >=0.1.1.2+ , hourglass+ , hpack ==0.34.2+ , HsYAML ^>=0.2+ , http-client >=0.5.14+ , http-client-tls >=0.3.5.3+ , optparse-applicative >=0.15+ , process >=1.6.9.0+ , safe >=0.3+ , temporary >=1.3+ , text >=1.2.3.1 if flag(ghcflags)- build-tool-depends: hsinspect:hsinspect- build-depends: ghcflags- ghc-options: -fplugin GhcFlags.Plugin+ build-tool-depends: hsinspect:hsinspect -any+ build-depends: ghcflags+ ghc-options: -fplugin GhcFlags.Plugin - ghc-options: -Wall -Werror=missing-home-modules+ ghc-options: -Wall default-language: Haskell2010 executable stack2cabal@@ -59,4 +71,9 @@ -- cabal-fmt: expand lib exposed-modules: StackageToHackage.Hackage+ StackageToHackage.Hackage.Types+ StackageToHackage.Hpack+ StackageToHackage.Prelude StackageToHackage.Stackage+ StackageToHackage.Stackage.Types+ StackageToHackage.Stackage.YAML