{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

-- | NonEmptyText: Text that is known not to be either the empty string, or pure
--   whitespace.

module Data.StringVariants.NonEmptyText
  ( -- * Non empty text
    NonEmptyText,
    type (<=),

    -- * Construction
    mkNonEmptyText,
    mkNonEmptyTextWithTruncate,
    IsNonEmptyText,
    literalNonEmptyText,
    unsafeMkNonEmptyText,
    compileNonEmptyText,
    compileNonEmptyTextKnownLength,
    convertEmptyTextToNothing,

    -- * Conversion
    widen,
    nonEmptyTextToText,

    -- * Functions
    takeNonEmptyText,
    takeNonEmptyTextEnd,
    chunksOfNonEmptyText,
    filterNonEmptyText,
    (<>|),
    concatWithSpace,

    -- * Conversions between 'Refined' and 'NonEmptyText'.
    ContainsNonWhitespaceCharacters (..),
    exactLengthRefinedToRange,
    nonEmptyTextFromRefined,
    refinedFromNonEmptyText,
  )
where

import Control.Monad
import Data.Data (Proxy (..), typeRep)
import Data.List.NonEmpty qualified as NE
import Data.Maybe (mapMaybe)
import Data.StringVariants.NonEmptyText.Internal
import Data.StringVariants.Util
import Data.Text (Text)
import Data.Text qualified as T
import GHC.Generics (Generic)
import GHC.TypeLits (KnownNat, KnownSymbol, Symbol, Nat, natVal, symbolVal, type (+), type (<=))
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax (Lift (..))
import Refined
import Refined.Unsafe (reallyUnsafeRefine)
import Prelude

compileNonEmptyText :: Integer -> QuasiQuoter
compileNonEmptyText :: Integer -> QuasiQuoter
compileNonEmptyText Integer
n =
  QuasiQuoter
    { quoteExp :: [Char] -> Q Exp
quoteExp = [Char] -> Q Exp
compileNonEmptyText'
    , quotePat :: [Char] -> Q Pat
quotePat = [Char] -> [Char] -> Q Pat
forall a. HasCallStack => [Char] -> a
error [Char]
"NonEmptyText is not a pattern; use nonEmptyTextToText instead"
    , quoteDec :: [Char] -> Q [Dec]
quoteDec = [Char] -> [Char] -> Q [Dec]
forall a. HasCallStack => [Char] -> a
error [Char]
"NonEmptyText is not supported at top-level"
    , quoteType :: [Char] -> Q Type
quoteType = [Char] -> [Char] -> Q Type
forall a. HasCallStack => [Char] -> a
error [Char]
"NonEmptyText is not supported as a type"
    }
  where
    compileNonEmptyText' :: String -> Q Exp
    compileNonEmptyText' :: [Char] -> Q Exp
compileNonEmptyText' [Char]
s = Integer
-> Q Exp
-> (forall {n :: Nat} {proxy :: Nat -> *}.
    (KnownNat n, 1 <= n) =>
    proxy n -> Q Exp)
-> Q Exp
forall a.
Integer
-> a
-> (forall (n :: Nat) (proxy :: Nat -> *).
    (KnownNat n, 1 <= n) =>
    proxy n -> a)
-> a
usePositiveNat Integer
n Q Exp
errorMessage ((forall {n :: Nat} {proxy :: Nat -> *}.
  (KnownNat n, 1 <= n) =>
  proxy n -> Q Exp)
 -> Q Exp)
-> (forall {n :: Nat} {proxy :: Nat -> *}.
    (KnownNat n, 1 <= n) =>
    proxy n -> Q Exp)
-> Q Exp
forall a b. (a -> b) -> a -> b
$ \(proxy n
_ :: proxy n) ->
      case forall (n :: Nat).
(KnownNat n, 1 <= n) =>
Text -> Maybe (NonEmptyText n)
mkNonEmptyText @n ([Char] -> Text
T.pack [Char]
s) of
        Just NonEmptyText n
txt -> [|$(NonEmptyText n -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => NonEmptyText n -> m Exp
lift NonEmptyText n
txt) :: NonEmptyText $(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ TyLit -> Type
LitT (TyLit -> Type) -> TyLit -> Type
forall a b. (a -> b) -> a -> b
$ Integer -> TyLit
NumTyLit Integer
n)|]
        Maybe (NonEmptyText n)
Nothing -> Q Exp
errorMessage
      where
        errorMessage :: Q Exp
errorMessage = [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q Exp) -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid NonEmptyText. Needs to be < " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Integer -> [Char]
forall a. Show a => a -> [Char]
show (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" characters, and not entirely whitespace: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s

type IsNonEmptyText n s =
  ( KnownSymbol s
  , KnownNat n
  , SymbolNonEmpty s
  , SymbolWithNoSpaceAround s
  , SymbolNoLongerThan s n
  )

literalNonEmptyText :: forall (s :: Symbol) (n :: Nat). IsNonEmptyText n s => NonEmptyText n
literalNonEmptyText :: forall (s :: Symbol) (n :: Nat).
IsNonEmptyText n s =>
NonEmptyText n
literalNonEmptyText = Text -> NonEmptyText n
forall (n :: Nat). Text -> NonEmptyText n
NonEmptyText ([Char] -> Text
T.pack (Proxy s -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @s)))

convertEmptyTextToNothing :: Text -> Maybe Text
convertEmptyTextToNothing :: Text -> Maybe Text
convertEmptyTextToNothing Text
t
  | Text -> Bool
textIsWhitespace Text
t = Maybe Text
forall a. Maybe a
Nothing
  | Bool
otherwise = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t

nonEmptyTextToText :: NonEmptyText n -> Text
nonEmptyTextToText :: forall (n :: Nat). NonEmptyText n -> Text
nonEmptyTextToText (NonEmptyText Text
t) = Text
t

-- | Identical to the normal text filter function, but maintains the type-level invariant
-- that the text length is <= n, unlike unwrapping the text, filtering, then
-- rewrapping the text.
--
-- Will return Nothing if the resulting length is zero.
filterNonEmptyText :: (KnownNat n, 1 <= n) => (Char -> Bool) -> NonEmptyText n -> Maybe (NonEmptyText n)
filterNonEmptyText :: forall (n :: Nat).
(KnownNat n, 1 <= n) =>
(Char -> Bool) -> NonEmptyText n -> Maybe (NonEmptyText n)
filterNonEmptyText Char -> Bool
f (NonEmptyText Text
t) = Text -> Maybe (NonEmptyText n)
forall (n :: Nat).
(KnownNat n, 1 <= n) =>
Text -> Maybe (NonEmptyText n)
mkNonEmptyText ((Char -> Bool) -> Text -> Text
T.filter Char -> Bool
f Text
t)

-- | Narrows the maximum length, dropping any remaining trailing characters.
takeNonEmptyText :: forall m n. (KnownNat m, KnownNat n, 1 <= n, n <= m) => NonEmptyText m -> NonEmptyText n
takeNonEmptyText :: forall (m :: Nat) (n :: Nat).
(KnownNat m, KnownNat n, 1 <= n, n <= m) =>
NonEmptyText m -> NonEmptyText n
takeNonEmptyText (NonEmptyText Text
t) =
  if Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n
    then Text -> NonEmptyText n
forall (n :: Nat). Text -> NonEmptyText n
NonEmptyText Text
t
    -- when the input is stripped, taking from it is guaranteed to be not empty
    else Text -> NonEmptyText n
forall (n :: Nat). Text -> NonEmptyText n
NonEmptyText (Text -> NonEmptyText n) -> Text -> NonEmptyText n
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.stripEnd (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.take Int
n Text
t
  where
    m :: Int
m = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Proxy m -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @m)
    n :: Int
n = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Proxy n -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @n)

-- | Narrows the maximum length, dropping any prefix remaining characters.
takeNonEmptyTextEnd :: forall m n. (KnownNat m, KnownNat n, 1 <= n, n <= m) => NonEmptyText m -> NonEmptyText n
takeNonEmptyTextEnd :: forall (m :: Nat) (n :: Nat).
(KnownNat m, KnownNat n, 1 <= n, n <= m) =>
NonEmptyText m -> NonEmptyText n
takeNonEmptyTextEnd (NonEmptyText Text
t) =
  if Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n
    then Text -> NonEmptyText n
forall (n :: Nat). Text -> NonEmptyText n
NonEmptyText Text
t
    -- when the input is stripped, taking from it is guaranteed to be not empty
    else Text -> NonEmptyText n
forall (n :: Nat). Text -> NonEmptyText n
NonEmptyText (Text -> NonEmptyText n) -> Text -> NonEmptyText n
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.stripStart (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.takeEnd Int
n Text
t
  where
    m :: Int
m = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Proxy m -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @m)
    n :: Int
n = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Proxy n -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @n)

-- | /O(n)/ Splits a 'NonEmptyText' into components of length @chunkSize@. The
-- chunks may be shorter than the chunkSize depending on the length
-- of the input and spacing. Each chunk is stripped of whitespace.
chunksOfNonEmptyText ::
  forall chunkSize totalSize.
  (KnownNat chunkSize, KnownNat totalSize, chunkSize <= totalSize, 1 <= chunkSize) =>
  NonEmptyText totalSize ->
  NE.NonEmpty (NonEmptyText chunkSize)
chunksOfNonEmptyText :: forall (chunkSize :: Nat) (totalSize :: Nat).
(KnownNat chunkSize, KnownNat totalSize, chunkSize <= totalSize,
 1 <= chunkSize) =>
NonEmptyText totalSize -> NonEmpty (NonEmptyText chunkSize)
chunksOfNonEmptyText (NonEmptyText Text
t) =
  case Maybe (NonEmpty (NonEmptyText chunkSize))
mNonEmptyChunks of
    Maybe (NonEmpty (NonEmptyText chunkSize))
Nothing -> [Char] -> NonEmpty (NonEmptyText chunkSize)
forall a. HasCallStack => [Char] -> a
error ([Char] -> NonEmpty (NonEmptyText chunkSize))
-> [Char] -> NonEmpty (NonEmptyText chunkSize)
forall a b. (a -> b) -> a -> b
$ [Char]
"chunksOfNonEmptyText: invalid input: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
forall a. Show a => a -> [Char]
show Text
t
    Just NonEmpty (NonEmptyText chunkSize)
chunks -> NonEmpty (NonEmptyText chunkSize)
chunks
  where
    -- The function NE.nonEmpty is safer than partial NE.fromList.
    -- If the input NonEmptyText is invalid, we want to return a detailed error message.
    mNonEmptyChunks :: Maybe (NonEmpty (NonEmptyText chunkSize))
mNonEmptyChunks = [NonEmptyText chunkSize]
-> Maybe (NonEmpty (NonEmptyText chunkSize))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([NonEmptyText chunkSize]
 -> Maybe (NonEmpty (NonEmptyText chunkSize)))
-> [NonEmptyText chunkSize]
-> Maybe (NonEmpty (NonEmptyText chunkSize))
forall a b. (a -> b) -> a -> b
$ (Text -> Maybe (NonEmptyText chunkSize))
-> [Text] -> [NonEmptyText chunkSize]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe (NonEmptyText chunkSize)
forall (n :: Nat).
(KnownNat n, 1 <= n) =>
Text -> Maybe (NonEmptyText n)
mkNonEmptyText (Int -> Text -> [Text]
T.chunksOf Int
chunkSize Text
t)
    chunkSize :: Int
chunkSize = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Proxy chunkSize -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @chunkSize)

-- | Concat two NonEmptyText values, with the new maximum length being the sum of the two
-- maximum lengths of the inputs.
--
-- Mnemonic: @<>@ for monoid, @|@ from NonEmpty's ':|' operator
(<>|) :: NonEmptyText n -> NonEmptyText m -> NonEmptyText (n + m)
(NonEmptyText Text
l) <>| :: forall (n :: Nat) (m :: Nat).
NonEmptyText n -> NonEmptyText m -> NonEmptyText (n + m)
<>| (NonEmptyText Text
r) = Text -> NonEmptyText (n + m)
forall (n :: Nat). Text -> NonEmptyText n
NonEmptyText (Text
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r)

-- | Concat two 'NonEmptyText' values with a space in between them. The new
-- maximum length is the sum of the two maximum lengths of the inputs + 1 for
-- the space.
--
-- Useful for 'unwords'like operations, or combining first and last names.
concatWithSpace :: NonEmptyText n -> NonEmptyText m -> NonEmptyText (n + m + 1)
concatWithSpace :: forall (n :: Nat) (m :: Nat).
NonEmptyText n -> NonEmptyText m -> NonEmptyText ((n + m) + 1)
concatWithSpace (NonEmptyText Text
l)  (NonEmptyText Text
r) = Text -> NonEmptyText ((n + m) + 1)
forall (n :: Nat). Text -> NonEmptyText n
NonEmptyText (Text
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r)

-- Refinery

data ContainsNonWhitespaceCharacters = ContainsNonWhitespaceCharacters
  deriving stock ((forall x.
 ContainsNonWhitespaceCharacters
 -> Rep ContainsNonWhitespaceCharacters x)
-> (forall x.
    Rep ContainsNonWhitespaceCharacters x
    -> ContainsNonWhitespaceCharacters)
-> Generic ContainsNonWhitespaceCharacters
forall x.
Rep ContainsNonWhitespaceCharacters x
-> ContainsNonWhitespaceCharacters
forall x.
ContainsNonWhitespaceCharacters
-> Rep ContainsNonWhitespaceCharacters x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x.
ContainsNonWhitespaceCharacters
-> Rep ContainsNonWhitespaceCharacters x
from :: forall x.
ContainsNonWhitespaceCharacters
-> Rep ContainsNonWhitespaceCharacters x
$cto :: forall x.
Rep ContainsNonWhitespaceCharacters x
-> ContainsNonWhitespaceCharacters
to :: forall x.
Rep ContainsNonWhitespaceCharacters x
-> ContainsNonWhitespaceCharacters
Generic)

instance Predicate ContainsNonWhitespaceCharacters Text where
  validate :: Proxy ContainsNonWhitespaceCharacters
-> Text -> Maybe RefineException
validate Proxy ContainsNonWhitespaceCharacters
p Text
txt
    | Text -> Bool
textHasNoMeaningfulContent Text
txt = TypeRep -> Text -> Maybe RefineException
throwRefineOtherException (Proxy ContainsNonWhitespaceCharacters -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Proxy ContainsNonWhitespaceCharacters
p) Text
"All characters in Text input are whitespace or control characters"
    | Bool
otherwise = Maybe RefineException
forall a. Maybe a
Nothing

exactLengthRefinedToRange :: Refined (ContainsNonWhitespaceCharacters && SizeEqualTo n) Text -> NonEmptyText n
exactLengthRefinedToRange :: forall (n :: Nat).
Refined (ContainsNonWhitespaceCharacters && SizeEqualTo n) Text
-> NonEmptyText n
exactLengthRefinedToRange = Text -> NonEmptyText n
forall (n :: Nat). Text -> NonEmptyText n
NonEmptyText (Text -> NonEmptyText n)
-> (Refined (ContainsNonWhitespaceCharacters && SizeEqualTo n) Text
    -> Text)
-> Refined (ContainsNonWhitespaceCharacters && SizeEqualTo n) Text
-> NonEmptyText n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Refined (ContainsNonWhitespaceCharacters && SizeEqualTo n) Text
-> Text
forall {k} (p :: k) x. Refined p x -> x
unrefine

nonEmptyTextFromRefined :: Refined (ContainsNonWhitespaceCharacters && (SizeLessThan n || SizeEqualTo n)) Text -> NonEmptyText n
nonEmptyTextFromRefined :: forall (n :: Nat).
Refined
  (ContainsNonWhitespaceCharacters
   && (SizeLessThan n || SizeEqualTo n))
  Text
-> NonEmptyText n
nonEmptyTextFromRefined = Text -> NonEmptyText n
forall (n :: Nat). Text -> NonEmptyText n
NonEmptyText (Text -> NonEmptyText n)
-> (Refined
      (ContainsNonWhitespaceCharacters
       && (SizeLessThan n || SizeEqualTo n))
      Text
    -> Text)
-> Refined
     (ContainsNonWhitespaceCharacters
      && (SizeLessThan n || SizeEqualTo n))
     Text
-> NonEmptyText n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Refined
  (ContainsNonWhitespaceCharacters
   && (SizeLessThan n || SizeEqualTo n))
  Text
-> Text
forall {k} (p :: k) x. Refined p x -> x
unrefine

refinedFromNonEmptyText :: NonEmptyText n -> Refined (ContainsNonWhitespaceCharacters && (SizeLessThan n || SizeEqualTo n)) Text
refinedFromNonEmptyText :: forall (n :: Nat).
NonEmptyText n
-> Refined
     (ContainsNonWhitespaceCharacters
      && (SizeLessThan n || SizeEqualTo n))
     Text
refinedFromNonEmptyText = Text
-> Refined
     (ContainsNonWhitespaceCharacters
      && (SizeLessThan n || SizeEqualTo n))
     Text
forall {k} x (p :: k). x -> Refined p x
reallyUnsafeRefine (Text
 -> Refined
      (ContainsNonWhitespaceCharacters
       && (SizeLessThan n || SizeEqualTo n))
      Text)
-> (NonEmptyText n -> Text)
-> NonEmptyText n
-> Refined
     (ContainsNonWhitespaceCharacters
      && (SizeLessThan n || SizeEqualTo n))
     Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmptyText n -> Text
forall (n :: Nat). NonEmptyText n -> Text
nonEmptyTextToText