Lala
This commit is contained in:
69
lib/GHCup/Utils/Bash.hs
Normal file
69
lib/GHCup/Utils/Bash.hs
Normal file
@@ -0,0 +1,69 @@
|
||||
module GHCup.Utils.Bash
|
||||
( findAssignment
|
||||
, equalsAssignmentWith
|
||||
, getRValue
|
||||
, getAssignmentValueFor
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad
|
||||
import Data.ByteString.UTF8 ( toString )
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import HPath
|
||||
import HPath.IO
|
||||
import Language.Bash.Parse
|
||||
import Language.Bash.Syntax
|
||||
import Language.Bash.Word
|
||||
import Prelude hiding ( readFile )
|
||||
|
||||
import qualified Data.ByteString.Lazy.UTF8 as UTF8
|
||||
|
||||
|
||||
extractAssignments :: List -> [Assign]
|
||||
extractAssignments (List stms) = join $ fmap getAssign $ getCommands stms
|
||||
where
|
||||
getCommands :: [Statement] -> [Command]
|
||||
getCommands = join . fmap commands . catMaybes . fmap findPipes
|
||||
where
|
||||
findPipes (Statement (Last p@(Pipeline{})) Sequential) = Just p
|
||||
findPipes _ = Nothing
|
||||
|
||||
getAssign :: Command -> [Assign]
|
||||
getAssign (Command (SimpleCommand ass _) _) = ass
|
||||
getAssign _ = []
|
||||
|
||||
|
||||
-- | Find an assignment matching the predicate in the given file.
|
||||
findAssignment :: Path b -> (Assign -> Bool) -> IO (Maybe Assign)
|
||||
findAssignment p predicate = do
|
||||
fileContents <- readFile p
|
||||
-- TODO: this should accept bytestring:
|
||||
-- https://github.com/knrafto/language-bash/issues/37
|
||||
case parse (toString . toFilePath $ p) (UTF8.toString fileContents) of
|
||||
Left e -> fail $ show e
|
||||
Right l -> pure $ find predicate (extractAssignments $ l)
|
||||
|
||||
|
||||
-- | Check that the assignment is of the form Foo= ignoring the
|
||||
-- right hand-side.
|
||||
equalsAssignmentWith :: String -> Assign -> Bool
|
||||
equalsAssignmentWith n ass = case ass of
|
||||
(Assign (Parameter name' Nothing) Equals _) -> n == name'
|
||||
_ -> False
|
||||
|
||||
|
||||
-- | This pretty-prints the right hand of an Equals assignment, removing
|
||||
-- quotations. No evaluation is performed.
|
||||
getRValue :: Assign -> Maybe String
|
||||
getRValue ass = case ass of
|
||||
(Assign (Parameter _ _) Equals (RValue w)) -> Just $ unquote w
|
||||
_ -> Nothing
|
||||
|
||||
|
||||
-- | Given a bash assignment such as Foo="Bar" in the given file,
|
||||
-- will return "Bar" (without quotations).
|
||||
getAssignmentValueFor :: Path b -> String -> IO (Maybe String)
|
||||
getAssignmentValueFor p n = do
|
||||
mass <- findAssignment p (equalsAssignmentWith n)
|
||||
pure (mass >>= getRValue)
|
||||
244
lib/GHCup/Utils/File.hs
Normal file
244
lib/GHCup/Utils/File.hs
Normal file
@@ -0,0 +1,244 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module GHCup.Utils.File where
|
||||
|
||||
import GHCup.Utils.Prelude
|
||||
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Resource
|
||||
import Data.ByteString
|
||||
import Data.ByteString.Unsafe ( unsafeUseAsCStringLen )
|
||||
import Data.Char
|
||||
import Data.Foldable
|
||||
import Data.Functor
|
||||
import Data.Maybe
|
||||
import Data.String.QQ
|
||||
import GHC.Foreign ( peekCStringLen )
|
||||
import GHC.IO.Encoding ( getLocaleEncoding )
|
||||
import GHC.IO.Exception
|
||||
import HPath
|
||||
import HPath.IO
|
||||
import Optics
|
||||
import Streamly
|
||||
import Streamly.External.ByteString
|
||||
import Streamly.External.ByteString.Lazy
|
||||
import System.IO
|
||||
import System.Posix.Directory.ByteString
|
||||
import System.Posix.Env.ByteString
|
||||
import System.Posix.FD as FD
|
||||
import System.Posix.FilePath hiding ( (</>) )
|
||||
import System.Posix.Foreign ( oExcl )
|
||||
import "unix" System.Posix.IO.ByteString
|
||||
hiding ( openFd )
|
||||
import System.Posix.Process ( ProcessStatus(..) )
|
||||
import System.Posix.Temp.ByteString
|
||||
import System.Posix.Types
|
||||
|
||||
|
||||
import qualified System.Posix.Process.ByteString
|
||||
as SPPB
|
||||
import qualified System.Posix.FilePath as FP
|
||||
import qualified System.Posix.User as PU
|
||||
import Streamly.External.Posix.DirStream
|
||||
import qualified Streamly.Internal.Memory.ArrayStream
|
||||
as AS
|
||||
import qualified Streamly.FileSystem.Handle as FH
|
||||
import qualified Streamly.Internal.Data.Unfold as SU
|
||||
import qualified Streamly.Prelude as S
|
||||
import qualified Data.ByteString.UTF8 as UTF8
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
|
||||
|
||||
data ProcessError = NonZeroExit Int ByteString [ByteString]
|
||||
| PTerminated ByteString [ByteString]
|
||||
| PStopped ByteString [ByteString]
|
||||
| NoSuchPid ByteString [ByteString]
|
||||
deriving Show
|
||||
|
||||
|
||||
data CapturedProcess = CapturedProcess
|
||||
{ _exitCode :: ExitCode
|
||||
, _stdOut :: ByteString
|
||||
, _stdErr :: ByteString
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
makeLenses ''CapturedProcess
|
||||
|
||||
|
||||
readFd :: Fd -> IO L.ByteString
|
||||
readFd fd = do
|
||||
handle' <- fdToHandle fd
|
||||
fromChunksIO $ (S.unfold (SU.finallyIO hClose FH.readChunks) handle')
|
||||
|
||||
|
||||
-- | Read the lines of a file into a stream. The stream holds
|
||||
-- a file handle as a resource and will close it once the stream
|
||||
-- terminates (either through exception or because it's drained).
|
||||
readFileLines :: Path b -> IO (SerialT IO ByteString)
|
||||
readFileLines p = do
|
||||
stream <- readFileStream p
|
||||
pure
|
||||
. (fmap fromArray)
|
||||
. AS.splitOn (fromIntegral $ ord '\n')
|
||||
. (fmap toArray)
|
||||
$ stream
|
||||
|
||||
|
||||
-- | Find the given executable by searching all *absolute* PATH components.
|
||||
-- Relative paths in PATH are ignored.
|
||||
--
|
||||
-- This shouldn't throw IO exceptions, unless getting the environment variable
|
||||
-- PATH does.
|
||||
findExecutable :: Path Rel -> IO (Maybe (Path Abs))
|
||||
findExecutable ex = do
|
||||
sPaths <- fmap catMaybes . (fmap . fmap) parseAbs $ getSearchPath
|
||||
-- We don't want exceptions to mess up our result. If we can't
|
||||
-- figure out if a file exists, then treat it as a negative result.
|
||||
asum $ fmap (handleIO (\_ -> pure Nothing)) $ fmap
|
||||
-- asum for short-circuiting behavior
|
||||
(\s' -> (isExecutable (s' </> ex) >>= guard) $> (Just (s' </> ex)))
|
||||
sPaths
|
||||
|
||||
|
||||
-- | Execute the given command and collect the stdout, stderr and the exit code.
|
||||
-- The command is run in a subprocess.
|
||||
executeOut :: Path b -- ^ command as filename, e.g. 'ls'
|
||||
-> [ByteString] -- ^ arguments to the command
|
||||
-> Maybe (Path Abs) -- ^ chdir to this path
|
||||
-> IO CapturedProcess
|
||||
executeOut path args chdir = captureOutStreams $ do
|
||||
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
|
||||
SPPB.executeFile (toFilePath path) True args Nothing
|
||||
|
||||
|
||||
-- | Capture the stdout and stderr of the given action, which
|
||||
-- is run in a subprocess. Stdin is closed. You might want to
|
||||
-- 'race' this to make sure it terminates.
|
||||
captureOutStreams :: IO a
|
||||
-- ^ the action to execute in a subprocess
|
||||
-> IO CapturedProcess
|
||||
captureOutStreams action =
|
||||
actionWithPipes $ \(parentStdoutRead, childStdoutWrite) ->
|
||||
actionWithPipes $ \(parentStderrRead, childStderrWrite) -> do
|
||||
pid <- SPPB.forkProcess $ do
|
||||
-- dup stdout
|
||||
void $ dupTo childStdoutWrite stdOutput
|
||||
closeFd childStdoutWrite
|
||||
closeFd parentStdoutRead
|
||||
|
||||
-- dup stderr
|
||||
void $ dupTo childStderrWrite stdError
|
||||
closeFd childStderrWrite
|
||||
closeFd parentStderrRead
|
||||
|
||||
-- execute the action
|
||||
void $ action
|
||||
|
||||
-- close everything we don't need
|
||||
closeFd childStdoutWrite
|
||||
closeFd childStderrWrite
|
||||
|
||||
SPPB.getProcessStatus True True pid >>= \case
|
||||
-- readFd will take care of closing the fd
|
||||
Just (SPPB.Exited es) -> do
|
||||
stdout' <- L.toStrict <$> readFd parentStdoutRead
|
||||
stderr' <- L.toStrict <$> readFd parentStderrRead
|
||||
pure $ CapturedProcess { _exitCode = es
|
||||
, _stdOut = stdout'
|
||||
, _stdErr = stderr'
|
||||
}
|
||||
_ -> throwIO $ userError $ ("No such PID " ++ show pid)
|
||||
|
||||
where
|
||||
actionWithPipes a =
|
||||
createPipe >>= \(p1, p2) -> (flip finally) (cleanup [p1, p2]) $ a (p1, p2)
|
||||
cleanup fds = for_ fds $ \fd -> handleIO (\_ -> pure ()) $ closeFd fd
|
||||
|
||||
|
||||
|
||||
-- | Create a new regular file in write-only mode. The file must not exist.
|
||||
createRegularFileFd :: FileMode -> Path b -> IO Fd
|
||||
createRegularFileFd fm dest =
|
||||
FD.openFd (toFilePath dest) WriteOnly [oExcl] (Just fm)
|
||||
|
||||
|
||||
-- | Thin wrapper around `executeFile`.
|
||||
exec :: ByteString -- ^ thing to execute
|
||||
-> Bool -- ^ whether to search PATH for the thing
|
||||
-> [ByteString] -- ^ args for the thing
|
||||
-> Maybe (Path Abs) -- ^ optionally chdir into this
|
||||
-> Maybe [(ByteString, ByteString)] -- ^ optional environment
|
||||
-> IO (Either ProcessError ())
|
||||
exec exe spath args chdir env = do
|
||||
pid <- SPPB.forkProcess $ do
|
||||
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
|
||||
SPPB.executeFile exe spath args env
|
||||
|
||||
fmap (toProcessError exe args) $ SPPB.getProcessStatus True True pid
|
||||
|
||||
|
||||
toProcessError :: ByteString
|
||||
-> [ByteString]
|
||||
-> Maybe ProcessStatus
|
||||
-> Either ProcessError ()
|
||||
toProcessError exe args mps = case mps of
|
||||
Just (SPPB.Exited (ExitFailure i)) -> Left $ NonZeroExit i exe args
|
||||
Just (SPPB.Exited ExitSuccess ) -> Right ()
|
||||
Just (Terminated _ _ ) -> Left $ PTerminated exe args
|
||||
Just (Stopped _ ) -> Left $ PStopped exe args
|
||||
Nothing -> Left $ NoSuchPid exe args
|
||||
|
||||
|
||||
mkGhcupTmpDir :: (MonadThrow m, MonadIO m) => m (Path Abs)
|
||||
mkGhcupTmpDir = do
|
||||
tmpdir <- liftIO $ getEnvDefault [s|TMPDIR|] [s|/tmp|]
|
||||
tmp <- liftIO $ mkdtemp $ (tmpdir FP.</> [s|ghcup-|])
|
||||
parseAbs tmp
|
||||
|
||||
|
||||
withGHCupTmpDir :: (MonadResource m, MonadThrow m, MonadIO m) => m (Path Abs)
|
||||
withGHCupTmpDir = snd <$> allocate mkGhcupTmpDir deleteDirRecursive
|
||||
|
||||
|
||||
getHomeDirectory :: IO (Path Abs)
|
||||
getHomeDirectory = do
|
||||
e <- getEnv [s|HOME|]
|
||||
case e of
|
||||
Just fp -> parseAbs fp
|
||||
Nothing -> do
|
||||
h <- PU.homeDirectory <$> (PU.getEffectiveUserID >>= PU.getUserEntryForID)
|
||||
parseAbs $ UTF8.fromString h -- this is a guess
|
||||
|
||||
|
||||
-- | Convert the String to a ByteString with the current
|
||||
-- system encoding.
|
||||
unsafePathToString :: Path b -> IO FilePath
|
||||
unsafePathToString (Path p) = do
|
||||
enc <- getLocaleEncoding
|
||||
unsafeUseAsCStringLen p (peekCStringLen enc)
|
||||
|
||||
|
||||
-- | Search for a file in the search paths.
|
||||
--
|
||||
-- Catches `PermissionDenied` and `NoSuchThing` and returns `Nothing`.
|
||||
searchPath :: [Path Abs] -> Path Rel -> IO (Maybe (Path Abs))
|
||||
searchPath paths needle = go paths
|
||||
where
|
||||
go [] = pure Nothing
|
||||
go (x : xs) =
|
||||
hideErrorDefM PermissionDenied (go xs)
|
||||
$ hideErrorDefM NoSuchThing (go xs)
|
||||
$ do
|
||||
dirStream <- openDirStream (toFilePath x)
|
||||
S.findM (\(_, p) -> isMatch x p) (dirContentsStream dirStream)
|
||||
>>= \case
|
||||
Just _ -> pure $ Just (x </> needle)
|
||||
Nothing -> go xs
|
||||
isMatch basedir p = do
|
||||
if p == toFilePath needle
|
||||
then isExecutable (basedir </> needle)
|
||||
else pure False
|
||||
28
lib/GHCup/Utils/Logger.hs
Normal file
28
lib/GHCup/Utils/Logger.hs
Normal file
@@ -0,0 +1,28 @@
|
||||
module GHCup.Utils.Logger where
|
||||
|
||||
|
||||
import Control.Monad.Logger
|
||||
import System.Console.Pretty
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
|
||||
|
||||
data LoggerConfig = LoggerConfig {
|
||||
lcPrintDebug :: Bool
|
||||
, outter :: B.ByteString -> IO ()
|
||||
}
|
||||
|
||||
|
||||
myLoggerT :: LoggerConfig -> LoggingT m a -> m a
|
||||
myLoggerT LoggerConfig{..} loggingt = runLoggingT loggingt mylogger
|
||||
where
|
||||
mylogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
|
||||
mylogger _ _ level str' = do
|
||||
let l = case level of
|
||||
LevelDebug -> if lcPrintDebug then toLogStr (style Bold $ color Blue "[ Debug ]") else mempty
|
||||
LevelInfo -> toLogStr (style Bold $ color Green "[ Info ]")
|
||||
LevelWarn -> toLogStr (style Bold $ color Yellow "[ Warn ]")
|
||||
LevelError -> toLogStr (style Bold $ color Red "[ Error ]")
|
||||
LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]"
|
||||
let out = fromLogStr (l <> toLogStr " " <> str' <> toLogStr "\n")
|
||||
outter out
|
||||
263
lib/GHCup/Utils/Prelude.hs
Normal file
263
lib/GHCup/Utils/Prelude.hs
Normal file
@@ -0,0 +1,263 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE DeriveLift #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module GHCup.Utils.Prelude where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Class ( lift )
|
||||
import Data.Bifunctor
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.Monoid ( (<>) )
|
||||
import Data.String
|
||||
import Data.Text ( Text )
|
||||
import Data.Versions
|
||||
import GHC.Base
|
||||
import Haskus.Utils.Types.List
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Quote ( QuasiQuoter(..) )
|
||||
import Language.Haskell.TH.Syntax ( Exp(..)
|
||||
, Lift
|
||||
)
|
||||
import System.IO.Error
|
||||
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.Strict.Maybe as S
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import qualified Data.Text.Lazy.Builder as B
|
||||
import qualified Data.Text.Lazy.Builder.Int as B
|
||||
import qualified Data.Text.Lazy.Encoding as TLE
|
||||
import qualified Language.Haskell.TH.Syntax as TH
|
||||
|
||||
|
||||
|
||||
fS :: IsString a => String -> a
|
||||
fS = fromString
|
||||
|
||||
fromStrictMaybe :: S.Maybe a -> Maybe a
|
||||
fromStrictMaybe = S.maybe Nothing Just
|
||||
|
||||
fSM :: S.Maybe a -> Maybe a
|
||||
fSM = fromStrictMaybe
|
||||
|
||||
toStrictMaybe :: Maybe a -> S.Maybe a
|
||||
toStrictMaybe = maybe S.Nothing S.Just
|
||||
|
||||
tSM :: Maybe a -> S.Maybe a
|
||||
tSM = toStrictMaybe
|
||||
|
||||
internalError :: String -> IO a
|
||||
internalError = fail . ("Internal error: " <>)
|
||||
|
||||
iE :: String -> IO a
|
||||
iE = internalError
|
||||
|
||||
|
||||
showT :: Show a => a -> Text
|
||||
showT = fS . show
|
||||
|
||||
-- | Like 'when', but where the test can be monadic.
|
||||
whenM :: Monad m => m Bool -> m () -> m ()
|
||||
whenM ~b ~t = ifM b t (return ())
|
||||
|
||||
-- | Like 'unless', but where the test can be monadic.
|
||||
unlessM :: Monad m => m Bool -> m () -> m ()
|
||||
unlessM ~b ~f = ifM b (return ()) f
|
||||
|
||||
-- | Like @if@, but where the test can be monadic.
|
||||
ifM :: Monad m => m Bool -> m a -> m a -> m a
|
||||
ifM ~b ~t ~f = do
|
||||
b' <- b
|
||||
if b' then t else f
|
||||
|
||||
whileM :: Monad m => m a -> (a -> m Bool) -> m a
|
||||
whileM ~action ~f = do
|
||||
a <- action
|
||||
b' <- f a
|
||||
if b' then whileM action f else pure a
|
||||
|
||||
whileM_ :: Monad m => m a -> (a -> m Bool) -> m ()
|
||||
whileM_ ~action = void . whileM action
|
||||
|
||||
guardM :: (Monad m, Alternative m) => m Bool -> m ()
|
||||
guardM ~f = guard =<< f
|
||||
|
||||
lBS2sT :: L.ByteString -> Text
|
||||
lBS2sT = TL.toStrict . TLE.decodeUtf8
|
||||
|
||||
|
||||
|
||||
handleIO' :: (MonadIO m, MonadCatch m)
|
||||
=> IOErrorType
|
||||
-> (IOException -> m a)
|
||||
-> m a
|
||||
-> m a
|
||||
handleIO' err handler = handleIO
|
||||
(\e -> if err == ioeGetErrorType e then handler e else liftIO $ ioError e)
|
||||
|
||||
|
||||
(??) :: forall e es a m . (Monad m, e :< es) => Maybe a -> e -> Excepts es m a
|
||||
(??) m e = maybe (throwE e) pure m
|
||||
|
||||
|
||||
(!?) :: forall e es a m
|
||||
. (Monad m, e :< es)
|
||||
=> m (Maybe a)
|
||||
-> e
|
||||
-> Excepts es m a
|
||||
(!?) em e = lift em >>= (?? e)
|
||||
|
||||
|
||||
lE :: forall e es a m . (Monad m, e :< es) => Either e a -> Excepts es m a
|
||||
lE = liftE . veitherToExcepts . fromEither
|
||||
|
||||
lE' :: forall e' e es a m
|
||||
. (Monad m, e :< es)
|
||||
=> (e' -> e)
|
||||
-> Either e' a
|
||||
-> Excepts es m a
|
||||
lE' f = liftE . veitherToExcepts . fromEither . bimap f id
|
||||
|
||||
lEM :: forall e es a m . (Monad m, e :< es) => m (Either e a) -> Excepts es m a
|
||||
lEM em = lift em >>= lE
|
||||
|
||||
lEM' :: forall e' e es a m
|
||||
. (Monad m, e :< es)
|
||||
=> (e' -> e)
|
||||
-> m (Either e' a)
|
||||
-> Excepts es m a
|
||||
lEM' f em = lift em >>= lE . bimap f id
|
||||
|
||||
fromEither :: Either a b -> VEither '[a] b
|
||||
fromEither = either (VLeft . V) VRight
|
||||
|
||||
|
||||
liftException :: ( MonadCatch m
|
||||
, MonadIO m
|
||||
, Monad m
|
||||
, e :< es'
|
||||
, LiftVariant es es'
|
||||
)
|
||||
=> IOErrorType
|
||||
-> e
|
||||
-> Excepts es m a
|
||||
-> Excepts es' m a
|
||||
liftException errType ex =
|
||||
handleIO
|
||||
(\e ->
|
||||
if errType == ioeGetErrorType e then throwE ex else liftIO $ ioError e
|
||||
)
|
||||
. liftE
|
||||
|
||||
|
||||
hideErrorDef :: IOErrorType -> a -> IO a -> IO a
|
||||
hideErrorDef err def =
|
||||
handleIO (\e -> if err == ioeGetErrorType e then pure def else ioError e)
|
||||
|
||||
|
||||
hideErrorDefM :: IOErrorType -> IO a -> IO a -> IO a
|
||||
hideErrorDefM err def =
|
||||
handleIO (\e -> if err == ioeGetErrorType e then def else ioError e)
|
||||
|
||||
|
||||
-- TODO: does this work?
|
||||
hideExcept :: forall e es es' a m
|
||||
. (Monad m, e :< es, LiftVariant (Remove e es) es')
|
||||
=> e
|
||||
-> a
|
||||
-> Excepts es m a
|
||||
-> Excepts es' m a
|
||||
hideExcept _ a action =
|
||||
catchLiftLeft ((\_ -> pure a) :: (e -> Excepts es' m a)) action
|
||||
|
||||
hideExcept' :: forall e es es' m
|
||||
. (Monad m, e :< es, LiftVariant (Remove e es) es')
|
||||
=> e
|
||||
-> Excepts es m ()
|
||||
-> Excepts es' m ()
|
||||
hideExcept' _ action =
|
||||
catchLiftLeft ((\_ -> pure ()) :: (e -> Excepts es' m ())) action
|
||||
|
||||
|
||||
|
||||
throwEither :: (Exception a, MonadThrow m) => Either a b -> m b
|
||||
throwEither a = case a of
|
||||
Left e -> throwM e
|
||||
Right r -> pure r
|
||||
|
||||
|
||||
|
||||
deriving instance Lift Versioning
|
||||
deriving instance Lift Version
|
||||
deriving instance Lift SemVer
|
||||
deriving instance Lift Mess
|
||||
deriving instance Lift PVP
|
||||
deriving instance Lift (NonEmpty Word)
|
||||
deriving instance Lift VSep
|
||||
deriving instance Lift VUnit
|
||||
instance Lift Text
|
||||
|
||||
qq :: (Text -> Q Exp) -> QuasiQuoter
|
||||
qq quoteExp' = QuasiQuoter
|
||||
{ quoteExp = (\s -> quoteExp' . T.pack $ s)
|
||||
, quotePat = \_ ->
|
||||
fail "illegal QuasiQuote (allowed as expression only, used as a pattern)"
|
||||
, quoteType = \_ ->
|
||||
fail "illegal QuasiQuote (allowed as expression only, used as a type)"
|
||||
, quoteDec = \_ -> fail
|
||||
"illegal QuasiQuote (allowed as expression only, used as a declaration)"
|
||||
}
|
||||
|
||||
vver :: QuasiQuoter
|
||||
vver = qq mkV
|
||||
where
|
||||
mkV :: Text -> Q Exp
|
||||
mkV = either (fail . show) TH.lift . version
|
||||
|
||||
mver :: QuasiQuoter
|
||||
mver = qq mkV
|
||||
where
|
||||
mkV :: Text -> Q Exp
|
||||
mkV = either (fail . show) TH.lift . mess
|
||||
|
||||
sver :: QuasiQuoter
|
||||
sver = qq mkV
|
||||
where
|
||||
mkV :: Text -> Q Exp
|
||||
mkV = either (fail . show) TH.lift . semver
|
||||
|
||||
vers :: QuasiQuoter
|
||||
vers = qq mkV
|
||||
where
|
||||
mkV :: Text -> Q Exp
|
||||
mkV = either (fail . show) TH.lift . versioning
|
||||
|
||||
pver :: QuasiQuoter
|
||||
pver = qq mkV
|
||||
where
|
||||
mkV :: Text -> Q Exp
|
||||
mkV = either (fail . show) TH.lift . pvp
|
||||
|
||||
|
||||
verToBS :: Version -> ByteString
|
||||
verToBS = E.encodeUtf8 . prettyVer
|
||||
|
||||
|
||||
|
||||
intToText :: Integral a => a -> T.Text
|
||||
intToText = TL.toStrict . B.toLazyText . B.decimal
|
||||
Reference in New Issue
Block a user