mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-18 13:02:11 +03:00
88ace749bc
PR-URL: https://github.com/hasura/graphql-engine-mono/pull/4738 GitOrigin-RevId: d0c0b13ac02ca80e51ae3d582f2e6917f76ad202
63 lines
2.1 KiB
Haskell
63 lines
2.1 KiB
Haskell
{-# LANGUAGE TemplateHaskellQuotes #-}
|
|
|
|
module Data.Text.NonEmpty
|
|
( NonEmptyText,
|
|
mkNonEmptyTextUnsafe,
|
|
mkNonEmptyText,
|
|
unNonEmptyText,
|
|
nonEmptyText,
|
|
nonEmptyTextQQ,
|
|
)
|
|
where
|
|
|
|
import Data.Aeson
|
|
import Data.Text qualified as T
|
|
import Data.Text.Extended
|
|
import Database.PG.Query qualified as Q
|
|
import Hasura.Prelude hiding (lift)
|
|
import Language.Haskell.TH.Quote (QuasiQuoter (..))
|
|
import Language.Haskell.TH.Syntax (Lift, Q, TExp, lift)
|
|
import Test.QuickCheck qualified as QC
|
|
|
|
newtype NonEmptyText = NonEmptyText {unNonEmptyText :: Text}
|
|
deriving (Show, Eq, Ord, Hashable, ToJSON, ToJSONKey, Lift, Q.ToPrepArg, ToTxt, Generic, NFData)
|
|
|
|
instance QC.Arbitrary NonEmptyText where
|
|
arbitrary = NonEmptyText . T.pack <$> QC.listOf1 (QC.elements alphaNumerics)
|
|
|
|
mkNonEmptyText :: Text -> Maybe NonEmptyText
|
|
mkNonEmptyText "" = Nothing
|
|
mkNonEmptyText text = Just $ NonEmptyText text
|
|
|
|
mkNonEmptyTextUnsafe :: Text -> NonEmptyText
|
|
mkNonEmptyTextUnsafe = NonEmptyText
|
|
|
|
parseNonEmptyText :: MonadFail m => Text -> m NonEmptyText
|
|
parseNonEmptyText text = mkNonEmptyText text `onNothing` fail "empty string not allowed"
|
|
|
|
nonEmptyText :: Text -> Q (TExp NonEmptyText)
|
|
nonEmptyText = parseNonEmptyText >=> \text -> [||text||]
|
|
|
|
-- | Construct 'NonEmptyText' literals at compile-time via quasiquotation.
|
|
nonEmptyTextQQ :: QuasiQuoter
|
|
nonEmptyTextQQ =
|
|
QuasiQuoter {quoteExp, quotePat, quoteType, quoteDec}
|
|
where
|
|
quotePat _ = error "nonEmptyTextQQ does not support quoting patterns"
|
|
quoteType _ = error "nonEmptyTextQQ does not support quoting types"
|
|
quoteDec _ = error "nonEmptyTextQQ does not support quoting declarations"
|
|
quoteExp s = case mkNonEmptyText (T.pack s) of
|
|
Just result -> lift result
|
|
Nothing -> fail "empty string not allowed"
|
|
|
|
instance FromJSON NonEmptyText where
|
|
parseJSON = withText "String" parseNonEmptyText
|
|
|
|
instance FromJSONKey NonEmptyText where
|
|
fromJSONKey = FromJSONKeyTextParser parseNonEmptyText
|
|
|
|
instance Q.FromCol NonEmptyText where
|
|
fromCol bs =
|
|
mkNonEmptyText <$> Q.fromCol bs
|
|
>>= maybe (Left "empty string not allowed") Right
|