ghcup-hs/lib/GHCup/Prelude.hs
2020-02-29 00:33:32 +01:00

218 lines
5.7 KiB
Haskell

{-# 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.Prelude where
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Class ( lift )
import Control.Exception.Safe
import Data.Bifunctor
import Data.ByteString ( ByteString )
import qualified Data.Strict.Maybe as S
import Data.Monoid ( (<>) )
import Data.String
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 Data.Text.Lazy as TL
import Data.Text ( Text )
import qualified Data.Text.Encoding as E
import qualified Data.Text as T
import Data.Versions
import qualified Data.ByteString.Lazy as L
import Haskus.Utils.Variant.Excepts
import System.IO.Error
import Language.Haskell.TH
import Language.Haskell.TH.Syntax ( Exp(..)
, Lift
)
import qualified Language.Haskell.TH.Syntax as TH
import Language.Haskell.TH.Quote ( QuasiQuoter(..) )
import GHC.Base
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' :: IOErrorType -> (IOException -> IO a) -> IO a -> IO a
handleIO' err handler =
handleIO (\e -> if err == ioeGetErrorType e then handler e else 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
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 h a action =
catchLiftLeft ((\(x@e) -> pure a) :: (e -> Excepts es' m a)) 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)"
}
ver :: QuasiQuoter
ver = 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