{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module StackageToHackage.Hackage
( Freeze(..)
, Project(..)
, printFreeze
, printProject
, stackToCabal
)
where
import StackageToHackage.Stackage ( localDirs, unroll, mergeResolvers )
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, sortOn)
import Data.List.Extra (nubOrd, nubOrdOn)
import Data.List.NonEmpty (NonEmpty((:|)))
import Data.Maybe (fromMaybe, mapMaybe, catMaybes)
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)
stackToCabal :: Bool
-> Bool
-> FilePath
-> Stack
-> IO (Project, Freeze)
stackToCabal :: Bool -> Bool -> FilePath -> Stack -> IO (Project, Freeze)
stackToCabal Bool
inspectRemotes Bool
runHpack FilePath
dir Stack
stack = do
Resolvers
resolvers <- FilePath -> Stack -> IO Resolvers
unroll FilePath
dir Stack
stack
let resolver :: Resolver
resolver = (Resolver -> Resolver -> Resolver) -> Resolvers -> Resolver
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Resolver -> Resolver -> Resolver
mergeResolvers Resolvers
resolvers
project :: Project
project = Stack -> Resolver -> Project
genProject Stack
stack Resolver
resolver
[PackageIdentifier]
localPkgs <-
([Maybe PackageIdentifier] -> [PackageIdentifier])
-> IO [Maybe PackageIdentifier] -> IO [PackageIdentifier]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe PackageIdentifier] -> [PackageIdentifier]
forall a. [Maybe a] -> [a]
catMaybes
(IO [Maybe PackageIdentifier] -> IO [PackageIdentifier])
-> (Project -> IO [Maybe PackageIdentifier])
-> Project
-> IO [PackageIdentifier]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> IO (Maybe PackageIdentifier))
-> [FilePath] -> IO [Maybe PackageIdentifier]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\FilePath
f -> FilePath -> IO (Maybe PackageIdentifier)
getPackageIdent (FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
f))
([FilePath] -> IO [Maybe PackageIdentifier])
-> (Project -> [FilePath])
-> Project
-> IO [Maybe PackageIdentifier]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty FilePath -> [FilePath]
forall a. NonEmpty a -> [a]
NEL.toList
(NonEmpty FilePath -> [FilePath])
-> (Project -> NonEmpty FilePath) -> Project -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Project -> NonEmpty FilePath
pkgs
(Project -> IO [PackageIdentifier])
-> Project -> IO [PackageIdentifier]
forall a b. (a -> b) -> a -> b
$ Project
project
[PackageIdentifier]
remotePkgs <- if Bool
inspectRemotes
then [Git] -> Bool -> IO [PackageIdentifier]
getRemotePkgs (Project -> [Git]
srcs Project
project) Bool
runHpack
else [PackageIdentifier] -> IO [PackageIdentifier]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
let ignore :: [PackageName]
ignore = [PackageName] -> [PackageName]
forall a. Ord a => [a] -> [a]
sort ([PackageName] -> [PackageName])
-> ([PackageIdentifier] -> [PackageName])
-> [PackageIdentifier]
-> [PackageName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PackageName] -> [PackageName]
forall a. Eq a => [a] -> [a]
nub ([PackageName] -> [PackageName])
-> ([PackageIdentifier] -> [PackageName])
-> [PackageIdentifier]
-> [PackageName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageIdentifier -> PackageName)
-> [PackageIdentifier] -> [PackageName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageIdentifier -> PackageName
pkgName ([PackageIdentifier] -> [PackageName])
-> [PackageIdentifier] -> [PackageName]
forall a b. (a -> b) -> a -> b
$ ([PackageIdentifier]
localPkgs [PackageIdentifier] -> [PackageIdentifier] -> [PackageIdentifier]
forall a. [a] -> [a] -> [a]
++ [PackageIdentifier]
remotePkgs)
let freeze :: Freeze
freeze = Resolver -> [PackageName] -> Freeze
genFreeze Resolver
resolver [PackageName]
ignore
(Project, Freeze) -> IO (Project, Freeze)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Project
project, Freeze
freeze)
printProject :: Bool
-> Maybe Elapsed
-> Project
-> Maybe Text
-> IO Text
printProject :: Bool -> Maybe Elapsed -> Project -> Maybe Text -> IO Text
printProject Bool
pinGHC Maybe Elapsed
indexDate (Project (Ghc Text
ghc) NonEmpty FilePath
pkgs [Git]
srcs GhcOptions
ghcOpts) Maybe Text
hack = do
[Text]
ghcOpts' <- GhcOptions -> IO [Text]
printGhcOpts GhcOptions
ghcOpts
Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text
"-- Generated by stack2cabal\n\n"]
[Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
withHackageIndex
[Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
withCompiler
[Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [ Text
"packages:\n ", Text
packages, Text
"\n\n", Text
sources
, Text
"\n", Text
"allow-older: *\n", Text
"allow-newer: *\n"
]
[Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
ghcOpts'
[Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> Maybe Text -> [Text]
verbatim Maybe Text
hack
where
withHackageIndex :: [Text]
withHackageIndex :: [Text]
withHackageIndex
| (Just Elapsed
utc) <- Maybe Elapsed
indexDate = [Text
"index-state: ", Elapsed -> Text
printUTC Elapsed
utc, Text
"\n\n"]
| Bool
otherwise = []
where
printUTC :: Elapsed -> Text
printUTC :: Elapsed -> Text
printUTC = FilePath -> Text
T.pack (FilePath -> Text) -> (Elapsed -> FilePath) -> Elapsed -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ISO8601_DateAndTime -> Elapsed -> FilePath
forall format t.
(TimeFormat format, Timeable t) =>
format -> t -> FilePath
timePrint ISO8601_DateAndTime
ISO8601_DateAndTime
withCompiler :: [Text]
withCompiler :: [Text]
withCompiler
| Bool
pinGHC = [Text
"with-compiler: ", Text
ghc, Text
"\n\n"]
| Bool
otherwise = []
verbatim :: Maybe Text -> [Text]
verbatim :: Maybe Text -> [Text]
verbatim Maybe Text
Nothing = []
verbatim (Just Text
txt) = [Text
"\n-- Verbatim\n", Text
txt, Text
"\n"]
packages :: Text
packages :: Text
packages = Text -> [Text] -> Text
T.intercalate Text
"\n , " (FilePath -> Text
T.pack (FilePath -> Text) -> (FilePath -> FilePath) -> FilePath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
addTrailingPathSeparator' (FilePath -> Text) -> [FilePath] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty FilePath -> [FilePath]
forall a. NonEmpty a -> [a]
NEL.toList NonEmpty FilePath
pkgs)
where
addTrailingPathSeparator' :: FilePath -> FilePath
addTrailingPathSeparator' :: FilePath -> FilePath
addTrailingPathSeparator' FilePath
x =
if FilePath -> Bool
hasTrailingPathSeparator' FilePath
x then FilePath
x else FilePath
x FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [Char
'/']
hasTrailingPathSeparator' :: FilePath -> Bool
hasTrailingPathSeparator' :: FilePath -> Bool
hasTrailingPathSeparator' FilePath
"" = Bool
False
hasTrailingPathSeparator' FilePath
x = FilePath -> Char
forall a. [a] -> a
last FilePath
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/'
sources :: Text
sources :: Text
sources = Text -> [Text] -> Text
T.intercalate Text
"\n" (Git -> [Text]
source (Git -> [Text]) -> [Git] -> [Text]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Git]
srcs)
source :: Git -> [Text]
source :: Git -> [Text]
source Git { Text
$sel:repo:Git :: Git -> Text
repo :: Text
repo, Text
$sel:commit:Git :: Git -> Text
commit :: Text
commit, [Text]
$sel:subdirs:Git :: Git -> [Text]
subdirs :: [Text]
subdirs } =
let base :: Text
base = [Text] -> Text
T.concat
[ Text
"source-repository-package\n ", Text
"type: git\n ", Text
"location: "
, Text
repo, Text
"\n ", Text
"tag: ", Text
commit, Text
"\n"
]
in case [Text] -> [Text]
forall a. Ord a => [a] -> [a]
sort [Text]
subdirs of
[] -> [Text
base]
(Text
x:[Text]
xs) -> [[Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text
base, Text
" subdir: ", Text
x]
[Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ ((Text
"\n " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
xs)
[Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
"\n"]]
printGhcOpts :: GhcOptions -> IO [GhcFlags]
printGhcOpts :: GhcOptions -> IO [Text]
printGhcOpts (GhcOptions Maybe Text
locals Maybe Text
_ Maybe Text
everything (PackageGhcOpts Map PkgId Text
packagesGhcOpts)) = do
[Text]
localsPrint <- case Maybe Text
locals of
Just Text
x -> (NonEmpty [Text] -> [Text]) -> IO (NonEmpty [Text]) -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty [Text] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO (NonEmpty [Text]) -> IO [Text])
-> IO (NonEmpty [Text]) -> IO [Text]
forall a b. (a -> b) -> a -> b
$ NonEmpty FilePath
-> (FilePath -> IO [Text]) -> IO (NonEmpty [Text])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM NonEmpty FilePath
pkgs ((FilePath -> IO [Text]) -> IO (NonEmpty [Text]))
-> (FilePath -> IO [Text]) -> IO (NonEmpty [Text])
forall a b. (a -> b) -> a -> b
$ \FilePath
pkg -> do
Maybe FilePath
name <- (PackageIdentifier -> FilePath)
-> Maybe PackageIdentifier -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PackageName -> FilePath
unPackageName (PackageName -> FilePath)
-> (PackageIdentifier -> PackageName)
-> PackageIdentifier
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> PackageName
pkgName)
(Maybe PackageIdentifier -> Maybe FilePath)
-> IO (Maybe PackageIdentifier) -> IO (Maybe FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Maybe PackageIdentifier)
getPackageIdent FilePath
pkg
[Text] -> IO [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text] -> IO [Text]) -> [Text] -> IO [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> (FilePath -> [Text]) -> Maybe FilePath -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe []
(\FilePath
n -> if FilePath -> Map FilePath Text -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member FilePath
n (Map FilePath Text -> Bool) -> Map FilePath Text -> Bool
forall a b. (a -> b) -> a -> b
$ (PkgId -> FilePath) -> Map PkgId Text -> Map FilePath Text
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys
(PackageName -> FilePath
unPackageName (PackageName -> FilePath)
-> (PkgId -> PackageName) -> PkgId -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> PackageName)
-> (PkgId -> PackageIdentifier) -> PkgId -> PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PkgId -> PackageIdentifier
unPkgId)
Map PkgId Text
packagesGhcOpts
then []
else [ Text
"\npackage ", FilePath -> Text
T.pack FilePath
n, Text
"\n ", Text
"ghc-options: ", Text
x, Text
"\n" ]
)
Maybe FilePath
name
Maybe Text
Nothing -> [Text] -> IO [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
let everythingPrint :: [Text]
everythingPrint = case Maybe Text
everything of
Just Text
x -> [Text
"\npackage ", Text
"*", Text
"\n ", Text
"ghc-options: ", Text
x, Text
"\n"]
Maybe Text
Nothing -> []
let pkgSpecificPrint :: [Text]
pkgSpecificPrint = (PkgId -> Text -> [Text] -> [Text])
-> [Text] -> Map PkgId Text -> [Text]
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
M.foldrWithKey
(\PkgId
k Text
a [Text]
b -> [ Text
"\npackage ", FilePath -> Text
T.pack (FilePath -> Text) -> (PkgId -> FilePath) -> PkgId -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> FilePath
unPackageName (PackageName -> FilePath)
-> (PkgId -> PackageName) -> PkgId -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> PackageName)
-> (PkgId -> PackageIdentifier) -> PkgId -> PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PkgId -> PackageIdentifier
unPkgId (PkgId -> Text) -> PkgId -> Text
forall a b. (a -> b) -> a -> b
$ PkgId
k
, Text
"\n "
, Text
"ghc-options: "
, Text
a
, Text
"\n"
]
[Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
b) [] Map PkgId Text
packagesGhcOpts
[Text] -> IO [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text]
everythingPrint [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
localsPrint [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
pkgSpecificPrint)
genProject :: Stack -> Resolver -> Project
genProject :: Stack -> Resolver -> Project
genProject Stack
stack Resolver { Maybe Ghc
compiler :: Maybe Ghc
$sel:compiler:Resolver :: Resolver -> Maybe Ghc
compiler, [Dep]
deps :: [Dep]
$sel:deps:Resolver :: Resolver -> [Dep]
deps } = Ghc -> NonEmpty FilePath -> [Git] -> GhcOptions -> Project
Project
(Ghc -> Maybe Ghc -> Ghc
forall a. a -> Maybe a -> a
fromMaybe (Text -> Ghc
Ghc Text
"ghc") Maybe Ghc
compiler)
(Stack -> NonEmpty FilePath
localDirs Stack
stack NonEmpty FilePath -> [FilePath] -> NonEmpty FilePath
forall a. NonEmpty a -> [a] -> NonEmpty a
`appendList` [Dep] -> [FilePath]
localDeps [Dep]
deps)
((Git -> Text) -> [Git] -> [Git]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn Git -> Text
repo ([Git] -> [Git]) -> [Git] -> [Git]
forall a b. (a -> b) -> a -> b
$ [Git] -> [Git]
forall a. Ord a => [a] -> [a]
nubOrd ([Git] -> [Git]) -> [Git] -> [Git]
forall a b. (a -> b) -> a -> b
$ (Dep -> Maybe Git) -> [Dep] -> [Git]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Dep -> Maybe Git
pickGit [Dep]
deps)
(Stack -> GhcOptions
ghcOptions Stack
stack)
where
pickGit :: Dep -> Maybe Git
pickGit :: Dep -> Maybe Git
pickGit (Hackage PkgId
_) = Maybe Git
forall a. Maybe a
Nothing
pickGit (LocalDep FilePath
_) = Maybe Git
forall a. Maybe a
Nothing
pickGit (SourceDep Git
g) = Git -> Maybe Git
forall a. a -> Maybe a
Just Git
g
localDeps :: [Dep] -> [FilePath]
localDeps :: [Dep] -> [FilePath]
localDeps = (Dep -> Maybe FilePath) -> [Dep] -> [FilePath]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Dep -> Maybe FilePath
fromLocalDeps
fromLocalDeps :: Dep -> Maybe FilePath
fromLocalDeps :: Dep -> Maybe FilePath
fromLocalDeps (Hackage PkgId
_) = Maybe FilePath
forall a. Maybe a
Nothing
fromLocalDeps (SourceDep Git
_) = Maybe FilePath
forall a. Maybe a
Nothing
fromLocalDeps (LocalDep FilePath
d) = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
d
appendList :: NonEmpty a -> [a] -> NonEmpty a
appendList :: NonEmpty a -> [a] -> NonEmpty a
appendList (a
x :| [a]
xs) [a]
ys = a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| ([a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
ys)
printFreeze :: Freeze -> Text
printFreeze :: Freeze -> Text
printFreeze (Freeze [Constraint]
constraints) = [Text] -> Text
T.concat
[Text
"constraints: ", Text
printConstraints, Text
"\n"]
where
spacing :: Text
spacing :: Text
spacing = Text
",\n "
printConstraints :: Text
printConstraints :: Text
printConstraints = Text -> [Text] -> Text
T.intercalate Text
spacing ([Text] -> Text)
-> ([Constraint] -> [Text]) -> [Constraint] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Constraint -> Text) -> [Constraint] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Constraint -> Text
printConstraint ([Constraint] -> Text) -> [Constraint] -> Text
forall a b. (a -> b) -> a -> b
$ [Constraint]
constraints
printConstraint :: Constraint -> Text
printConstraint :: Constraint -> Text
printConstraint (VersionPin PackageIdentifier
pkg) =
let name :: Text
name = (FilePath -> Text
T.pack (FilePath -> Text)
-> (PackageIdentifier -> FilePath) -> PackageIdentifier -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> FilePath
unPackageName (PackageName -> FilePath)
-> (PackageIdentifier -> PackageName)
-> PackageIdentifier
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> Text) -> PackageIdentifier -> Text
forall a b. (a -> b) -> a -> b
$ PackageIdentifier
pkg)
ver :: Text
ver = (FilePath -> Text
T.pack (FilePath -> Text)
-> (PackageIdentifier -> FilePath) -> PackageIdentifier -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (Version -> FilePath)
-> (PackageIdentifier -> Version) -> PackageIdentifier -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> Version
pkgVersion (PackageIdentifier -> Text) -> PackageIdentifier -> Text
forall a b. (a -> b) -> a -> b
$ PackageIdentifier
pkg)
in [Text] -> Text
T.concat [Text
"any.", Text
name, Text
" ==", Text
ver]
printConstraint (FlagSetting Text
name Map Text Bool
flags)
= [Text] -> Text
T.concat [Text
name, Text
" ", Map Text Bool -> Text
custom Map Text Bool
flags]
custom :: M.Map Text Bool -> Text
custom :: Map Text Bool -> Text
custom (Map Text Bool -> [(Text, Bool)]
forall k a. Map k a -> [(k, a)]
M.toList -> [(Text, Bool)]
lst) = Text -> [Text] -> Text
T.intercalate Text
" " ((Text, Bool) -> Text
renderFlag ((Text, Bool) -> Text) -> [(Text, Bool)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Bool)]
lst)
renderFlag :: (Text, Bool) -> Text
renderFlag :: (Text, Bool) -> Text
renderFlag (Text
name, Bool
True) = Text
"+" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
renderFlag (Text
name, Bool
False) = Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
genFreeze :: Resolver
-> [PackageName]
-> Freeze
genFreeze :: Resolver -> [PackageName] -> Freeze
genFreeze Resolver { [Dep]
deps :: [Dep]
$sel:deps:Resolver :: Resolver -> [Dep]
deps, Flags
flags :: Flags
$sel:flags:Resolver :: Resolver -> Flags
flags } [PackageName]
ignore =
let pkgs :: [PackageIdentifier]
pkgs = (PackageIdentifier -> Bool)
-> [PackageIdentifier] -> [PackageIdentifier]
forall a. (a -> Bool) -> [a] -> [a]
filter PackageIdentifier -> Bool
noSelfs ([PackageIdentifier] -> [PackageIdentifier])
-> [PackageIdentifier] -> [PackageIdentifier]
forall a b. (a -> b) -> a -> b
$ PkgId -> PackageIdentifier
unPkgId (PkgId -> PackageIdentifier) -> [PkgId] -> [PackageIdentifier]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Dep -> Maybe PkgId) -> [Dep] -> [PkgId]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Dep -> Maybe PkgId
pick [Dep]
deps
uniqpkgs :: [PackageIdentifier]
uniqpkgs = (PackageIdentifier -> PackageName)
-> [PackageIdentifier] -> [PackageIdentifier]
forall b a. Ord b => (a -> b) -> [a] -> [a]
nubOrdOn PackageIdentifier -> PackageName
pkgName [PackageIdentifier]
pkgs
in [Constraint] -> Freeze
Freeze ([PackageIdentifier] -> Flags -> [Constraint]
toConstraints [PackageIdentifier]
uniqpkgs Flags
flags)
where
pick :: Dep -> Maybe PkgId
pick :: Dep -> Maybe PkgId
pick (Hackage PkgId
p) = PkgId -> Maybe PkgId
forall a. a -> Maybe a
Just PkgId
p
pick (SourceDep Git
_) = Maybe PkgId
forall a. Maybe a
Nothing
pick (LocalDep FilePath
_) = Maybe PkgId
forall a. Maybe a
Nothing
noSelfs :: PackageIdentifier -> Bool
noSelfs :: PackageIdentifier -> Bool
noSelfs (PackageIdentifier -> PackageName
pkgName -> PackageName
n) = PackageName
n PackageName -> [PackageName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [PackageName]
ignore
toConstraints :: [PackageIdentifier] -> Flags -> [Constraint]
toConstraints :: [PackageIdentifier] -> Flags -> [Constraint]
toConstraints [PackageIdentifier]
deps' (Flags Map Text (Map Text Bool)
flags') =
let cdeps :: [Constraint]
cdeps = (PackageIdentifier -> Constraint)
-> [PackageIdentifier] -> [Constraint]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageIdentifier -> Constraint
VersionPin [PackageIdentifier]
deps'
cflags :: [Constraint]
cflags = Map Text Constraint -> [Constraint]
forall k a. Map k a -> [a]
M.elems (Map Text Constraint -> [Constraint])
-> Map Text Constraint -> [Constraint]
forall a b. (a -> b) -> a -> b
$ (Text -> Map Text Bool -> Constraint)
-> Map Text (Map Text Bool) -> Map Text Constraint
forall k a b. (k -> a -> b) -> Map k a -> Map k b
M.mapWithKey Text -> Map Text Bool -> Constraint
FlagSetting Map Text (Map Text Bool)
flags'
in [Constraint] -> [Constraint]
forall a. Ord a => [a] -> [a]
sort ([Constraint]
cdeps [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++ [Constraint]
cflags)
getRemotePkg :: Git -> Bool -> IO [PackageIdentifier]
getRemotePkg :: Git -> Bool -> IO [PackageIdentifier]
getRemotePkg git :: Git
git@(Git (Text -> FilePath
T.unpack -> FilePath
repo) (Text -> FilePath
T.unpack -> FilePath
commit) ((Text -> FilePath) -> [Text] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> FilePath
T.unpack -> [FilePath]
subdirs)) Bool
runHpack
= FilePath
-> (FilePath -> IO [PackageIdentifier]) -> IO [PackageIdentifier]
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> (FilePath -> m a) -> m a
withSystemTempDirectory FilePath
"stack2cabal" ((FilePath -> IO [PackageIdentifier]) -> IO [PackageIdentifier])
-> (FilePath -> IO [PackageIdentifier]) -> IO [PackageIdentifier]
forall a b. (a -> b) -> a -> b
$ \FilePath
dir ->
(IOError -> IO [PackageIdentifier])
-> IO [PackageIdentifier] -> IO [PackageIdentifier]
forall (m :: * -> *) a.
MonadCatch m =>
(IOError -> m a) -> m a -> m a
handleIOError
(\IOError
_ -> Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr
(FilePath
"Warning: failed to resolve remote .cabal files of: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Git -> FilePath
forall a. Show a => a -> FilePath
show Git
git)
IO () -> IO [PackageIdentifier] -> IO [PackageIdentifier]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [PackageIdentifier] -> IO [PackageIdentifier]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
) (IO [PackageIdentifier] -> IO [PackageIdentifier])
-> IO [PackageIdentifier] -> IO [PackageIdentifier]
forall a b. (a -> b) -> a -> b
$ do
FilePath -> [FilePath] -> IO ()
callProcess FilePath
"git" [FilePath
"clone", FilePath
repo, FilePath
dir]
FilePath -> [FilePath] -> IO ()
callProcess FilePath
"git" [FilePath
"-C", FilePath
dir, FilePath
"reset", FilePath
"--hard", FilePath
commit]
case [FilePath]
subdirs of
[] -> do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
runHpack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Bool
b <- FilePath -> IO Bool
doesFileExist (FilePath -> FilePath
hpackInput FilePath
dir)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO Result -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Result -> IO ()) -> IO Result -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Result
execHpack FilePath
dir
(Just PackageIdentifier
pid) <- FilePath -> IO (Maybe PackageIdentifier)
getPackageIdent FilePath
dir
[PackageIdentifier] -> IO [PackageIdentifier]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [PackageIdentifier
pid]
[FilePath]
_ ->
[FilePath]
-> (FilePath -> IO PackageIdentifier) -> IO [PackageIdentifier]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FilePath]
subdirs ((FilePath -> IO PackageIdentifier) -> IO [PackageIdentifier])
-> (FilePath -> IO PackageIdentifier) -> IO [PackageIdentifier]
forall a b. (a -> b) -> a -> b
$ \FilePath
subdir -> do
let fullDir :: FilePath
fullDir = FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
subdir
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
runHpack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Bool
b <- FilePath -> IO Bool
doesFileExist (FilePath -> FilePath
hpackInput FilePath
fullDir)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO Result -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Result -> IO ()) -> IO Result -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Result
execHpack FilePath
fullDir
(Just PackageIdentifier
pid) <- FilePath -> IO (Maybe PackageIdentifier)
getPackageIdent FilePath
fullDir
PackageIdentifier -> IO PackageIdentifier
forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageIdentifier
pid
where
callProcess :: FilePath -> [String] -> IO ()
callProcess :: FilePath -> [FilePath] -> IO ()
callProcess FilePath
cmd [FilePath]
args = do
ExitCode
exit_code <- CreateProcess
-> (Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ExitCode)
-> IO ExitCode
forall a.
CreateProcess
-> (Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess (FilePath -> [FilePath] -> CreateProcess
proc FilePath
cmd [FilePath]
args)
{ delegate_ctlc :: Bool
delegate_ctlc = Bool
True
, std_out :: StdStream
std_out = Handle -> StdStream
UseHandle Handle
stderr
} ((Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ExitCode)
-> IO ExitCode)
-> (Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ExitCode)
-> IO ExitCode
forall a b. (a -> b) -> a -> b
$ \Maybe Handle
_ Maybe Handle
_ Maybe Handle
_ ProcessHandle
p -> ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
p
case ExitCode
exit_code of
ExitCode
ExitSuccess -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
ExitFailure Int
r ->
IOError -> IO ()
forall e a. Exception e => e -> IO a
throwIO
(IOError -> IO ()) -> (FilePath -> IOError) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IOError
userError
(FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ (FilePath
"Process \"" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
cmd FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"\" failed with: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
r)
getPackageIdent :: FilePath
-> IO (Maybe PackageIdentifier)
getPackageIdent :: FilePath -> IO (Maybe PackageIdentifier)
getPackageIdent FilePath
dir =
(IOError -> IO (Maybe PackageIdentifier))
-> IO (Maybe PackageIdentifier) -> IO (Maybe PackageIdentifier)
forall (m :: * -> *) a.
MonadCatch m =>
(IOError -> m a) -> m a -> m a
handleIOError
(\IOError
_ -> Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath
"Warning: failed to resolve .cabal file in " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
dir)
IO ()
-> IO (Maybe PackageIdentifier) -> IO (Maybe PackageIdentifier)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe PackageIdentifier -> IO (Maybe PackageIdentifier)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe PackageIdentifier
forall a. Maybe a
Nothing
) (IO (Maybe PackageIdentifier) -> IO (Maybe PackageIdentifier))
-> IO (Maybe PackageIdentifier) -> IO (Maybe PackageIdentifier)
forall a b. (a -> b) -> a -> b
$ do
Maybe FilePath
cabalFile <- [FilePath] -> Maybe FilePath
forall a. [a] -> Maybe a
headMay ([FilePath] -> Maybe FilePath)
-> IO [FilePath] -> IO (Maybe FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> [FilePath] -> IO [FilePath]
getDirectoryFiles FilePath
dir [FilePath
"*.cabal"]
Maybe FilePath
-> (FilePath -> IO PackageIdentifier)
-> IO (Maybe PackageIdentifier)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe FilePath
cabalFile ((FilePath -> IO PackageIdentifier)
-> IO (Maybe PackageIdentifier))
-> (FilePath -> IO PackageIdentifier)
-> IO (Maybe PackageIdentifier)
forall a b. (a -> b) -> a -> b
$ \FilePath
f ->
PackageDescription -> PackageIdentifier
package (PackageDescription -> PackageIdentifier)
-> (GenericPackageDescription -> PackageDescription)
-> GenericPackageDescription
-> PackageIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericPackageDescription -> PackageDescription
packageDescription
(GenericPackageDescription -> PackageIdentifier)
-> IO GenericPackageDescription -> IO PackageIdentifier
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity -> FilePath -> IO GenericPackageDescription
readGenericPackageDescription Verbosity
silent (FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
f)
getRemotePkgs :: [Git] -> Bool -> IO [PackageIdentifier]
getRemotePkgs :: [Git] -> Bool -> IO [PackageIdentifier]
getRemotePkgs [Git]
srcs Bool
runHpack = ([[PackageIdentifier]] -> [PackageIdentifier])
-> IO [[PackageIdentifier]] -> IO [PackageIdentifier]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[PackageIdentifier]] -> [PackageIdentifier]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [[PackageIdentifier]] -> IO [PackageIdentifier])
-> IO [[PackageIdentifier]] -> IO [PackageIdentifier]
forall a b. (a -> b) -> a -> b
$ [Git]
-> (Git -> IO [PackageIdentifier]) -> IO [[PackageIdentifier]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Git]
srcs ((Git -> IO [PackageIdentifier]) -> IO [[PackageIdentifier]])
-> (Git -> IO [PackageIdentifier]) -> IO [[PackageIdentifier]]
forall a b. (a -> b) -> a -> b
$ \Git
src -> Git -> Bool -> IO [PackageIdentifier]
getRemotePkg Git
src Bool
runHpack