171 lines
4.4 KiB
Haskell
171 lines
4.4 KiB
Haskell
{-# OPTIONS_GHC -Wno-orphans #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
{-# LANGUAGE DeriveLift #-}
|
|
{-# LANGUAGE StandaloneDeriving #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
|
|
module GHCup.Prelude where
|
|
|
|
import Control.Applicative
|
|
import Control.Monad
|
|
import Control.Monad.Trans.Class ( lift )
|
|
import Control.Exception.Safe
|
|
import Data.ByteString (ByteString)
|
|
import qualified Data.Strict.Maybe as S
|
|
import Data.Monoid ( (<>) )
|
|
import Data.String
|
|
import qualified Data.Text.Lazy.Encoding as TLE
|
|
import qualified Data.Text.Lazy as TL
|
|
import Data.Text ( Text )
|
|
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 ()) -> IO () -> IO ()
|
|
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
|
|
|
|
lEM :: forall e es a m . (Monad m, e :< es) => m (Either e a) -> Excepts es m a
|
|
lEM em = lift em >>= lE
|
|
|
|
fromEither :: Either a b -> VEither '[a] b
|
|
fromEither = either (VLeft . V) VRight
|
|
|
|
|
|
|
|
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
|
|
|