{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TemplateHaskell #-}

-- GHC considers the constraints for the prose symbol redundant.
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

-- | Internal module of Prose, allowing breaking the abstraction.
--
--   Prefer to use "Data.StringVariants.Prose" instead.
module Data.StringVariants.Prose.Internal where

import Data.Aeson (FromJSON, ToJSON, ToJSONKey, withText)
import Data.Aeson.Types (FromJSON (..))
import Data.String.Conversions (ConvertibleStrings (..), cs)
import Data.StringVariants.NonEmptyText.Internal (NonEmptyText (..))
import Data.StringVariants.Util (SymbolWithNoSpaceAround)
import Data.Proxy
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Lazy qualified as LT
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
import Prelude

-- | Whitespace-trimmed, non-empty text, for use with API endpoints.
-- The rationale is that there are many situations where if a client sends
-- text that is empty or all whitespace, there's probably a client error.
-- Not suitable for database fields, as there is no character limit (see
-- 'ProsePersistFieldMsg').
newtype Prose = Prose Text
  deriving stock (Prose -> Prose -> Bool
(Prose -> Prose -> Bool) -> (Prose -> Prose -> Bool) -> Eq Prose
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Prose -> Prose -> Bool
== :: Prose -> Prose -> Bool
$c/= :: Prose -> Prose -> Bool
/= :: Prose -> Prose -> Bool
Eq, (forall (m :: * -> *). Quote m => Prose -> m Exp)
-> (forall (m :: * -> *). Quote m => Prose -> Code m Prose)
-> Lift Prose
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => Prose -> m Exp
forall (m :: * -> *). Quote m => Prose -> Code m Prose
$clift :: forall (m :: * -> *). Quote m => Prose -> m Exp
lift :: forall (m :: * -> *). Quote m => Prose -> m Exp
$cliftTyped :: forall (m :: * -> *). Quote m => Prose -> Code m Prose
liftTyped :: forall (m :: * -> *). Quote m => Prose -> Code m Prose
Lift, Eq Prose
Eq Prose =>
(Prose -> Prose -> Ordering)
-> (Prose -> Prose -> Bool)
-> (Prose -> Prose -> Bool)
-> (Prose -> Prose -> Bool)
-> (Prose -> Prose -> Bool)
-> (Prose -> Prose -> Prose)
-> (Prose -> Prose -> Prose)
-> Ord Prose
Prose -> Prose -> Bool
Prose -> Prose -> Ordering
Prose -> Prose -> Prose
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Prose -> Prose -> Ordering
compare :: Prose -> Prose -> Ordering
$c< :: Prose -> Prose -> Bool
< :: Prose -> Prose -> Bool
$c<= :: Prose -> Prose -> Bool
<= :: Prose -> Prose -> Bool
$c> :: Prose -> Prose -> Bool
> :: Prose -> Prose -> Bool
$c>= :: Prose -> Prose -> Bool
>= :: Prose -> Prose -> Bool
$cmax :: Prose -> Prose -> Prose
max :: Prose -> Prose -> Prose
$cmin :: Prose -> Prose -> Prose
min :: Prose -> Prose -> Prose
Ord, Int -> Prose -> ShowS
[Prose] -> ShowS
Prose -> String
(Int -> Prose -> ShowS)
-> (Prose -> String) -> ([Prose] -> ShowS) -> Show Prose
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Prose -> ShowS
showsPrec :: Int -> Prose -> ShowS
$cshow :: Prose -> String
show :: Prose -> String
$cshowList :: [Prose] -> ShowS
showList :: [Prose] -> ShowS
Show)
  deriving newtype (NonEmpty Prose -> Prose
Prose -> Prose -> Prose
(Prose -> Prose -> Prose)
-> (NonEmpty Prose -> Prose)
-> (forall b. Integral b => b -> Prose -> Prose)
-> Semigroup Prose
forall b. Integral b => b -> Prose -> Prose
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: Prose -> Prose -> Prose
<> :: Prose -> Prose -> Prose
$csconcat :: NonEmpty Prose -> Prose
sconcat :: NonEmpty Prose -> Prose
$cstimes :: forall b. Integral b => b -> Prose -> Prose
stimes :: forall b. Integral b => b -> Prose -> Prose
Semigroup, [Prose] -> Value
[Prose] -> Encoding
Prose -> Bool
Prose -> Value
Prose -> Encoding
(Prose -> Value)
-> (Prose -> Encoding)
-> ([Prose] -> Value)
-> ([Prose] -> Encoding)
-> (Prose -> Bool)
-> ToJSON Prose
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: Prose -> Value
toJSON :: Prose -> Value
$ctoEncoding :: Prose -> Encoding
toEncoding :: Prose -> Encoding
$ctoJSONList :: [Prose] -> Value
toJSONList :: [Prose] -> Value
$ctoEncodingList :: [Prose] -> Encoding
toEncodingList :: [Prose] -> Encoding
$comitField :: Prose -> Bool
omitField :: Prose -> Bool
ToJSON, ToJSONKeyFunction [Prose]
ToJSONKeyFunction Prose
ToJSONKeyFunction Prose
-> ToJSONKeyFunction [Prose] -> ToJSONKey Prose
forall a.
ToJSONKeyFunction a -> ToJSONKeyFunction [a] -> ToJSONKey a
$ctoJSONKey :: ToJSONKeyFunction Prose
toJSONKey :: ToJSONKeyFunction Prose
$ctoJSONKeyList :: ToJSONKeyFunction [Prose]
toJSONKeyList :: ToJSONKeyFunction [Prose]
ToJSONKey)

instance ConvertibleStrings Prose Text where
  convertString :: Prose -> Text
convertString (Prose Text
t) = Text
t

instance ConvertibleStrings Prose LT.Text where
  convertString :: Prose -> Text
convertString (Prose Text
t) = Text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs Text
t

instance FromJSON Prose where
  parseJSON :: Value -> Parser Prose
parseJSON = String -> (Text -> Parser Prose) -> Value -> Parser Prose
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Prose" ((Text -> Parser Prose) -> Value -> Parser Prose)
-> (Text -> Parser Prose) -> Value -> Parser Prose
forall a b. (a -> b) -> a -> b
$ \Text
t -> case Text -> Maybe Prose
mkProse Text
t of
    Maybe Prose
Nothing -> String -> Parser Prose
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Prose) -> String -> Parser Prose
forall a b. (a -> b) -> a -> b
$ String
"Model/CustomTypes/StringVariants.hs: invalid Prose: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
t
    Just Prose
t' -> Prose -> Parser Prose
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Prose
t'

mkProse :: Text -> Maybe Prose
mkProse :: Text -> Maybe Prose
mkProse Text
t = case Text -> Text
T.strip Text
t of
  Text
"" -> Maybe Prose
forall a. Maybe a
Nothing
  Text
t' -> Prose -> Maybe Prose
forall a. a -> Maybe a
Just (Text -> Prose
Prose Text
t')

proseFromNonEmptyText :: NonEmptyText n -> Prose
proseFromNonEmptyText :: forall (n :: Nat). NonEmptyText n -> Prose
proseFromNonEmptyText (NonEmptyText Text
t) = Text -> Prose
Prose (Text -> Text
T.strip Text
t)

compileProse :: QuasiQuoter
compileProse :: QuasiQuoter
compileProse =
  QuasiQuoter
    { quoteDec :: String -> Q [Dec]
quoteDec = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"Prose is not supported at top-level"
    , quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"Prose is not supported as a type"
    , quotePat :: String -> Q Pat
quotePat = String -> String -> Q Pat
forall a. HasCallStack => String -> a
error String
"Prose is not a pattern; use `proseToText` instead"
    , String -> Q Exp
forall {m :: * -> *}. (MonadFail m, Quote m) => String -> m Exp
quoteExp :: String -> Q Exp
quoteExp :: forall {m :: * -> *}. (MonadFail m, Quote m) => String -> m Exp
..
    }
  where
    quoteExp :: String -> m Exp
quoteExp String
s = case Text -> Maybe Prose
mkProse (String -> Text
T.pack String
s) of
      Maybe Prose
Nothing -> String -> m Exp
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (ShowS
forall {a}. (Semigroup a, IsString a) => a -> a
msg String
s)
      Just Prose
s' -> [|$(Prose -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Prose -> m Exp
lift Prose
s')|]

    msg :: a -> a
msg a
s = a
"Invalid Prose: " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
s a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
". Make sure you aren't wrapping the text in quotes."

type IsProse s =
  ( KnownSymbol s
  , SymbolWithNoSpaceAround s
  )

literalProse :: forall (s :: Symbol). IsProse s => Prose
literalProse :: forall (s :: Symbol). IsProse s => Prose
literalProse = Text -> Prose
Prose (String -> Text
T.pack (Proxy s -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @s)))

proseToText :: Prose -> Text
proseToText :: Prose -> Text
proseToText (Prose Text
txt) = Text
txt