{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeOperators       #-}

{-|
Module      : GHCup.Prelude
Description : MegaParsec utilities
Copyright   : (c) Julian Ospald, 2020
License     : LGPL-3.0
Maintainer  : hasufell@hasufell.de
Stability   : experimental
Portability : portable

GHCup specific prelude. Lots of Excepts functionality.
-}
module GHCup.Prelude
  (module GHCup.Prelude,
   module GHCup.Prelude.Internal,
#if defined(IS_WINDOWS)
   module GHCup.Prelude.Windows
#else
   module GHCup.Prelude.Posix
#endif
  )
where

import           GHCup.Errors
import           GHCup.Prelude.Internal
import           GHCup.Types.Optics   (HasLog)
import           GHCup.Prelude.Logger (logWarn)
#if defined(IS_WINDOWS)
import GHCup.Prelude.Windows
#else
import GHCup.Prelude.Posix
#endif

import           Control.Monad.IO.Class
import           Control.Monad.Reader
import           Haskus.Utils.Variant.Excepts
import           Text.PrettyPrint.HughesPJClass ( Pretty )
import qualified Data.Text                     as T
import System.Environment (getEnvironment)
import qualified Data.Map.Strict               as Map
import System.FilePath
import Data.List (intercalate)



-- for some obscure reason... this won't type-check if we move it to a different module
catchWarn :: forall es m env . ( Pretty (V es)
                             , HFErrorProject (V es)
                             , MonadReader env m
                             , HasLog env
                             , MonadIO m
                             , Monad m) => Excepts es m () -> Excepts '[] m ()
catchWarn :: forall (es :: [*]) (m :: * -> *) env.
(Pretty (V es), HFErrorProject (V es), MonadReader env m,
 HasLog env, MonadIO m, Monad m) =>
Excepts es m () -> Excepts '[] m ()
catchWarn = forall (m :: * -> *) (es :: [*]) (es' :: [*]) a.
Monad m =>
(V es -> Excepts es' m a) -> Excepts es m a -> Excepts es' m a
catchAllE @_ @es (\V es
v -> m () -> Excepts '[] m ()
forall (m :: * -> *) a. Monad m => m a -> Excepts '[] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Excepts '[] m ()) -> m () -> Excepts '[] m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
 LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logWarn (String -> Text
T.pack (String -> Text) -> (V es -> String) -> V es -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. V es -> String
forall e. (Pretty e, HFErrorProject e) => e -> String
prettyHFError (V es -> Text) -> V es -> Text
forall a b. (a -> b) -> a -> b
$ V es
v))


runBothE' :: forall e m a b .
             ( Monad m
             , Show (V e)
             , Pretty (V e)
             , HFErrorProject (V e)
             , PopVariant InstallSetError e
             , LiftVariant' e (InstallSetError ': e)
             , e :<< (InstallSetError ': e)
             )
          => Excepts e m a
          -> Excepts e m b
          -> Excepts (InstallSetError ': e) m ()
runBothE' :: forall (e :: [*]) (m :: * -> *) a b.
(Monad m, Show (V e), Pretty (V e), HFErrorProject (V e),
 PopVariant InstallSetError e, LiftVariant' e (InstallSetError : e),
 e :<< (InstallSetError : e)) =>
Excepts e m a
-> Excepts e m b -> Excepts (InstallSetError : e) m ()
runBothE' Excepts e m a
a1 Excepts e m b
a2 = do
   VEither e a
r1 <- m (VEither e a) -> Excepts (InstallSetError : e) m (VEither e a)
forall (m :: * -> *) a.
Monad m =>
m a -> Excepts (InstallSetError : e) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (VEither e a) -> Excepts (InstallSetError : e) m (VEither e a))
-> m (VEither e a) -> Excepts (InstallSetError : e) m (VEither e a)
forall a b. (a -> b) -> a -> b
$ forall (es :: [*]) a (m :: * -> *).
Excepts es m a -> m (VEither es a)
runE @e Excepts e m a
a1
   VEither e b
r2 <- m (VEither e b) -> Excepts (InstallSetError : e) m (VEither e b)
forall (m :: * -> *) a.
Monad m =>
m a -> Excepts (InstallSetError : e) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (VEither e b) -> Excepts (InstallSetError : e) m (VEither e b))
-> m (VEither e b) -> Excepts (InstallSetError : e) m (VEither e b)
forall a b. (a -> b) -> a -> b
$ forall (es :: [*]) a (m :: * -> *).
Excepts es m a -> m (VEither es a)
runE @e Excepts e m b
a2
   case (VEither e a
r1, VEither e b
r2) of
      (VLeft V e
e1, VLeft V e
e2) -> InstallSetError -> Excepts (InstallSetError : e) m ()
forall e (es :: [*]) a (m :: * -> *).
(Monad m, e :< es) =>
e -> Excepts es m a
throwE (V e -> V e -> InstallSetError
forall (xs1 :: [*]) (xs2 :: [*]).
(Show (V xs1), Pretty (V xs1), HFErrorProject (V xs1),
 Show (V xs2), Pretty (V xs2), HFErrorProject (V xs2)) =>
V xs1 -> V xs2 -> InstallSetError
InstallSetError V e
e1 V e
e2)
      (VLeft V e
e , VEither e b
_       ) -> V e -> Excepts (InstallSetError : e) m ()
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, LiftVariant es' es) =>
V es' -> Excepts es m a
throwSomeE V e
e
      (VEither e a
_       , VLeft V e
e ) -> V e -> Excepts (InstallSetError : e) m ()
forall (es' :: [*]) (es :: [*]) a (m :: * -> *).
(Monad m, LiftVariant es' es) =>
V es' -> Excepts es m a
throwSomeE V e
e
      (VRight a
_, VRight b
_) -> () -> Excepts (InstallSetError : e) m ()
forall a. a -> Excepts (InstallSetError : e) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- "throwSomeE" function has been upstreamed in haskus-utils-variant-3.3
-- So, only conditionally include this shim if
-- haskus-utils-variant version is < 3.3

#if MIN_VERSION_haskus_utils_variant(3,3,0)
#else
-- | Throw some exception
throwSomeE :: forall es' es a m. (Monad m, LiftVariant es' es) => V es' -> Excepts es m a
{-# INLINABLE throwSomeE #-}
throwSomeE = Excepts . pure . VLeft . liftVariant
#endif

addToPath :: [FilePath]
          -> Bool         -- ^ if False will prepend
          -> IO [(String, String)]
addToPath :: [String] -> Bool -> IO [(String, String)]
addToPath [String]
paths Bool
append = do
 [(String, String)]
cEnv <- IO [(String, String)]
getEnvironment
 [(String, String)] -> IO [(String, String)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, String)] -> IO [(String, String)])
-> [(String, String)] -> IO [(String, String)]
forall a b. (a -> b) -> a -> b
$ [(String, String)] -> [String] -> Bool -> [(String, String)]
addToPath' [(String, String)]
cEnv [String]
paths Bool
append

addToPath' :: [(String, String)]
          -> [FilePath]
          -> Bool         -- ^ if False will prepend
          -> [(String, String)]
addToPath' :: [(String, String)] -> [String] -> Bool -> [(String, String)]
addToPath' [(String, String)]
cEnv' [String]
newPaths Bool
append =
  let cEnv :: Map String String
cEnv           = [(String, String)] -> Map String String
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String, String)]
cEnv'
      paths :: [String]
paths          = [String
"PATH", String
"Path"]
      curPaths :: [String]
curPaths       = (\String
x -> [String] -> (String -> [String]) -> Maybe String -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] String -> [String]
splitSearchPath (String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
x Map String String
cEnv)) (String -> [String]) -> [String] -> [String]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [String]
paths
      {- HLINT ignore "Redundant bracket" -}
      newPath :: String
newPath        = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate [Char
searchPathSeparator] (if Bool
append then ([String]
curPaths [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
newPaths) else ([String]
newPaths [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
curPaths))
      envWithoutPath :: Map String String
envWithoutPath = (String -> Map String String -> Map String String)
-> Map String String -> [String] -> Map String String
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\String
x Map String String
y -> String -> Map String String -> Map String String
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete String
x Map String String
y) Map String String
cEnv [String]
paths
      pathVar :: String
pathVar        = if Bool
isWindows then String
"Path" else String
"PATH"
      envWithNewPath :: [(String, String)]
envWithNewPath = Map String String -> [(String, String)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map String String -> [(String, String)])
-> Map String String -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ String -> String -> Map String String -> Map String String
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
pathVar String
newPath Map String String
envWithoutPath
  in [(String, String)]
envWithNewPath