mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-18 04:51:35 +03:00
823babe885
## Migrating, for server devs You will need the fork of 9.2.4 that we're using (for now): ``` ghcup -c -n install ghc --force -u "https://storage.googleapis.com/graphql-engine-cdn.hasura.io/ghc-bindists/ghc-x86_64-deb10-linux-9.2.4-hasura-fix.tar.xz" 9.2.4 ``` or for m1 mac: ``` ghcup -c -n install ghc --force -u "https://storage.googleapis.com/graphql-engine-cdn.hasura.io/ghc-bindists/ghc-arm64-apple-darwin-9.2.4-hasura-fix.tar.xz" ``` Samir is working on a nix build for nix folx PR-URL: https://github.com/hasura/graphql-engine-mono/pull/6154 GitOrigin-RevId: 6716e3f2ee19f0281c8ad25383a1241fc362d616
74 lines
2.5 KiB
Haskell
74 lines
2.5 KiB
Haskell
{-# LANGUAGE TemplateHaskellQuotes #-}
|
|
|
|
module Data.Text.NonEmpty
|
|
( NonEmptyText,
|
|
mkNonEmptyTextUnsafe,
|
|
mkNonEmptyText,
|
|
unNonEmptyText,
|
|
nonEmptyText,
|
|
nonEmptyTextCodec,
|
|
nonEmptyTextQQ,
|
|
)
|
|
where
|
|
|
|
import Autodocodec (HasCodec (codec), JSONCodec, bimapCodec, textCodec)
|
|
import Data.Aeson
|
|
import Data.Text qualified as T
|
|
import Data.Text.Extended
|
|
import Database.PG.Query qualified as PG
|
|
import Hasura.Prelude hiding (lift)
|
|
import Language.Haskell.TH.Quote (QuasiQuoter (..))
|
|
import Language.Haskell.TH.Syntax (Code, Lift, Q, bindCode, lift)
|
|
import Test.QuickCheck qualified as QC
|
|
|
|
newtype NonEmptyText = NonEmptyText {unNonEmptyText :: Text}
|
|
deriving (Show, Eq, Ord, Hashable, ToJSON, ToJSONKey, Lift, PG.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 -> Code Q NonEmptyText
|
|
nonEmptyText textDirty = parseNonEmptyText textDirty `bindCode` \text -> [||text||]
|
|
|
|
nonEmptyTextCodec :: JSONCodec NonEmptyText
|
|
nonEmptyTextCodec = bimapCodec dec enc textCodec
|
|
where
|
|
dec = maybeToEither "empty string not allowed" . parseNonEmptyText
|
|
enc = unNonEmptyText
|
|
|
|
-- | 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 PG.FromCol NonEmptyText where
|
|
fromCol bs =
|
|
mkNonEmptyText <$> PG.fromCol bs
|
|
>>= maybe (Left "empty string not allowed") Right
|
|
|
|
instance HasCodec NonEmptyText where
|
|
codec = nonEmptyTextCodec
|