packages feed

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