{-# 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 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 {NonEmptyText -> Text
unNonEmptyText :: Text}
  deriving (Int -> NonEmptyText -> ShowS
[NonEmptyText] -> ShowS
NonEmptyText -> String
(Int -> NonEmptyText -> ShowS)
-> (NonEmptyText -> String)
-> ([NonEmptyText] -> ShowS)
-> Show NonEmptyText
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NonEmptyText] -> ShowS
$cshowList :: [NonEmptyText] -> ShowS
show :: NonEmptyText -> String
$cshow :: NonEmptyText -> String
showsPrec :: Int -> NonEmptyText -> ShowS
$cshowsPrec :: Int -> NonEmptyText -> ShowS
Show, NonEmptyText -> NonEmptyText -> Bool
(NonEmptyText -> NonEmptyText -> Bool)
-> (NonEmptyText -> NonEmptyText -> Bool) -> Eq NonEmptyText
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NonEmptyText -> NonEmptyText -> Bool
$c/= :: NonEmptyText -> NonEmptyText -> Bool
== :: NonEmptyText -> NonEmptyText -> Bool
$c== :: NonEmptyText -> NonEmptyText -> Bool
Eq, Eq NonEmptyText
Eq NonEmptyText
-> (NonEmptyText -> NonEmptyText -> Ordering)
-> (NonEmptyText -> NonEmptyText -> Bool)
-> (NonEmptyText -> NonEmptyText -> Bool)
-> (NonEmptyText -> NonEmptyText -> Bool)
-> (NonEmptyText -> NonEmptyText -> Bool)
-> (NonEmptyText -> NonEmptyText -> NonEmptyText)
-> (NonEmptyText -> NonEmptyText -> NonEmptyText)
-> Ord NonEmptyText
NonEmptyText -> NonEmptyText -> Bool
NonEmptyText -> NonEmptyText -> Ordering
NonEmptyText -> NonEmptyText -> NonEmptyText
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: NonEmptyText -> NonEmptyText -> NonEmptyText
$cmin :: NonEmptyText -> NonEmptyText -> NonEmptyText
max :: NonEmptyText -> NonEmptyText -> NonEmptyText
$cmax :: NonEmptyText -> NonEmptyText -> NonEmptyText
>= :: NonEmptyText -> NonEmptyText -> Bool
$c>= :: NonEmptyText -> NonEmptyText -> Bool
> :: NonEmptyText -> NonEmptyText -> Bool
$c> :: NonEmptyText -> NonEmptyText -> Bool
<= :: NonEmptyText -> NonEmptyText -> Bool
$c<= :: NonEmptyText -> NonEmptyText -> Bool
< :: NonEmptyText -> NonEmptyText -> Bool
$c< :: NonEmptyText -> NonEmptyText -> Bool
compare :: NonEmptyText -> NonEmptyText -> Ordering
$ccompare :: NonEmptyText -> NonEmptyText -> Ordering
$cp1Ord :: Eq NonEmptyText
Ord, Int -> NonEmptyText -> Int
NonEmptyText -> Int
(Int -> NonEmptyText -> Int)
-> (NonEmptyText -> Int) -> Hashable NonEmptyText
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: NonEmptyText -> Int
$chash :: NonEmptyText -> Int
hashWithSalt :: Int -> NonEmptyText -> Int
$chashWithSalt :: Int -> NonEmptyText -> Int
Hashable, [NonEmptyText] -> Value
[NonEmptyText] -> Encoding
NonEmptyText -> Value
NonEmptyText -> Encoding
(NonEmptyText -> Value)
-> (NonEmptyText -> Encoding)
-> ([NonEmptyText] -> Value)
-> ([NonEmptyText] -> Encoding)
-> ToJSON NonEmptyText
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [NonEmptyText] -> Encoding
$ctoEncodingList :: [NonEmptyText] -> Encoding
toJSONList :: [NonEmptyText] -> Value
$ctoJSONList :: [NonEmptyText] -> Value
toEncoding :: NonEmptyText -> Encoding
$ctoEncoding :: NonEmptyText -> Encoding
toJSON :: NonEmptyText -> Value
$ctoJSON :: NonEmptyText -> Value
ToJSON, ToJSONKeyFunction [NonEmptyText]
ToJSONKeyFunction NonEmptyText
ToJSONKeyFunction NonEmptyText
-> ToJSONKeyFunction [NonEmptyText] -> ToJSONKey NonEmptyText
forall a.
ToJSONKeyFunction a -> ToJSONKeyFunction [a] -> ToJSONKey a
toJSONKeyList :: ToJSONKeyFunction [NonEmptyText]
$ctoJSONKeyList :: ToJSONKeyFunction [NonEmptyText]
toJSONKey :: ToJSONKeyFunction NonEmptyText
$ctoJSONKey :: ToJSONKeyFunction NonEmptyText
ToJSONKey, NonEmptyText -> Q Exp
NonEmptyText -> Q (TExp NonEmptyText)
(NonEmptyText -> Q Exp)
-> (NonEmptyText -> Q (TExp NonEmptyText)) -> Lift NonEmptyText
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: NonEmptyText -> Q (TExp NonEmptyText)
$cliftTyped :: NonEmptyText -> Q (TExp NonEmptyText)
lift :: NonEmptyText -> Q Exp
$clift :: NonEmptyText -> Q Exp
Lift, NonEmptyText -> PrepArg
(NonEmptyText -> PrepArg) -> ToPrepArg NonEmptyText
forall a. (a -> PrepArg) -> ToPrepArg a
toPrepVal :: NonEmptyText -> PrepArg
$ctoPrepVal :: NonEmptyText -> PrepArg
Q.ToPrepArg, NonEmptyText -> Text
(NonEmptyText -> Text) -> ToTxt NonEmptyText
forall a. (a -> Text) -> ToTxt a
toTxt :: NonEmptyText -> Text
$ctoTxt :: NonEmptyText -> Text
ToTxt, (forall x. NonEmptyText -> Rep NonEmptyText x)
-> (forall x. Rep NonEmptyText x -> NonEmptyText)
-> Generic NonEmptyText
forall x. Rep NonEmptyText x -> NonEmptyText
forall x. NonEmptyText -> Rep NonEmptyText x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep NonEmptyText x -> NonEmptyText
$cfrom :: forall x. NonEmptyText -> Rep NonEmptyText x
Generic, NonEmptyText -> ()
(NonEmptyText -> ()) -> NFData NonEmptyText
forall a. (a -> ()) -> NFData a
rnf :: NonEmptyText -> ()
$crnf :: NonEmptyText -> ()
NFData)

instance QC.Arbitrary NonEmptyText where
  arbitrary :: Gen NonEmptyText
arbitrary = Text -> NonEmptyText
NonEmptyText (Text -> NonEmptyText)
-> (String -> Text) -> String -> NonEmptyText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> NonEmptyText) -> Gen String -> Gen NonEmptyText
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Char -> Gen String
forall a. Gen a -> Gen [a]
QC.listOf1 (String -> Gen Char
forall a. [a] -> Gen a
QC.elements String
alphaNumerics)

mkNonEmptyText :: Text -> Maybe NonEmptyText
mkNonEmptyText :: Text -> Maybe NonEmptyText
mkNonEmptyText Text
"" = Maybe NonEmptyText
forall a. Maybe a
Nothing
mkNonEmptyText Text
text = NonEmptyText -> Maybe NonEmptyText
forall a. a -> Maybe a
Just (NonEmptyText -> Maybe NonEmptyText)
-> NonEmptyText -> Maybe NonEmptyText
forall a b. (a -> b) -> a -> b
$ Text -> NonEmptyText
NonEmptyText Text
text

mkNonEmptyTextUnsafe :: Text -> NonEmptyText
mkNonEmptyTextUnsafe :: Text -> NonEmptyText
mkNonEmptyTextUnsafe = Text -> NonEmptyText
NonEmptyText

parseNonEmptyText :: MonadFail m => Text -> m NonEmptyText
parseNonEmptyText :: Text -> m NonEmptyText
parseNonEmptyText Text
text = Text -> Maybe NonEmptyText
mkNonEmptyText Text
text Maybe NonEmptyText -> m NonEmptyText -> m NonEmptyText
forall (m :: * -> *) a. Applicative m => Maybe a -> m a -> m a
`onNothing` String -> m NonEmptyText
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"empty string not allowed"

nonEmptyText :: Text -> Q (TExp NonEmptyText)
nonEmptyText :: Text -> Q (TExp NonEmptyText)
nonEmptyText = Text -> Q NonEmptyText
forall (m :: * -> *). MonadFail m => Text -> m NonEmptyText
parseNonEmptyText (Text -> Q NonEmptyText)
-> (NonEmptyText -> Q (TExp NonEmptyText))
-> Text
-> Q (TExp NonEmptyText)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \NonEmptyText
text -> [||text||]

nonEmptyTextCodec :: JSONCodec NonEmptyText
nonEmptyTextCodec :: JSONCodec NonEmptyText
nonEmptyTextCodec = (Text -> Either String NonEmptyText)
-> (NonEmptyText -> Text)
-> Codec Value Text Text
-> JSONCodec NonEmptyText
forall oldOutput newOutput newInput oldInput context.
(oldOutput -> Either String newOutput)
-> (newInput -> oldInput)
-> Codec context oldInput oldOutput
-> Codec context newInput newOutput
bimapCodec Text -> Either String NonEmptyText
dec NonEmptyText -> Text
enc Codec Value Text Text
textCodec
  where
    dec :: Text -> Either String NonEmptyText
dec = String -> Maybe NonEmptyText -> Either String NonEmptyText
forall a b. a -> Maybe b -> Either a b
maybeToEither String
"empty string not allowed" (Maybe NonEmptyText -> Either String NonEmptyText)
-> (Text -> Maybe NonEmptyText)
-> Text
-> Either String NonEmptyText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe NonEmptyText
forall (m :: * -> *). MonadFail m => Text -> m NonEmptyText
parseNonEmptyText
    enc :: NonEmptyText -> Text
enc = NonEmptyText -> Text
unNonEmptyText

-- | Construct 'NonEmptyText' literals at compile-time via quasiquotation.
nonEmptyTextQQ :: QuasiQuoter
nonEmptyTextQQ :: QuasiQuoter
nonEmptyTextQQ =
  QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter {String -> Q Exp
quoteExp :: String -> Q Exp
quoteExp :: String -> Q Exp
quoteExp, String -> Q Pat
forall p a. p -> a
quotePat :: String -> Q Pat
quotePat :: forall p a. p -> a
quotePat, String -> Q Type
forall p a. p -> a
quoteType :: String -> Q Type
quoteType :: forall p a. p -> a
quoteType, String -> Q [Dec]
forall p a. p -> a
quoteDec :: String -> Q [Dec]
quoteDec :: forall p a. p -> a
quoteDec}
  where
    quotePat :: p -> a
quotePat p
_ = String -> a
forall a. HasCallStack => String -> a
error String
"nonEmptyTextQQ does not support quoting patterns"
    quoteType :: p -> a
quoteType p
_ = String -> a
forall a. HasCallStack => String -> a
error String
"nonEmptyTextQQ does not support quoting types"
    quoteDec :: p -> a
quoteDec p
_ = String -> a
forall a. HasCallStack => String -> a
error String
"nonEmptyTextQQ does not support quoting declarations"
    quoteExp :: String -> Q Exp
quoteExp String
s = case Text -> Maybe NonEmptyText
mkNonEmptyText (String -> Text
T.pack String
s) of
      Just NonEmptyText
result -> NonEmptyText -> Q Exp
forall t. Lift t => t -> Q Exp
lift NonEmptyText
result
      Maybe NonEmptyText
Nothing -> String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"empty string not allowed"

instance FromJSON NonEmptyText where
  parseJSON :: Value -> Parser NonEmptyText
parseJSON = String
-> (Text -> Parser NonEmptyText) -> Value -> Parser NonEmptyText
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"String" Text -> Parser NonEmptyText
forall (m :: * -> *). MonadFail m => Text -> m NonEmptyText
parseNonEmptyText

instance FromJSONKey NonEmptyText where
  fromJSONKey :: FromJSONKeyFunction NonEmptyText
fromJSONKey = (Text -> Parser NonEmptyText) -> FromJSONKeyFunction NonEmptyText
forall a. (Text -> Parser a) -> FromJSONKeyFunction a
FromJSONKeyTextParser Text -> Parser NonEmptyText
forall (m :: * -> *). MonadFail m => Text -> m NonEmptyText
parseNonEmptyText

instance Q.FromCol NonEmptyText where
  fromCol :: Maybe ByteString -> Either Text NonEmptyText
fromCol Maybe ByteString
bs =
    Text -> Maybe NonEmptyText
mkNonEmptyText (Text -> Maybe NonEmptyText)
-> Either Text Text -> Either Text (Maybe NonEmptyText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString -> Either Text Text
forall a. FromCol a => Maybe ByteString -> Either Text a
Q.fromCol Maybe ByteString
bs
      Either Text (Maybe NonEmptyText)
-> (Maybe NonEmptyText -> Either Text NonEmptyText)
-> Either Text NonEmptyText
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either Text NonEmptyText
-> (NonEmptyText -> Either Text NonEmptyText)
-> Maybe NonEmptyText
-> Either Text NonEmptyText
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text NonEmptyText
forall a b. a -> Either a b
Left Text
"empty string not allowed") NonEmptyText -> Either Text NonEmptyText
forall a b. b -> Either a b
Right

instance HasCodec NonEmptyText where
  codec :: JSONCodec NonEmptyText
codec = JSONCodec NonEmptyText
nonEmptyTextCodec