{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Pantry.HPack
  ( hpack
  , hpackVersion
  ) where

import qualified Data.ByteString.Lazy.Char8 as BL
import           Data.Char ( isDigit, isSpace )
import qualified Hpack
import qualified Hpack.Config as Hpack
import           Pantry.Types
                   ( HasPantryConfig, HpackExecutable (..), PantryConfig (..)
                   , Version, pantryConfigL, parseVersionThrowing
                   )
import           Path
                   ( Abs, Dir, Path, (</>), filename, parseRelFile, toFilePath )
import           Path.IO ( doesFileExist )
import           RIO
import           RIO.Process
                   ( HasProcessContext, proc, readProcessStdout_, runProcess_
                   , withWorkingDir
                   )

hpackVersion ::
     (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => RIO env Version
hpackVersion :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RIO env Version
hpackVersion = do
  HpackExecutable
he <- Getting HpackExecutable env HpackExecutable
-> RIO env HpackExecutable
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting HpackExecutable env HpackExecutable
 -> RIO env HpackExecutable)
-> Getting HpackExecutable env HpackExecutable
-> RIO env HpackExecutable
forall a b. (a -> b) -> a -> b
$ (PantryConfig -> Const HpackExecutable PantryConfig)
-> env -> Const HpackExecutable env
forall env. HasPantryConfig env => Lens' env PantryConfig
Lens' env PantryConfig
pantryConfigL((PantryConfig -> Const HpackExecutable PantryConfig)
 -> env -> Const HpackExecutable env)
-> ((HpackExecutable -> Const HpackExecutable HpackExecutable)
    -> PantryConfig -> Const HpackExecutable PantryConfig)
-> Getting HpackExecutable env HpackExecutable
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PantryConfig -> HpackExecutable)
-> SimpleGetter PantryConfig HpackExecutable
forall s a. (s -> a) -> SimpleGetter s a
to PantryConfig -> HpackExecutable
pcHpackExecutable
  case HpackExecutable
he of
    HpackExecutable
HpackBundled -> do
      let String
bundledHpackVersion :: String = VERSION_hpack
      String -> RIO env Version
forall (m :: * -> *). MonadThrow m => String -> m Version
parseVersionThrowing String
bundledHpackVersion
    HpackCommand String
command -> do
      String
version <- ByteString -> String
BL.unpack (ByteString -> String) -> RIO env ByteString -> RIO env String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> [String]
-> (ProcessConfig () () () -> RIO env ByteString)
-> RIO env ByteString
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
String -> [String] -> (ProcessConfig () () () -> m a) -> m a
proc String
command [String
"--version"] ProcessConfig () () () -> RIO env ByteString
forall (m :: * -> *) stdin stdoutIgnored stderr.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderr -> m ByteString
readProcessStdout_
      let version' :: String
version' = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isDigit) String
version
          version'' :: String
version'' = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace) String
version'
      String -> RIO env Version
forall (m :: * -> *). MonadThrow m => String -> m Version
parseVersionThrowing String
version''

-- | Generate .cabal file from package.yaml, if necessary.

hpack ::
     (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => Path Abs Dir
  -> RIO env ()
hpack :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir -> RIO env ()
hpack Path Abs Dir
pkgDir = do
  Path Rel File
packageConfigRelFile <- String -> RIO env (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile String
Hpack.packageConfig
  let hpackFile :: Path Abs File
hpackFile = Path Abs Dir
pkgDir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
Path.</> Path Rel File
packageConfigRelFile
  RIO env Bool -> RIO env () -> RIO env ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
hpackFile) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
    Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Running hpack on " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
hpackFile)
    HpackExecutable
he <- Getting HpackExecutable env HpackExecutable
-> RIO env HpackExecutable
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting HpackExecutable env HpackExecutable
 -> RIO env HpackExecutable)
-> Getting HpackExecutable env HpackExecutable
-> RIO env HpackExecutable
forall a b. (a -> b) -> a -> b
$ (PantryConfig -> Const HpackExecutable PantryConfig)
-> env -> Const HpackExecutable env
forall env. HasPantryConfig env => Lens' env PantryConfig
Lens' env PantryConfig
pantryConfigL((PantryConfig -> Const HpackExecutable PantryConfig)
 -> env -> Const HpackExecutable env)
-> ((HpackExecutable -> Const HpackExecutable HpackExecutable)
    -> PantryConfig -> Const HpackExecutable PantryConfig)
-> Getting HpackExecutable env HpackExecutable
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PantryConfig -> HpackExecutable)
-> SimpleGetter PantryConfig HpackExecutable
forall s a. (s -> a) -> SimpleGetter s a
to PantryConfig -> HpackExecutable
pcHpackExecutable
    case HpackExecutable
he of
      HpackExecutable
HpackBundled -> do
        Result
r <- IO Result -> RIO env Result
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Result -> RIO env Result) -> IO Result -> RIO env Result
forall a b. (a -> b) -> a -> b
$ Options -> IO Result
Hpack.hpackResult (Options -> IO Result) -> Options -> IO Result
forall a b. (a -> b) -> a -> b
$ ProgramName -> Options -> Options
Hpack.setProgramName ProgramName
"stack" (Options -> Options) -> Options -> Options
forall a b. (a -> b) -> a -> b
$
          String -> Options -> Options
Hpack.setTarget (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
hpackFile) Options
Hpack.defaultOptions
        [String] -> (String -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Result -> [String]
Hpack.resultWarnings Result
r) (Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ())
-> (String -> Utf8Builder) -> String -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Utf8Builder
forall a. IsString a => String -> a
fromString)
        let cabalFile :: Utf8Builder
cabalFile = String -> Utf8Builder
forall a. IsString a => String -> a
fromString (String -> Utf8Builder)
-> (Result -> String) -> Result -> Utf8Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> String
Hpack.resultCabalFile (Result -> Utf8Builder) -> Result -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ Result
r
        case Result -> Status
Hpack.resultStatus Result
r of
          Status
Hpack.Generated -> Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
               Utf8Builder
"hpack generated a modified version of "
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
cabalFile
          Status
Hpack.OutputUnchanged -> Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
               Utf8Builder
"hpack output unchanged in "
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
cabalFile
          Status
Hpack.AlreadyGeneratedByNewerHpack -> Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
               Utf8Builder
cabalFile
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" was generated with a newer version of hpack. Ignoring "
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
hpackFile)
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" in favor of the Cabal file.\n"
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Either please upgrade and try again or, if you want to use the "
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path Rel File -> String
forall b t. Path b t -> String
toFilePath (Path Abs File -> Path Rel File
forall b. Path b File -> Path Rel File
filename Path Abs File
hpackFile))
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" file instead of the Cabal file,\n"
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"then please delete the Cabal file."
          Status
Hpack.ExistingCabalFileWasModifiedManually -> Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
               Utf8Builder
cabalFile
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" was modified manually. Ignoring "
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
hpackFile)
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" in favor of the Cabal file.\n"
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"If you want to use the "
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path Rel File -> String
forall b t. Path b t -> String
toFilePath (Path Abs File -> Path Rel File
forall b. Path b File -> Path Rel File
filename Path Abs File
hpackFile))
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" file instead of the Cabal file,\n"
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"then please delete the Cabal file."
      HpackCommand String
command ->
        String -> RIO env () -> RIO env ()
forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
String -> m a -> m a
withWorkingDir (Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
pkgDir) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
        String
-> [String] -> (ProcessConfig () () () -> RIO env ()) -> RIO env ()
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
String -> [String] -> (ProcessConfig () () () -> m a) -> m a
proc String
command [] ProcessConfig () () () -> RIO env ()
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_