-- cabal-helper: Simple interface to Cabal's configuration state
-- Copyright (C) 2018  Daniel Gröber <cabal-helper@dxld.at>
--
-- SPDX-License-Identifier: Apache-2.0
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--     http://www.apache.org/licenses/LICENSE-2.0

{-|
Module      : CabalHelper.Compiletime.Program.Cabal
Description : Cabal library source unpacking
License     : Apache-2.0
-}

{-# LANGUAGE DeriveFunctor, ViewPatterns, OverloadedStrings #-}
{-# LANGUAGE CPP #-} -- for VERSION_Cabal

module CabalHelper.Compiletime.Cabal where

import Data.Char
import Control.Exception
import Data.List
import Data.Maybe
import Data.Time.Calendar
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.Version
import System.Directory
import System.FilePath
import System.IO
import Text.Printf

import Distribution.Verbosity (Verbosity, silent, normal, verbose, deafening)

import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8

import CabalHelper.Compiletime.Types
import CabalHelper.Compiletime.Types.Cabal
import CabalHelper.Compiletime.Process
import CabalHelper.Shared.Common (replace, parseVer, parseVerMay, parsePkgIdBS, panicIO)

data CabalPatchDescription = CabalPatchDescription
  { CabalPatchDescription -> [Version]
cpdVersions      :: [Version]
  , CabalPatchDescription -> UnpackCabalVariant
cpdUnpackVariant :: UnpackCabalVariant
  , CabalPatchDescription -> FilePath -> IO ()
cpdPatchFn       :: FilePath -> IO ()
  }

nopCabalPatchDescription :: CabalPatchDescription
nopCabalPatchDescription :: CabalPatchDescription
nopCabalPatchDescription =
  [Version]
-> UnpackCabalVariant
-> (FilePath -> IO ())
-> CabalPatchDescription
CabalPatchDescription [] UnpackCabalVariant
LatestRevision (IO () -> FilePath -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()))

patchyCabalVersions :: [CabalPatchDescription]
patchyCabalVersions :: [CabalPatchDescription]
patchyCabalVersions = [
  let versions :: [Version]
versions  = [ [Int] -> [FilePath] -> Version
Version [1,18,1] [] ]
      variant :: UnpackCabalVariant
variant   = UnpackCabalVariant
Pristine
      patch :: FilePath -> IO ()
patch     = FilePath -> IO ()
fixArrayConstraint
  in [Version]
-> UnpackCabalVariant
-> (FilePath -> IO ())
-> CabalPatchDescription
CabalPatchDescription [Version]
versions UnpackCabalVariant
variant FilePath -> IO ()
patch,

  let versions :: [Version]
versions  = [ [Int] -> [FilePath] -> Version
Version [1,18,0] [] ]
      variant :: UnpackCabalVariant
variant   = UnpackCabalVariant
Pristine
      patch :: FilePath -> IO ()
patch dir :: FilePath
dir = do
        FilePath -> IO ()
fixArrayConstraint FilePath
dir
        FilePath -> IO ()
fixOrphanInstance FilePath
dir
  in [Version]
-> UnpackCabalVariant
-> (FilePath -> IO ())
-> CabalPatchDescription
CabalPatchDescription [Version]
versions UnpackCabalVariant
variant FilePath -> IO ()
patch,

  let versions :: [Version]
versions  = [ [Int] -> [FilePath] -> Version
Version [1,24,1,0] [] ]
      variant :: UnpackCabalVariant
variant   = UnpackCabalVariant
Pristine
      patch :: p -> m ()
patch _   = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  in [Version]
-> UnpackCabalVariant
-> (FilePath -> IO ())
-> CabalPatchDescription
CabalPatchDescription [Version]
versions UnpackCabalVariant
variant FilePath -> IO ()
forall (m :: * -> *) p. Monad m => p -> m ()
patch
  ]
 where
   fixArrayConstraint :: FilePath -> IO ()
fixArrayConstraint dir :: FilePath
dir = do
     let cabalFile :: FilePath
cabalFile    = FilePath
dir FilePath -> FilePath -> FilePath
</> "Cabal.cabal"
         cabalFileTmp :: FilePath
cabalFileTmp = FilePath
cabalFile FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ".tmp"

     FilePath
cf <- FilePath -> IO FilePath
readFile FilePath
cabalFile
     FilePath -> FilePath -> IO ()
writeFile FilePath
cabalFileTmp (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> FilePath -> FilePath
replace "&& < 0.5" "&& < 0.6" FilePath
cf
     FilePath -> FilePath -> IO ()
renameFile FilePath
cabalFileTmp FilePath
cabalFile

   fixOrphanInstance :: FilePath -> IO ()
fixOrphanInstance dir :: FilePath
dir = do
     let versionFile :: FilePath
versionFile    = FilePath
dir FilePath -> FilePath -> FilePath
</> "Distribution/Version.hs"
         versionFileTmp :: FilePath
versionFileTmp = FilePath
versionFile FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ".tmp"

     let languagePragma :: FilePath
languagePragma =
           "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}"
         languagePragmaCPP :: FilePath
languagePragmaCPP =
           "{-# LANGUAGE CPP, DeriveDataTypeable, StandaloneDeriving #-}"

         derivingDataVersion :: FilePath
derivingDataVersion =
           "deriving instance Data Version"
         derivingDataVersionCPP :: FilePath
derivingDataVersionCPP = [FilePath] -> FilePath
unlines [
             "#if __GLASGOW_HASKELL__ < 707",
             FilePath
derivingDataVersion,
             "#endif"
           ]

     FilePath
vf <- FilePath -> IO FilePath
readFile FilePath
versionFile
     FilePath -> FilePath -> IO ()
writeFile FilePath
versionFileTmp
       (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> FilePath -> FilePath
replace FilePath
derivingDataVersion FilePath
derivingDataVersionCPP
       (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> FilePath -> FilePath
replace FilePath
languagePragma FilePath
languagePragmaCPP FilePath
vf

     FilePath -> FilePath -> IO ()
renameFile FilePath
versionFileTmp FilePath
versionFile

unpackPatchedCabal :: Env => Version -> FilePath -> IO CabalSourceDir
unpackPatchedCabal :: Version -> FilePath -> IO CabalSourceDir
unpackPatchedCabal cabalVer :: Version
cabalVer tmpdir :: FilePath
tmpdir = do
    res :: CabalSourceDir
res@(CabalSourceDir dir :: FilePath
dir) <- (Verbose, Progs) =>
Version -> FilePath -> UnpackCabalVariant -> IO CabalSourceDir
Version -> FilePath -> UnpackCabalVariant -> IO CabalSourceDir
unpackCabalHackage Version
cabalVer FilePath
tmpdir UnpackCabalVariant
variant
    FilePath -> IO ()
patch FilePath
dir
    CabalSourceDir -> IO CabalSourceDir
forall (m :: * -> *) a. Monad m => a -> m a
return CabalSourceDir
res
  where
    CabalPatchDescription _ variant :: UnpackCabalVariant
variant patch :: FilePath -> IO ()
patch = CabalPatchDescription
-> Maybe CabalPatchDescription -> CabalPatchDescription
forall a. a -> Maybe a -> a
fromMaybe CabalPatchDescription
nopCabalPatchDescription (Maybe CabalPatchDescription -> CabalPatchDescription)
-> Maybe CabalPatchDescription -> CabalPatchDescription
forall a b. (a -> b) -> a -> b
$
      (CabalPatchDescription -> Bool)
-> [CabalPatchDescription] -> Maybe CabalPatchDescription
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Version
cabalVer Version -> [Version] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) ([Version] -> Bool)
-> (CabalPatchDescription -> [Version])
-> CabalPatchDescription
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CabalPatchDescription -> [Version]
cpdVersions) [CabalPatchDescription]
patchyCabalVersions

-- legacy, for `installCabalLib` v1
unpackCabalV1
  :: Env
  => UnpackedCabalVersion
  -> FilePath
  -> IO CabalSourceDir
unpackCabalV1 :: UnpackedCabalVersion -> FilePath -> IO CabalSourceDir
unpackCabalV1 (CabalVersion ver :: Version
ver) tmpdir :: FilePath
tmpdir = do
  CabalSourceDir
csdir <- Env => Version -> FilePath -> IO CabalSourceDir
Version -> FilePath -> IO CabalSourceDir
unpackPatchedCabal Version
ver FilePath
tmpdir
  CabalSourceDir -> IO CabalSourceDir
forall (m :: * -> *) a. Monad m => a -> m a
return CabalSourceDir
csdir
unpackCabalV1 (CabalHEAD (_commit :: CommitId
_commit, csdir :: CabalSourceDir
csdir)) _tmpdir :: FilePath
_tmpdir =
  CabalSourceDir -> IO CabalSourceDir
forall (m :: * -> *) a. Monad m => a -> m a
return CabalSourceDir
csdir

unpackCabal :: Env => CabalVersion -> FilePath -> IO UnpackedCabalVersion
unpackCabal :: CabalVersion -> FilePath -> IO UnpackedCabalVersion
unpackCabal (CabalVersion ver :: Version
ver) _tmpdir :: FilePath
_tmpdir = do
  UnpackedCabalVersion -> IO UnpackedCabalVersion
forall (m :: * -> *) a. Monad m => a -> m a
return (UnpackedCabalVersion -> IO UnpackedCabalVersion)
-> UnpackedCabalVersion -> IO UnpackedCabalVersion
forall a b. (a -> b) -> a -> b
$ Version -> UnpackedCabalVersion
forall a. Version -> CabalVersion' a
CabalVersion Version
ver
unpackCabal (CabalHEAD ()) tmpdir :: FilePath
tmpdir = do
  (commit :: CommitId
commit, csdir :: CabalSourceDir
csdir) <- FilePath -> IO (CommitId, CabalSourceDir)
Env => FilePath -> IO (CommitId, CabalSourceDir)
unpackCabalHEAD FilePath
tmpdir
  UnpackedCabalVersion -> IO UnpackedCabalVersion
forall (m :: * -> *) a. Monad m => a -> m a
return (UnpackedCabalVersion -> IO UnpackedCabalVersion)
-> UnpackedCabalVersion -> IO UnpackedCabalVersion
forall a b. (a -> b) -> a -> b
$ (CommitId, CabalSourceDir) -> UnpackedCabalVersion
forall a. a -> CabalVersion' a
CabalHEAD (CommitId
commit, CabalSourceDir
csdir)

unpackCabalHackage
    :: (Verbose, Progs)
    => Version
    -> FilePath
    -> UnpackCabalVariant
    -> IO CabalSourceDir
unpackCabalHackage :: Version -> FilePath -> UnpackCabalVariant -> IO CabalSourceDir
unpackCabalHackage cabalVer :: Version
cabalVer tmpdir :: FilePath
tmpdir variant :: UnpackCabalVariant
variant = do
  let cabal :: FilePath
cabal = "Cabal-" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Version -> FilePath
showVersion Version
cabalVer
      dir :: FilePath
dir = FilePath
tmpdir FilePath -> FilePath -> FilePath
</> FilePath
cabal
      variant_opts :: [FilePath]
variant_opts = case UnpackCabalVariant
variant of Pristine -> [ "--pristine" ]; _ -> []
      args :: [FilePath]
args = [ "get", FilePath
cabal ] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
variant_opts
  Verbose =>
Maybe FilePath
-> [(FilePath, EnvOverride)] -> FilePath -> [FilePath] -> IO ()
Maybe FilePath
-> [(FilePath, EnvOverride)] -> FilePath -> [FilePath] -> IO ()
callProcessStderr (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
tmpdir) [] (Programs -> FilePath
cabalProgram Progs
Programs
?progs) [FilePath]
args
  CabalSourceDir -> IO CabalSourceDir
forall (m :: * -> *) a. Monad m => a -> m a
return (CabalSourceDir -> IO CabalSourceDir)
-> CabalSourceDir -> IO CabalSourceDir
forall a b. (a -> b) -> a -> b
$ FilePath -> CabalSourceDir
CabalSourceDir FilePath
dir

unpackCabalHEAD :: Env => FilePath -> IO (CommitId, CabalSourceDir)
unpackCabalHEAD :: FilePath -> IO (CommitId, CabalSourceDir)
unpackCabalHEAD tmpdir :: FilePath
tmpdir = do
  let dir :: FilePath
dir = FilePath
tmpdir FilePath -> FilePath -> FilePath
</> "cabal-head.git"
      url :: FilePath
url = "https://github.com/haskell/cabal.git"
  Verbose =>
Maybe FilePath
-> [(FilePath, EnvOverride)] -> FilePath -> [FilePath] -> IO ()
Maybe FilePath
-> [(FilePath, EnvOverride)] -> FilePath -> [FilePath] -> IO ()
callProcessStderr (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just "/") [] "git" [ "clone", "--depth=1", FilePath
url, FilePath
dir]
  Verbose =>
Maybe FilePath
-> [(FilePath, EnvOverride)] -> FilePath -> [FilePath] -> IO ()
Maybe FilePath
-> [(FilePath, EnvOverride)] -> FilePath -> [FilePath] -> IO ()
callProcessStderr (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath
dir FilePath -> FilePath -> FilePath
</> "Cabal")) [] "cabal"
    [ "act-as-setup", "--", "sdist"
    , "--output-directory=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
tmpdir FilePath -> FilePath -> FilePath
</> "Cabal" ]
  FilePath
commit <- (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isHexDigit (FilePath -> FilePath) -> IO FilePath -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    CreateProcess -> FilePath -> IO FilePath
readCreateProcess (FilePath -> [FilePath] -> CreateProcess
proc "git" ["rev-parse", "HEAD"]){ cwd :: Maybe FilePath
cwd = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
dir } ""
  FilePath
ts <-
    CreateProcess -> FilePath -> IO FilePath
readCreateProcess (FilePath -> [FilePath] -> CreateProcess
proc "git" [ "show", "-s", "--format=%ct", "HEAD" ])
      { cwd :: Maybe FilePath
cwd = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
dir } ""
  let ut :: UTCTime
ut = POSIXTime -> UTCTime
posixSecondsToUTCTime (POSIXTime -> UTCTime) -> POSIXTime -> UTCTime
forall a b. (a -> b) -> a -> b
$ Integer -> POSIXTime
forall a. Num a => Integer -> a
fromInteger (FilePath -> Integer
forall a. Read a => FilePath -> a
read FilePath
ts)
      (y :: Integer
y,m :: Int
m,d :: Int
d) = Day -> (Integer, Int, Int)
toGregorian (Day -> (Integer, Int, Int)) -> Day -> (Integer, Int, Int)
forall a b. (a -> b) -> a -> b
$ UTCTime -> Day
utctDay UTCTime
ut
      sec :: Int
sec = DiffTime -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (DiffTime -> Int) -> DiffTime -> Int
forall a b. (a -> b) -> a -> b
$ UTCTime -> DiffTime
utctDayTime UTCTime
ut; sec :: Int
      datecode :: Version
datecode = [Int] -> Version
makeVersion [1000, Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
y, Int
m, Int
d, Int
sec]
  let cabal_file :: FilePath
cabal_file = FilePath
tmpdir FilePath -> FilePath -> FilePath
</> "Cabal/Cabal.cabal"
  FilePath
cf0 <- FilePath -> IO FilePath
readFile FilePath
cabal_file
  let Just cf1 :: FilePath
cf1 = (Version -> Maybe Version) -> FilePath -> Maybe FilePath
replaceVersionDecl (Maybe Version -> Version -> Maybe Version
forall a b. a -> b -> a
const (Version -> Maybe Version
forall a. a -> Maybe a
Just Version
datecode)) FilePath
cf0
  FilePath -> FilePath -> IO ()
writeFile (FilePath
cabal_fileFilePath -> FilePath -> FilePath
<.>"tmp") FilePath
cf1
  FilePath -> FilePath -> IO ()
renameFile (FilePath
cabal_fileFilePath -> FilePath -> FilePath
<.>"tmp") FilePath
cabal_file
  (CommitId, CabalSourceDir) -> IO (CommitId, CabalSourceDir)
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> CommitId
CommitId FilePath
commit, FilePath -> CabalSourceDir
CabalSourceDir (FilePath -> CabalSourceDir) -> FilePath -> CabalSourceDir
forall a b. (a -> b) -> a -> b
$ FilePath
tmpdir FilePath -> FilePath -> FilePath
</> "Cabal")

-- | Replace the version declaration in a cabal file
replaceVersionDecl :: (Version -> Maybe Version) -> String -> Maybe String
replaceVersionDecl :: (Version -> Maybe Version) -> FilePath -> Maybe FilePath
replaceVersionDecl ver_fn :: Version -> Maybe Version
ver_fn cf :: FilePath
cf = let
  isVersionDecl :: (FilePath, FilePath) -> Bool
isVersionDecl ([],t :: FilePath
t) = "version:" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
t
  isVersionDecl (i :: FilePath
i,t :: FilePath
t) = "\n" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` FilePath
i Bool -> Bool -> Bool
&& "version:" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
t
  Just (before_ver :: FilePath
before_ver,m :: FilePath
m) = ((FilePath, FilePath) -> Bool)
-> [(FilePath, FilePath)] -> Maybe (FilePath, FilePath)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (FilePath, FilePath) -> Bool
isVersionDecl ([(FilePath, FilePath)] -> Maybe (FilePath, FilePath))
-> [(FilePath, FilePath)] -> Maybe (FilePath, FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> [(FilePath, FilePath)]
forall a. [a] -> [([a], [a])]
splits FilePath
cf
  Just (ver_decl :: FilePath
ver_decl,after_ver :: FilePath
after_ver)
    = ((FilePath, FilePath) -> Bool)
-> [(FilePath, FilePath)] -> Maybe (FilePath, FilePath)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\s :: (FilePath, FilePath)
s -> case (FilePath, FilePath)
s of (_i :: FilePath
_i,'\n':x :: Char
x:_) -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Char -> Bool
isSpace Char
x; _ -> Bool
False)
    ([(FilePath, FilePath)] -> Maybe (FilePath, FilePath))
-> [(FilePath, FilePath)] -> Maybe (FilePath, FilePath)
forall a b. (a -> b) -> a -> b
$ ((FilePath, FilePath) -> Bool)
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(_i :: FilePath
_i,t :: FilePath
t) -> "\n" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
t)
    ([(FilePath, FilePath)] -> [(FilePath, FilePath)])
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a b. (a -> b) -> a -> b
$ FilePath -> [(FilePath, FilePath)]
forall a. [a] -> [([a], [a])]
splits FilePath
m
  Just vers0 :: FilePath
vers0 = (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (FilePath -> FilePath) -> Maybe FilePath -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix "version:" FilePath
ver_decl
  (vers1 :: FilePath
vers1,rest :: FilePath
rest) = (Char -> Bool) -> FilePath -> (FilePath, FilePath)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (\c :: Char
c -> Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '.') FilePath
vers0
  Just verp :: Version
verp | (Char -> Bool) -> FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace FilePath
rest = FilePath -> Maybe Version
parseVerMay (FilePath -> Maybe Version) -> FilePath -> Maybe Version
forall a b. (a -> b) -> a -> b
$ FilePath
vers1 in do
  Version
new_ver <- Version -> Maybe Version
ver_fn Version
verp
  FilePath -> Maybe FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ FilePath
before_ver, "version: ", Version -> FilePath
showVersion Version
new_ver, FilePath
after_ver ]
  where
    splits :: [a] -> [([a], [a])]
splits xs :: [a]
xs = [a] -> [[a]]
forall a. [a] -> [[a]]
inits [a]
xs [[a]] -> [[a]] -> [([a], [a])]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [a] -> [[a]]
forall a. [a] -> [[a]]
tails [a]
xs

resolveCabalVersion :: Verbose => CabalVersion -> IO ResolvedCabalVersion
resolveCabalVersion :: CabalVersion -> IO ResolvedCabalVersion
resolveCabalVersion (CabalVersion ver :: Version
ver) = ResolvedCabalVersion -> IO ResolvedCabalVersion
forall (m :: * -> *) a. Monad m => a -> m a
return (ResolvedCabalVersion -> IO ResolvedCabalVersion)
-> ResolvedCabalVersion -> IO ResolvedCabalVersion
forall a b. (a -> b) -> a -> b
$ Version -> ResolvedCabalVersion
forall a. Version -> CabalVersion' a
CabalVersion Version
ver
resolveCabalVersion (CabalHEAD ()) = do
  FilePath
out <- Verbose => FilePath -> [FilePath] -> FilePath -> IO FilePath
FilePath -> [FilePath] -> FilePath -> IO FilePath
readProcess' "git"
    [ "ls-remote", "https://github.com/haskell/cabal.git", "-h", "master" ] ""
  let commit :: FilePath
commit = (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isHexDigit FilePath
out
  ResolvedCabalVersion -> IO ResolvedCabalVersion
forall (m :: * -> *) a. Monad m => a -> m a
return (ResolvedCabalVersion -> IO ResolvedCabalVersion)
-> ResolvedCabalVersion -> IO ResolvedCabalVersion
forall a b. (a -> b) -> a -> b
$ CommitId -> ResolvedCabalVersion
forall a. a -> CabalVersion' a
CabalHEAD (CommitId -> ResolvedCabalVersion)
-> CommitId -> ResolvedCabalVersion
forall a b. (a -> b) -> a -> b
$ FilePath -> CommitId
CommitId FilePath
commit

findCabalFile :: FilePath -> IO (Maybe FilePath)
findCabalFile :: FilePath -> IO (Maybe FilePath)
findCabalFile pkgdir :: FilePath
pkgdir = do
    [FilePath]
cfiles <- (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
isCabalFile ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [FilePath]
getDirectoryContents FilePath
pkgdir
    case [FilePath]
cfiles of
      [] -> Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing
      [cfile :: FilePath
cfile] -> Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FilePath -> IO (Maybe FilePath))
-> Maybe FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
pkgdir FilePath -> FilePath -> FilePath
</> FilePath
cfile
      _ -> FilePath -> IO (Maybe FilePath)
forall a. FilePath -> IO a
panicIO (FilePath -> IO (Maybe FilePath))
-> FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ "Multiple cabal-files found in directory '"
             FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
pkgdirFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++"': " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
forall a. Show a => a -> FilePath
show [FilePath]
cfiles
  where
    isCabalFile :: FilePath -> Bool
    isCabalFile :: FilePath -> Bool
isCabalFile f :: FilePath
f = FilePath -> FilePath
takeExtension' FilePath
f FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== ".cabal"

    takeExtension' :: FilePath -> String
    takeExtension' :: FilePath -> FilePath
takeExtension' p :: FilePath
p =
        if FilePath -> FilePath
takeFileName FilePath
p FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath -> FilePath
takeExtension FilePath
p
          then "" -- just ".cabal" is not a valid cabal file
          else FilePath -> FilePath
takeExtension FilePath
p

complainIfNoCabalFile :: FilePath -> Maybe FilePath -> IO FilePath
complainIfNoCabalFile :: FilePath -> Maybe FilePath -> IO FilePath
complainIfNoCabalFile _ (Just cabal_file :: FilePath
cabal_file) = FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
cabal_file
complainIfNoCabalFile pkgdir :: FilePath
pkgdir Nothing =
  FilePath -> IO FilePath
forall a. FilePath -> IO a
panicIO (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ "No cabal file found in package-dir: '"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
pkgdirFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++"'"

bultinCabalVersion :: CabalVersion
bultinCabalVersion :: CabalVersion
bultinCabalVersion = Version -> CabalVersion
forall a. Version -> CabalVersion' a
CabalVersion (Version -> CabalVersion) -> Version -> CabalVersion
forall a b. (a -> b) -> a -> b
$ FilePath -> Version
parseVer VERSION_Cabal

readSetupConfigHeader :: FilePath -> IO UnitHeader
readSetupConfigHeader :: FilePath -> IO UnitHeader
readSetupConfigHeader file :: FilePath
file = IO Handle
-> (Handle -> IO ()) -> (Handle -> IO UnitHeader) -> IO UnitHeader
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (FilePath -> IOMode -> IO Handle
openFile FilePath
file IOMode
ReadMode) Handle -> IO ()
hClose ((Handle -> IO UnitHeader) -> IO UnitHeader)
-> (Handle -> IO UnitHeader) -> IO UnitHeader
forall a b. (a -> b) -> a -> b
$ \h :: Handle
h -> do
  Maybe UnitHeader
mhdr <- ByteString -> Maybe UnitHeader
parseSetupHeader (ByteString -> Maybe UnitHeader)
-> IO ByteString -> IO (Maybe UnitHeader)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO ByteString
BS.hGetLine Handle
h
  case Maybe UnitHeader
mhdr of
    Just hdr :: UnitHeader
hdr@(UnitHeader _PkgId :: (ByteString, Version)
_PkgId ("Cabal", _hdrCabalVersion :: Version
_hdrCabalVersion) _compId :: (ByteString, Version)
_compId) -> do
      UnitHeader -> IO UnitHeader
forall (m :: * -> *) a. Monad m => a -> m a
return UnitHeader
hdr
    Just UnitHeader {uhSetupId :: UnitHeader -> (ByteString, Version)
uhSetupId=(setup_name :: ByteString
setup_name, _)} -> FilePath -> IO UnitHeader
forall a. FilePath -> IO a
panicIO (FilePath -> IO UnitHeader) -> FilePath -> IO UnitHeader
forall a b. (a -> b) -> a -> b
$
      FilePath -> FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf "Unknown Setup package-id in setup-config header '%s': '%s'"
        (ByteString -> FilePath
BS8.unpack ByteString
setup_name) FilePath
file
    Nothing -> FilePath -> IO UnitHeader
forall a. FilePath -> IO a
panicIO (FilePath -> IO UnitHeader) -> FilePath -> IO UnitHeader
forall a b. (a -> b) -> a -> b
$
      FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf "Could not read '%s' header" FilePath
file


parseSetupHeader :: BS.ByteString -> Maybe UnitHeader
parseSetupHeader :: ByteString -> Maybe UnitHeader
parseSetupHeader header :: ByteString
header = case ByteString -> [ByteString]
BS8.words ByteString
header of
  ["Saved", "package", "config", "for", pkgId :: ByteString
pkgId ,
   "written", "by", setupId :: ByteString
setupId,
   "using", compId :: ByteString
compId]
    -> (ByteString, Version)
-> (ByteString, Version) -> (ByteString, Version) -> UnitHeader
UnitHeader
       ((ByteString, Version)
 -> (ByteString, Version) -> (ByteString, Version) -> UnitHeader)
-> Maybe (ByteString, Version)
-> Maybe
     ((ByteString, Version) -> (ByteString, Version) -> UnitHeader)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe (ByteString, Version)
parsePkgIdBS ByteString
pkgId
       Maybe
  ((ByteString, Version) -> (ByteString, Version) -> UnitHeader)
-> Maybe (ByteString, Version)
-> Maybe ((ByteString, Version) -> UnitHeader)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ByteString -> Maybe (ByteString, Version)
parsePkgIdBS ByteString
setupId
       Maybe ((ByteString, Version) -> UnitHeader)
-> Maybe (ByteString, Version) -> Maybe UnitHeader
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ByteString -> Maybe (ByteString, Version)
parsePkgIdBS ByteString
compId
  _ -> Maybe UnitHeader
forall a. Maybe a
Nothing

getCabalVerbosity :: Verbose => Verbosity
getCabalVerbosity :: Verbosity
getCabalVerbosity
  | Verbose
Word -> Bool
?verbose 2 = Verbosity
normal
  | Verbose
Word -> Bool
?verbose 3 = Verbosity
verbose
  | Verbose
Word -> Bool
?verbose 4 = Verbosity
deafening
  | Bool
otherwise = Verbosity
silent