{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}

-- | A simplistic model of cabal multi-package files and convertors from Stackage.
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)


-- | Converts a stack.yaml (and list of local packages) to cabal.project and
-- cabal.project.freeze.
stackToCabal :: Bool     -- ^ whether to inspect remotes
             -> Bool     -- ^ whether to run hpack
             -> 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           -- ^ whether to pin GHC
             -> Maybe Elapsed  -- ^ hackage index date to pin
             -> 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"]]

    -- Get the ghc options. This requires IO, because we have to figure out
    -- the local package names.
    printGhcOpts :: GhcOptions -> IO [GhcFlags]
    printGhcOpts :: GhcOptions -> IO [Text]
printGhcOpts (GhcOptions Maybe Text
locals Maybe Text
_ Maybe Text
everything (PackageGhcOpts Map PkgId Text
packagesGhcOpts)) = do
        -- locals are basically pkgs since cabal-install-3.4.0.0
        [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]       -- ^ ignore these (local packages)
          -> 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)


-- | Acquire all package identifiers from a list of subdirs
-- of a git repository.
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)


-- | Get package identifier from project directory.
getPackageIdent :: FilePath  -- ^ absolute path to project repository
                -> 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)


-- | Get all remote VCS packages.
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