{-# 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,
    unsafeMkNonEmptyText,
    nonEmptyTextToText,
    compileNonEmptyText,
    compileNonEmptyTextKnownLength,
    convertEmptyTextToNothing,

    -- * Conversion
    widen,

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

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

    -- * Convenience util if you need a NonEmptyText of a dynamically determined lengths
    useNat,
    natOfLength,
  )
where

import Control.Monad
import Data.Data (Proxy (..), typeRep)
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, natVal, 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 :: String -> Q Exp
quoteExp = String -> Q Exp
compileNonEmptyText'
    , quotePat :: String -> Q Pat
quotePat = forall a. HasCallStack => String -> a
error String
"NonEmptyText is not a pattern; use nonEmptyTextToText instead"
    , quoteDec :: String -> Q [Dec]
quoteDec = forall a. HasCallStack => String -> a
error String
"NonEmptyText is not supported at top-level"
    , quoteType :: String -> Q Type
quoteType = forall a. HasCallStack => String -> a
error String
"NonEmptyText is not supported as a type"
    }
  where
    compileNonEmptyText' :: String -> Q Exp
    compileNonEmptyText' :: String -> Q Exp
compileNonEmptyText' 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 (NonEmptyText n)
mkNonEmptyText (String -> Text
T.pack String
s) of
        Maybe (NonEmptyText n)
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Invalid NonEmptyText. 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 NonEmptyText n
txt -> [|$(lift txt) :: NonEmptyText $(pure $ LitT $ NumTyLit n)|]

convertEmptyTextToNothing :: Text -> Maybe Text
convertEmptyTextToNothing :: Text -> Maybe Text
convertEmptyTextToNothing Text
t
  | Text -> Bool
textIsWhitespace Text
t = forall a. Maybe a
Nothing
  | Bool
otherwise = 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.
filterNonEmptyText :: (Char -> Bool) -> NonEmptyText n -> NonEmptyText n
filterNonEmptyText :: forall (n :: Nat).
(Char -> Bool) -> NonEmptyText n -> NonEmptyText n
filterNonEmptyText Char -> Bool
f (NonEmptyText Text
t) = forall (n :: Nat). Text -> NonEmptyText n
NonEmptyText ((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, n <= m) => NonEmptyText m -> NonEmptyText n
takeNonEmptyText :: forall (m :: Nat) (n :: Nat).
(KnownNat m, KnownNat n, n <= m) =>
NonEmptyText m -> NonEmptyText n
takeNonEmptyText (NonEmptyText Text
t) =
  if Int
m forall a. Eq a => a -> a -> Bool
== Int
n
    then forall (n :: Nat). Text -> NonEmptyText n
NonEmptyText Text
t
    else forall (n :: Nat). Text -> NonEmptyText n
NonEmptyText forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.take Int
n Text
t
  where
    m :: Int
m = 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 @m)
    n :: Int
n = 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)

-- | Narrows the maximum length, dropping any prefix remaining characters.
takeNonEmptyTextEnd :: forall m n. (KnownNat m, KnownNat n, n <= m) => NonEmptyText m -> NonEmptyText n
takeNonEmptyTextEnd :: forall (m :: Nat) (n :: Nat).
(KnownNat m, KnownNat n, n <= m) =>
NonEmptyText m -> NonEmptyText n
takeNonEmptyTextEnd (NonEmptyText Text
t) =
  if Int
m forall a. Eq a => a -> a -> Bool
== Int
n
    then forall (n :: Nat). Text -> NonEmptyText n
NonEmptyText Text
t
    else forall (n :: Nat). Text -> NonEmptyText n
NonEmptyText forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.takeEnd Int
n Text
t
  where
    m :: Int
m = 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 @m)
    n :: Int
n = 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)

-- | /O(n)/ Splits a 'NonEmptyText' into components of length @chunkSize@. The
-- last element may be shorter than the other chunks, depending on the length
-- of the input.
chunksOfNonEmptyText ::
  forall chunkSize totalSize.
  (KnownNat chunkSize, KnownNat totalSize) =>
  NonEmptyText totalSize ->
  [NonEmptyText chunkSize]
chunksOfNonEmptyText :: forall (chunkSize :: Nat) (totalSize :: Nat).
(KnownNat chunkSize, KnownNat totalSize) =>
NonEmptyText totalSize -> [NonEmptyText chunkSize]
chunksOfNonEmptyText (NonEmptyText Text
t) =
  forall a b. (a -> b) -> [a] -> [b]
map forall (n :: Nat). Text -> NonEmptyText n
NonEmptyText (Int -> Text -> [Text]
T.chunksOf Int
chunkSize Text
t)
  where
    chunkSize :: Int
chunkSize = 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 @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) = forall (n :: Nat). Text -> NonEmptyText n
NonEmptyText (Text
l forall a. Semigroup a => a -> a -> a
<> Text
r)

-- Refinery

data ContainsNonWhitespaceCharacters = ContainsNonWhitespaceCharacters
  deriving stock (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
$cto :: forall x.
Rep ContainsNonWhitespaceCharacters x
-> ContainsNonWhitespaceCharacters
$cfrom :: forall x.
ContainsNonWhitespaceCharacters
-> Rep ContainsNonWhitespaceCharacters x
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 (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 = 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 = forall (n :: Nat). Text -> NonEmptyText n
NonEmptyText forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (n :: Nat). Text -> NonEmptyText n
NonEmptyText forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall {k} x (p :: k). x -> Refined p x
reallyUnsafeRefine forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (n :: Nat). NonEmptyText n -> Text
nonEmptyTextToText