ghcup-hs/lib/GHCup/Prelude.hs

117 lines
3.8 KiB
Haskell
Raw Permalink Normal View History

2022-05-21 20:54:18 +00:00
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
2022-05-23 21:32:58 +00:00
{-# LANGUAGE TypeOperators #-}
2022-05-21 20:54:18 +00:00
{-|
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
2022-05-23 21:32:58 +00:00
import GHCup.Errors
2022-05-21 20:54:18 +00:00
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 )
2022-05-21 20:54:18 +00:00
import qualified Data.Text as T
import System.Environment (getEnvironment)
import qualified Data.Map.Strict as Map
import System.FilePath
import Data.List (intercalate)
2022-05-21 20:54:18 +00:00
-- 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)
2022-05-21 20:54:18 +00:00
, MonadReader env m
, HasLog env
, MonadIO m
, Monad m) => Excepts es m () -> Excepts '[] m ()
catchWarn = catchAllE @_ @es (\v -> lift $ logWarn (T.pack . prettyHFError $ v))
2022-05-21 20:54:18 +00:00
2022-05-23 21:32:58 +00:00
runBothE' :: forall e m a b .
( Monad m
, Show (V e)
, Pretty (V e)
, HFErrorProject (V e)
2022-05-23 21:32:58 +00:00
, PopVariant InstallSetError e
, LiftVariant' e (InstallSetError ': e)
, e :<< (InstallSetError ': e)
)
=> Excepts e m a
-> Excepts e m b
-> Excepts (InstallSetError ': e) m ()
runBothE' a1 a2 = do
r1 <- lift $ runE @e a1
r2 <- lift $ runE @e a2
case (r1, r2) of
(VLeft e1, VLeft e2) -> throwE (InstallSetError e1 e2)
(VLeft e , _ ) -> throwSomeE e
(_ , VLeft e ) -> throwSomeE e
(VRight _, VRight _) -> 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
2022-05-23 21:32:58 +00:00
#if MIN_VERSION_haskus_utils_variant(3,3,0)
#else
2022-05-23 21:32:58 +00:00
-- | 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 paths append = do
cEnv <- getEnvironment
return $ addToPath' cEnv paths append
addToPath' :: [(String, String)]
-> [FilePath]
-> Bool -- ^ if False will prepend
-> [(String, String)]
addToPath' cEnv' newPaths append =
let cEnv = Map.fromList cEnv'
paths = ["PATH", "Path"]
curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
{- HLINT ignore "Redundant bracket" -}
newPath = intercalate [searchPathSeparator] (if append then (curPaths ++ newPaths) else (newPaths ++ curPaths))
envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths
pathVar = if isWindows then "Path" else "PATH"
envWithNewPath = Map.toList $ Map.insert pathVar newPath envWithoutPath
in envWithNewPath