{-# LANGUAGE TemplateHaskell #-}

-- | 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.Text (Text)
import Data.Text qualified as T
import Data.Text.Lazy qualified as LT
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."

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