{-# LANGUAGE TemplateHaskell #-}
module Data.StringVariants.NullableNonEmptyText
(
NullableNonEmptyText (..),
mkNonEmptyTextWithTruncate,
compileNullableNonEmptyText,
mkNullableNonEmptyText,
parseNullableNonEmptyText,
nullNonEmptyText,
maybeTextToTruncateNullableNonEmptyText,
nonEmptyTextToNullable,
maybeNonEmptyTextToNullable,
nullableNonEmptyTextToMaybeText,
nullableNonEmptyTextToMaybeNonEmptyText,
fromMaybeNullableText,
isNullNonEmptyText,
)
where
import Control.Monad
import Data.Aeson
import Data.Aeson qualified as J
import Data.Aeson.Key qualified as J
import Data.Aeson.Types qualified as J
import Data.Data (Proxy (..))
import Data.Maybe (fromMaybe)
import Data.StringVariants.NonEmptyText
import Data.StringVariants.Util (textIsTooLong)
import Data.Text (Text)
import Data.Text qualified as T
import GHC.Generics (Generic)
import GHC.TypeLits (KnownNat, natVal)
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax (Lift (..))
import Prelude
newtype NullableNonEmptyText n = NullableNonEmptyText (Maybe (NonEmptyText n))
deriving stock (forall (n :: Nat) x.
Rep (NullableNonEmptyText n) x -> NullableNonEmptyText n
forall (n :: Nat) x.
NullableNonEmptyText n -> Rep (NullableNonEmptyText n) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall (n :: Nat) x.
Rep (NullableNonEmptyText n) x -> NullableNonEmptyText n
$cfrom :: forall (n :: Nat) x.
NullableNonEmptyText n -> Rep (NullableNonEmptyText n) x
Generic, Int -> NullableNonEmptyText n -> ShowS
forall (n :: Nat). Int -> NullableNonEmptyText n -> ShowS
forall (n :: Nat). [NullableNonEmptyText n] -> ShowS
forall (n :: Nat). NullableNonEmptyText n -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NullableNonEmptyText n] -> ShowS
$cshowList :: forall (n :: Nat). [NullableNonEmptyText n] -> ShowS
show :: NullableNonEmptyText n -> String
$cshow :: forall (n :: Nat). NullableNonEmptyText n -> String
showsPrec :: Int -> NullableNonEmptyText n -> ShowS
$cshowsPrec :: forall (n :: Nat). Int -> NullableNonEmptyText n -> ShowS
Show, ReadPrec [NullableNonEmptyText n]
ReadPrec (NullableNonEmptyText n)
ReadS [NullableNonEmptyText n]
forall (n :: Nat). ReadPrec [NullableNonEmptyText n]
forall (n :: Nat). ReadPrec (NullableNonEmptyText n)
forall (n :: Nat). Int -> ReadS (NullableNonEmptyText n)
forall (n :: Nat). ReadS [NullableNonEmptyText n]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [NullableNonEmptyText n]
$creadListPrec :: forall (n :: Nat). ReadPrec [NullableNonEmptyText n]
readPrec :: ReadPrec (NullableNonEmptyText n)
$creadPrec :: forall (n :: Nat). ReadPrec (NullableNonEmptyText n)
readList :: ReadS [NullableNonEmptyText n]
$creadList :: forall (n :: Nat). ReadS [NullableNonEmptyText n]
readsPrec :: Int -> ReadS (NullableNonEmptyText n)
$creadsPrec :: forall (n :: Nat). Int -> ReadS (NullableNonEmptyText n)
Read, forall (n :: Nat) (m :: * -> *).
Quote m =>
NullableNonEmptyText n -> m Exp
forall (n :: Nat) (m :: * -> *).
Quote m =>
NullableNonEmptyText n -> Code m (NullableNonEmptyText n)
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => NullableNonEmptyText n -> m Exp
forall (m :: * -> *).
Quote m =>
NullableNonEmptyText n -> Code m (NullableNonEmptyText n)
liftTyped :: forall (m :: * -> *).
Quote m =>
NullableNonEmptyText n -> Code m (NullableNonEmptyText n)
$cliftTyped :: forall (n :: Nat) (m :: * -> *).
Quote m =>
NullableNonEmptyText n -> Code m (NullableNonEmptyText n)
lift :: forall (m :: * -> *). Quote m => NullableNonEmptyText n -> m Exp
$clift :: forall (n :: Nat) (m :: * -> *).
Quote m =>
NullableNonEmptyText n -> m Exp
Lift)
deriving newtype (NullableNonEmptyText n -> NullableNonEmptyText n -> Bool
forall (n :: Nat).
NullableNonEmptyText n -> NullableNonEmptyText n -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NullableNonEmptyText n -> NullableNonEmptyText n -> Bool
$c/= :: forall (n :: Nat).
NullableNonEmptyText n -> NullableNonEmptyText n -> Bool
== :: NullableNonEmptyText n -> NullableNonEmptyText n -> Bool
$c== :: forall (n :: Nat).
NullableNonEmptyText n -> NullableNonEmptyText n -> Bool
Eq, [NullableNonEmptyText n] -> Encoding
[NullableNonEmptyText n] -> Value
NullableNonEmptyText n -> Encoding
NullableNonEmptyText n -> Value
forall (n :: Nat). [NullableNonEmptyText n] -> Encoding
forall (n :: Nat). [NullableNonEmptyText n] -> Value
forall (n :: Nat). NullableNonEmptyText n -> Encoding
forall (n :: Nat). NullableNonEmptyText n -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [NullableNonEmptyText n] -> Encoding
$ctoEncodingList :: forall (n :: Nat). [NullableNonEmptyText n] -> Encoding
toJSONList :: [NullableNonEmptyText n] -> Value
$ctoJSONList :: forall (n :: Nat). [NullableNonEmptyText n] -> Value
toEncoding :: NullableNonEmptyText n -> Encoding
$ctoEncoding :: forall (n :: Nat). NullableNonEmptyText n -> Encoding
toJSON :: NullableNonEmptyText n -> Value
$ctoJSON :: forall (n :: Nat). NullableNonEmptyText n -> Value
ToJSON)
mkNullableNonEmptyText :: forall n. KnownNat n => Text -> Maybe (NullableNonEmptyText n)
mkNullableNonEmptyText :: forall (n :: Nat).
KnownNat n =>
Text -> Maybe (NullableNonEmptyText n)
mkNullableNonEmptyText Text
t
| Text -> Int -> Bool
textIsTooLong Text
t (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy @n)) = forall a. Maybe a
Nothing
| Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (n :: Nat). Maybe (NonEmptyText n) -> NullableNonEmptyText n
NullableNonEmptyText forall a b. (a -> b) -> a -> b
$ forall (n :: Nat). KnownNat n => Text -> Maybe (NonEmptyText n)
mkNonEmptyText Text
t
mkNonEmptyTextWithTruncate :: forall n. KnownNat n => Text -> Maybe (NonEmptyText n)
mkNonEmptyTextWithTruncate :: forall (n :: Nat). KnownNat n => Text -> Maybe (NonEmptyText n)
mkNonEmptyTextWithTruncate = forall (n :: Nat). KnownNat n => Text -> Maybe (NonEmptyText n)
mkNonEmptyText forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
T.take (forall a. Num a => Integer -> a
fromInteger (forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy @n)))
nullNonEmptyText :: NullableNonEmptyText n
nullNonEmptyText :: forall (n :: Nat). NullableNonEmptyText n
nullNonEmptyText = forall (n :: Nat). Maybe (NonEmptyText n) -> NullableNonEmptyText n
NullableNonEmptyText forall a. Maybe a
Nothing
isNullNonEmptyText :: NullableNonEmptyText n -> Bool
isNullNonEmptyText :: forall (n :: Nat). NullableNonEmptyText n -> Bool
isNullNonEmptyText = (forall a. Eq a => a -> a -> Bool
== forall (n :: Nat). NullableNonEmptyText n
nullNonEmptyText)
instance KnownNat n => FromJSON (NullableNonEmptyText n) where
parseJSON :: Value -> Parser (NullableNonEmptyText n)
parseJSON = \case
J.String Text
t -> case forall (n :: Nat).
KnownNat n =>
Text -> Maybe (NullableNonEmptyText n)
mkNullableNonEmptyText Text
t of
Just NullableNonEmptyText n
txt -> forall (f :: * -> *) a. Applicative f => a -> f a
pure NullableNonEmptyText n
txt
Maybe (NullableNonEmptyText n)
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Data/StringVariants/NullableNonEmptyText.hs: When trying to parse a NullableNonEmptyText, expected a String of length < " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy @n)) forall a. [a] -> [a] -> [a]
++ String
", but received: " forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
t
Value
J.Null -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (n :: Nat). Maybe (NonEmptyText n) -> NullableNonEmptyText n
NullableNonEmptyText forall a. Maybe a
Nothing
Value
x -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Data/StringVariants/NullableNonEmptyText.hs: When trying to parse a NullableNonEmptyText, expected a String or Null, but received: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Value
x
parseNullableNonEmptyText :: KnownNat n => Text -> J.Object -> J.Parser (NullableNonEmptyText n)
parseNullableNonEmptyText :: forall (n :: Nat).
KnownNat n =>
Text -> Object -> Parser (NullableNonEmptyText n)
parseNullableNonEmptyText Text
fieldName Object
obj = Object
obj forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Text -> Key
J.fromText Text
fieldName forall a. Parser (Maybe a) -> a -> Parser a
.!= forall (n :: Nat). NullableNonEmptyText n
nullNonEmptyText
fromMaybeNullableText :: Maybe (NullableNonEmptyText n) -> NullableNonEmptyText n
fromMaybeNullableText :: forall (n :: Nat).
Maybe (NullableNonEmptyText n) -> NullableNonEmptyText n
fromMaybeNullableText = forall a. a -> Maybe a -> a
fromMaybe forall (n :: Nat). NullableNonEmptyText n
nullNonEmptyText
nonEmptyTextToNullable :: NonEmptyText n -> NullableNonEmptyText n
nonEmptyTextToNullable :: forall (n :: Nat). NonEmptyText n -> NullableNonEmptyText n
nonEmptyTextToNullable = forall (n :: Nat). Maybe (NonEmptyText n) -> NullableNonEmptyText n
NullableNonEmptyText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just
maybeNonEmptyTextToNullable :: Maybe (NonEmptyText n) -> NullableNonEmptyText n
maybeNonEmptyTextToNullable :: forall (n :: Nat). Maybe (NonEmptyText n) -> NullableNonEmptyText n
maybeNonEmptyTextToNullable Maybe (NonEmptyText n)
Nothing = forall (n :: Nat). NullableNonEmptyText n
nullNonEmptyText
maybeNonEmptyTextToNullable Maybe (NonEmptyText n)
jt = forall (n :: Nat). Maybe (NonEmptyText n) -> NullableNonEmptyText n
NullableNonEmptyText Maybe (NonEmptyText n)
jt
maybeTextToTruncateNullableNonEmptyText :: forall n. KnownNat n => Maybe Text -> NullableNonEmptyText n
maybeTextToTruncateNullableNonEmptyText :: forall (n :: Nat).
KnownNat n =>
Maybe Text -> NullableNonEmptyText n
maybeTextToTruncateNullableNonEmptyText Maybe Text
mText = forall (n :: Nat). Maybe (NonEmptyText n) -> NullableNonEmptyText n
NullableNonEmptyText forall a b. (a -> b) -> a -> b
$ Maybe Text
mText forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (n :: Nat). KnownNat n => Text -> Maybe (NonEmptyText n)
mkNonEmptyText forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
T.take (forall a. Num a => Integer -> a
fromInteger (forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy @n)))
nullableNonEmptyTextToMaybeNonEmptyText :: NullableNonEmptyText n -> Maybe (NonEmptyText n)
nullableNonEmptyTextToMaybeNonEmptyText :: forall (n :: Nat). NullableNonEmptyText n -> Maybe (NonEmptyText n)
nullableNonEmptyTextToMaybeNonEmptyText (NullableNonEmptyText Maybe (NonEmptyText n)
t) = Maybe (NonEmptyText n)
t
nullableNonEmptyTextToMaybeText :: NullableNonEmptyText n -> Maybe Text
nullableNonEmptyTextToMaybeText :: forall (n :: Nat). NullableNonEmptyText n -> Maybe Text
nullableNonEmptyTextToMaybeText (NullableNonEmptyText Maybe (NonEmptyText n)
t) = forall (n :: Nat). NonEmptyText n -> Text
nonEmptyTextToText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (NonEmptyText n)
t
compileNullableNonEmptyText :: Integer -> QuasiQuoter
compileNullableNonEmptyText :: Integer -> QuasiQuoter
compileNullableNonEmptyText Integer
n =
QuasiQuoter
{ quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
compileNullableNonEmptyText'
, quotePat :: String -> Q Pat
quotePat = forall a. HasCallStack => String -> a
error String
"NullableNonEmptyText is not a pattern; use `nullableNonEmptyTextToMaybeText` instead"
, quoteDec :: String -> Q [Dec]
quoteDec = forall a. HasCallStack => String -> a
error String
"NullableNonEmptyText is not supported at top-level"
, quoteType :: String -> Q Type
quoteType = forall a. HasCallStack => String -> a
error String
"NullableNonEmptyText is not supported as a type"
}
where
compileNullableNonEmptyText' :: String -> Q Exp
compileNullableNonEmptyText' :: String -> Q Exp
compileNullableNonEmptyText' String
s = forall x.
Integer
-> (forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> x)
-> x
useNat Integer
n forall a b. (a -> b) -> a -> b
$ \proxy n
p ->
case forall {k} (proxy :: Nat -> *) (n :: Nat) (f :: k -> *)
(other :: Nat -> k).
proxy n -> f (other n) -> f (other n)
natOfLength proxy n
p forall a b. (a -> b) -> a -> b
$ forall (n :: Nat).
KnownNat n =>
Text -> Maybe (NullableNonEmptyText n)
mkNullableNonEmptyText (String -> Text
T.pack String
s) of
Maybe (NullableNonEmptyText n)
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Invalid NullableNonEmptyText. Needs to be < " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Integer
n forall a. Num a => a -> a -> a
+ Integer
1) forall a. [a] -> [a] -> [a]
++ String
" characters, and not entirely whitespace: " forall a. [a] -> [a] -> [a]
++ String
s
Just NullableNonEmptyText n
txt -> [|$(lift txt)|]