{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

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

    -- * Constructing
    mkNonEmptyTextWithTruncate,
    compileNullableNonEmptyText,
    literalNullableNonEmptyText,
    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
import Data.Text (Text)
import Data.Text qualified as T
import GHC.Generics (Generic)
import GHC.TypeLits (KnownNat, KnownSymbol, Nat, Symbol, 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 :: Natural) x.
Rep (NullableNonEmptyText n) x -> NullableNonEmptyText n
forall (n :: Natural) 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 :: Natural) x.
Rep (NullableNonEmptyText n) x -> NullableNonEmptyText n
$cfrom :: forall (n :: Natural) x.
NullableNonEmptyText n -> Rep (NullableNonEmptyText n) x
Generic, Int -> NullableNonEmptyText n -> ShowS
forall (n :: Natural). Int -> NullableNonEmptyText n -> ShowS
forall (n :: Natural). [NullableNonEmptyText n] -> ShowS
forall (n :: Natural). NullableNonEmptyText n -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [NullableNonEmptyText n] -> ShowS
$cshowList :: forall (n :: Natural). [NullableNonEmptyText n] -> ShowS
show :: NullableNonEmptyText n -> [Char]
$cshow :: forall (n :: Natural). NullableNonEmptyText n -> [Char]
showsPrec :: Int -> NullableNonEmptyText n -> ShowS
$cshowsPrec :: forall (n :: Natural). Int -> NullableNonEmptyText n -> ShowS
Show, ReadPrec [NullableNonEmptyText n]
ReadPrec (NullableNonEmptyText n)
ReadS [NullableNonEmptyText n]
forall (n :: Natural). ReadPrec [NullableNonEmptyText n]
forall (n :: Natural). ReadPrec (NullableNonEmptyText n)
forall (n :: Natural). Int -> ReadS (NullableNonEmptyText n)
forall (n :: Natural). ReadS [NullableNonEmptyText n]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [NullableNonEmptyText n]
$creadListPrec :: forall (n :: Natural). ReadPrec [NullableNonEmptyText n]
readPrec :: ReadPrec (NullableNonEmptyText n)
$creadPrec :: forall (n :: Natural). ReadPrec (NullableNonEmptyText n)
readList :: ReadS [NullableNonEmptyText n]
$creadList :: forall (n :: Natural). ReadS [NullableNonEmptyText n]
readsPrec :: Int -> ReadS (NullableNonEmptyText n)
$creadsPrec :: forall (n :: Natural). Int -> ReadS (NullableNonEmptyText n)
Read, forall (n :: Natural) (m :: * -> *).
Quote m =>
NullableNonEmptyText n -> m Exp
forall (n :: Natural) (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 :: Natural) (m :: * -> *).
Quote m =>
NullableNonEmptyText n -> Code m (NullableNonEmptyText n)
lift :: forall (m :: * -> *). Quote m => NullableNonEmptyText n -> m Exp
$clift :: forall (n :: Natural) (m :: * -> *).
Quote m =>
NullableNonEmptyText n -> m Exp
Lift)
  deriving newtype (NullableNonEmptyText n -> NullableNonEmptyText n -> Bool
forall (n :: Natural).
NullableNonEmptyText n -> NullableNonEmptyText n -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NullableNonEmptyText n -> NullableNonEmptyText n -> Bool
$c/= :: forall (n :: Natural).
NullableNonEmptyText n -> NullableNonEmptyText n -> Bool
== :: NullableNonEmptyText n -> NullableNonEmptyText n -> Bool
$c== :: forall (n :: Natural).
NullableNonEmptyText n -> NullableNonEmptyText n -> Bool
Eq, [NullableNonEmptyText n] -> Encoding
[NullableNonEmptyText n] -> Value
NullableNonEmptyText n -> Encoding
NullableNonEmptyText n -> Value
forall (n :: Natural). [NullableNonEmptyText n] -> Encoding
forall (n :: Natural). [NullableNonEmptyText n] -> Value
forall (n :: Natural). NullableNonEmptyText n -> Encoding
forall (n :: Natural). NullableNonEmptyText n -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [NullableNonEmptyText n] -> Encoding
$ctoEncodingList :: forall (n :: Natural). [NullableNonEmptyText n] -> Encoding
toJSONList :: [NullableNonEmptyText n] -> Value
$ctoJSONList :: forall (n :: Natural). [NullableNonEmptyText n] -> Value
toEncoding :: NullableNonEmptyText n -> Encoding
$ctoEncoding :: forall (n :: Natural). NullableNonEmptyText n -> Encoding
toJSON :: NullableNonEmptyText n -> Value
$ctoJSON :: forall (n :: Natural). NullableNonEmptyText n -> Value
ToJSON)

mkNullableNonEmptyText :: forall n. (KnownNat n, 1 <= n) => Text -> Maybe (NullableNonEmptyText n)
mkNullableNonEmptyText :: forall (n :: Natural).
(KnownNat n, 1 <= n) =>
Text -> Maybe (NullableNonEmptyText n)
mkNullableNonEmptyText Text
t
  | Text -> Int -> Ordering
T.compareLength Text
t (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (n :: Natural) (proxy :: Natural -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy @n)) forall a. Eq a => a -> a -> Bool
== Ordering
GT = 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 :: Natural).
Maybe (NonEmptyText n) -> NullableNonEmptyText n
NullableNonEmptyText forall a b. (a -> b) -> a -> b
$ forall (n :: Natural).
(KnownNat n, 1 <= n) =>
Text -> Maybe (NonEmptyText n)
mkNonEmptyText Text
t

nullNonEmptyText :: NullableNonEmptyText n
nullNonEmptyText :: forall (n :: Natural). NullableNonEmptyText n
nullNonEmptyText = forall (n :: Natural).
Maybe (NonEmptyText n) -> NullableNonEmptyText n
NullableNonEmptyText forall a. Maybe a
Nothing

isNullNonEmptyText :: NullableNonEmptyText n -> Bool
isNullNonEmptyText :: forall (n :: Natural). NullableNonEmptyText n -> Bool
isNullNonEmptyText = (forall a. Eq a => a -> a -> Bool
== forall (n :: Natural). NullableNonEmptyText n
nullNonEmptyText)

instance (KnownNat n, 1 <= n) => FromJSON (NullableNonEmptyText n) where
  parseJSON :: Value -> Parser (NullableNonEmptyText n)
parseJSON = \case
    J.String Text
t -> case forall (n :: Natural).
(KnownNat n, 1 <= 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 => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"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 -> [Char]
show (forall (n :: Natural) (proxy :: Natural -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy @n)) forall a. [a] -> [a] -> [a]
++ [Char]
", but received: " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
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 :: Natural).
Maybe (NonEmptyText n) -> NullableNonEmptyText n
NullableNonEmptyText forall a. Maybe a
Nothing
    Value
x -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"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 -> [Char]
show Value
x

parseNullableNonEmptyText :: (KnownNat n, 1 <= n) => Text -> J.Object -> J.Parser (NullableNonEmptyText n)
parseNullableNonEmptyText :: forall (n :: Natural).
(KnownNat n, 1 <= 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 :: Natural). NullableNonEmptyText n
nullNonEmptyText

fromMaybeNullableText :: Maybe (NullableNonEmptyText n) -> NullableNonEmptyText n
fromMaybeNullableText :: forall (n :: Natural).
Maybe (NullableNonEmptyText n) -> NullableNonEmptyText n
fromMaybeNullableText = forall a. a -> Maybe a -> a
fromMaybe forall (n :: Natural). NullableNonEmptyText n
nullNonEmptyText

nonEmptyTextToNullable :: NonEmptyText n -> NullableNonEmptyText n
nonEmptyTextToNullable :: forall (n :: Natural). NonEmptyText n -> NullableNonEmptyText n
nonEmptyTextToNullable = forall (n :: Natural).
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 :: Natural).
Maybe (NonEmptyText n) -> NullableNonEmptyText n
maybeNonEmptyTextToNullable Maybe (NonEmptyText n)
Nothing = forall (n :: Natural). NullableNonEmptyText n
nullNonEmptyText
maybeNonEmptyTextToNullable Maybe (NonEmptyText n)
jt = forall (n :: Natural).
Maybe (NonEmptyText n) -> NullableNonEmptyText n
NullableNonEmptyText Maybe (NonEmptyText n)
jt

maybeTextToTruncateNullableNonEmptyText :: forall n. (KnownNat n, 1 <= n) => Maybe Text -> NullableNonEmptyText n
maybeTextToTruncateNullableNonEmptyText :: forall (n :: Natural).
(KnownNat n, 1 <= n) =>
Maybe Text -> NullableNonEmptyText n
maybeTextToTruncateNullableNonEmptyText Maybe Text
mText = forall (n :: Natural).
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 :: Natural).
(KnownNat n, 1 <= 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 :: Natural) (proxy :: Natural -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy @n)))

nullableNonEmptyTextToMaybeNonEmptyText :: NullableNonEmptyText n -> Maybe (NonEmptyText n)
nullableNonEmptyTextToMaybeNonEmptyText :: forall (n :: Natural).
NullableNonEmptyText n -> Maybe (NonEmptyText n)
nullableNonEmptyTextToMaybeNonEmptyText (NullableNonEmptyText Maybe (NonEmptyText n)
t) = Maybe (NonEmptyText n)
t

nullableNonEmptyTextToMaybeText :: NullableNonEmptyText n -> Maybe Text
nullableNonEmptyTextToMaybeText :: forall (n :: Natural). NullableNonEmptyText n -> Maybe Text
nullableNonEmptyTextToMaybeText (NullableNonEmptyText Maybe (NonEmptyText n)
t) = forall (n :: Natural). 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 :: [Char] -> Q Exp
quoteExp = [Char] -> Q Exp
compileNullableNonEmptyText'
    , quotePat :: [Char] -> Q Pat
quotePat = forall a. HasCallStack => [Char] -> a
error [Char]
"NullableNonEmptyText is not a pattern; use `nullableNonEmptyTextToMaybeText` instead"
    , quoteDec :: [Char] -> Q [Dec]
quoteDec = forall a. HasCallStack => [Char] -> a
error [Char]
"NullableNonEmptyText is not supported at top-level"
    , quoteType :: [Char] -> Q Type
quoteType = forall a. HasCallStack => [Char] -> a
error [Char]
"NullableNonEmptyText is not supported as a type"
    }
  where
    compileNullableNonEmptyText' :: String -> Q Exp
    compileNullableNonEmptyText' :: [Char] -> Q Exp
compileNullableNonEmptyText' [Char]
s = forall a.
Integer
-> a
-> (forall (n :: Natural) (proxy :: Natural -> *).
    (KnownNat n, 1 <= n) =>
    proxy n -> a)
-> a
usePositiveNat Integer
n Q Exp
errorMessage forall a b. (a -> b) -> a -> b
$ \(proxy n
_ :: proxy n) ->
      case forall (n :: Natural).
(KnownNat n, 1 <= n) =>
Text -> Maybe (NullableNonEmptyText n)
mkNullableNonEmptyText @n ([Char] -> Text
T.pack [Char]
s) of
        Just NullableNonEmptyText n
txt -> [|$(lift txt)|]
        Maybe (NullableNonEmptyText n)
Nothing -> Q Exp
errorMessage
      where
        errorMessage :: Q Exp
errorMessage = forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid NullableNonEmptyText. Needs to be < " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Integer
n forall a. Num a => a -> a -> a
+ Integer
1) forall a. [a] -> [a] -> [a]
++ [Char]
" characters, and not entirely whitespace: " forall a. [a] -> [a] -> [a]
++ [Char]
s

-- | This requires the text to be non-empty. For the empty text just use the constructor `NullableNonEmptyText Nothing`
literalNullableNonEmptyText :: forall (s :: Symbol) (n :: Nat). (KnownSymbol s, KnownNat n, SymbolNonEmpty s, SymbolWithNoSpaceAround s, SymbolNoLongerThan s n) => NullableNonEmptyText n
literalNullableNonEmptyText :: forall (s :: Symbol) (n :: Natural).
(KnownSymbol s, KnownNat n, SymbolNonEmpty s,
 SymbolWithNoSpaceAround s, SymbolNoLongerThan s n) =>
NullableNonEmptyText n
literalNullableNonEmptyText = forall (n :: Natural).
Maybe (NonEmptyText n) -> NullableNonEmptyText n
NullableNonEmptyText (forall a. a -> Maybe a
Just (forall (s :: Symbol) (n :: Natural).
(KnownSymbol s, KnownNat n, SymbolNonEmpty s,
 SymbolWithNoSpaceAround s, SymbolNoLongerThan s n) =>
NonEmptyText n
literalNonEmptyText @s @n))