{-# LANGUAGE TemplateHaskell #-}

module Data.StringVariants.NullableNonEmptyText
  ( -- Safe to construct, so we can export the contents
    NullableNonEmptyText (..),

    -- * Constructing
    mkNonEmptyTextWithTruncate,
    compileNullableNonEmptyText,
    mkNullableNonEmptyText,
    parseNullableNonEmptyText,
    nullNonEmptyText,

    -- * Conversion
    maybeTextToTruncateNullableNonEmptyText,
    nonEmptyTextToNullable,
    maybeNonEmptyTextToNullable,
    nullableNonEmptyTextToMaybeText,
    nullableNonEmptyTextToMaybeNonEmptyText,
    fromMaybeNullableText,

    -- * Functions
    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 wrapper around Maybe NonEmptyText that converts empty string to 'Nothing'.
--
--   This is aimed primarily at JSON parsing: make it possible to parse empty
--   string and turn it into @Nothing@, in order to convert everything into
--   @Maybe NonEmptyText@ at the edge of the system.
--
--   While using this for JSON parsing, use @Maybe NullableNonEmptyText@. Aeson
--   special-cases @Maybe@ to allow nulls, so @Maybe@ catches the nulls and
--   @NullableNonEmptyText@ catches the empty strings.
--
--   To extract @Maybe NonEmptyText@ values from @Maybe NullableNonEmptyText@,
--   use 'nullableNonEmptyTextToMaybeNonEmptyText'.
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 -- we can't store text that is too long
  | 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)|]