{-# 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.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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Prose -> Prose -> Bool
$c/= :: Prose -> Prose -> Bool
== :: Prose -> Prose -> Bool
$c== :: Prose -> Prose -> Bool
Eq, 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
liftTyped :: forall (m :: * -> *). Quote m => Prose -> Code m Prose
$cliftTyped :: forall (m :: * -> *). Quote m => Prose -> Code m Prose
lift :: forall (m :: * -> *). Quote m => Prose -> m Exp
$clift :: forall (m :: * -> *). Quote m => Prose -> m Exp
Lift, Eq 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
min :: Prose -> Prose -> Prose
$cmin :: Prose -> Prose -> Prose
max :: Prose -> Prose -> Prose
$cmax :: Prose -> Prose -> Prose
>= :: Prose -> Prose -> Bool
$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
compare :: Prose -> Prose -> Ordering
$ccompare :: Prose -> Prose -> Ordering
Ord, Int -> Prose -> ShowS
[Prose] -> ShowS
Prose -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Prose] -> ShowS
$cshowList :: [Prose] -> ShowS
show :: Prose -> String
$cshow :: Prose -> String
showsPrec :: Int -> Prose -> ShowS
$cshowsPrec :: Int -> Prose -> ShowS
Show)
  deriving newtype (NonEmpty Prose -> Prose
Prose -> Prose -> 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
stimes :: forall b. Integral b => b -> Prose -> Prose
$cstimes :: forall b. Integral b => b -> Prose -> Prose
sconcat :: NonEmpty Prose -> Prose
$csconcat :: NonEmpty Prose -> Prose
<> :: Prose -> Prose -> Prose
$c<> :: Prose -> Prose -> Prose
Semigroup, [Prose] -> Encoding
[Prose] -> Value
Prose -> Encoding
Prose -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Prose] -> Encoding
$ctoEncodingList :: [Prose] -> Encoding
toJSONList :: [Prose] -> Value
$ctoJSONList :: [Prose] -> Value
toEncoding :: Prose -> Encoding
$ctoEncoding :: Prose -> Encoding
toJSON :: Prose -> Value
$ctoJSON :: Prose -> Value
ToJSON, ToJSONKeyFunction [Prose]
ToJSONKeyFunction Prose
forall a.
ToJSONKeyFunction a -> ToJSONKeyFunction [a] -> ToJSONKey a
toJSONKeyList :: ToJSONKeyFunction [Prose]
$ctoJSONKeyList :: ToJSONKeyFunction [Prose]
toJSONKey :: ToJSONKeyFunction Prose
$ctoJSONKey :: 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) = forall a b. ConvertibleStrings a b => a -> b
cs Text
t

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

compileProse :: QuasiQuoter
compileProse :: QuasiQuoter
compileProse =
  QuasiQuoter
    { quoteDec :: String -> Q [Dec]
quoteDec = forall a. HasCallStack => String -> a
error String
"Prose is not supported at top-level"
    , quoteType :: String -> Q Type
quoteType = forall a. HasCallStack => String -> a
error String
"Prose is not supported as a type"
    , quotePat :: String -> Q Pat
quotePat = forall a. HasCallStack => String -> a
error String
"Prose is not a pattern; use `proseToText` instead"
    , 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 -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail (forall {a}. (Semigroup a, IsString a) => a -> a
msg String
s)
      Just Prose
s' -> [|$(lift s')|]

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

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

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