-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

-- deriving 'Container' automatically produces extra constraints.
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

-- | Strings compliant with Michelson constraints.
--
-- When writting a Michelson contract, you can only mention characters with
-- codes from @[32 .. 126]@ range in string literals. Same restriction applies
-- to string literals passed to @octez-client@.
--
-- However, Michelson allows some control sequences: @"\n"@. You have to write
-- it exactly in this form, and internally it will be transformed to line feed
-- character (this behaviour can be observed when looking at @Pack@ed data).
--
-- See tests for examples of good and bad strings.
module Morley.Michelson.Text
  ( MText (..)
  , mkMText
  , mkMTextCut
  , writeMText
  , takeMText
  , dropMText
  , isMChar
  , minBoundMChar
  , maxBoundMChar

    -- * Misc
  , qqMText
  , mt
  , DoNotUseTextError
  , symbolToMText
  , labelToMText
  , mtextHeadToUpper
  ) where

import Data.Aeson (FromJSON(..), ToJSON(..))
import Data.Char qualified as C
import Data.Data (Data)
import Data.Text qualified as T
import Fmt (Buildable)
import Language.Haskell.TH qualified as TH
import Language.Haskell.TH.Quote qualified as TH
import Type.Errors (DelayError)

import Morley.Util.CLI
import Morley.Util.Label (Label(..), labelToText)
import Morley.Util.TypeLits

-- | Michelson string value.
--
-- This is basically a mere text with limits imposed by the language:
-- <https://tezos.gitlab.io/whitedoc/michelson.html#constants>
-- Although, this document seems to be not fully correct, and thus we applied
-- constraints deduced empirically.
--
-- You construct an item of this type using one of the following ways:
--
-- * With QuasyQuotes when need to create a string literal.
--
-- >>> [mt|Some text|]
-- UnsafeMText {unMText = "Some text"}
--
-- * With 'mkMText' when constructing from a runtime text value.
--
-- * With 'UnsafeMText' when absolutelly sure that
-- given string does not violate invariants.
--
-- * With 'mkMTextCut' when not sure about text contents and want
-- to make it compliant with Michelson constraints.
newtype MText = UnsafeMText { MText -> Text
unMText :: Text }
  deriving stock (Int -> MText -> ShowS
[MText] -> ShowS
MText -> [Char]
(Int -> MText -> ShowS)
-> (MText -> [Char]) -> ([MText] -> ShowS) -> Show MText
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [MText] -> ShowS
$cshowList :: [MText] -> ShowS
show :: MText -> [Char]
$cshow :: MText -> [Char]
showsPrec :: Int -> MText -> ShowS
$cshowsPrec :: Int -> MText -> ShowS
Show, MText -> MText -> Bool
(MText -> MText -> Bool) -> (MText -> MText -> Bool) -> Eq MText
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MText -> MText -> Bool
$c/= :: MText -> MText -> Bool
== :: MText -> MText -> Bool
$c== :: MText -> MText -> Bool
Eq, Eq MText
Eq MText
-> (MText -> MText -> Ordering)
-> (MText -> MText -> Bool)
-> (MText -> MText -> Bool)
-> (MText -> MText -> Bool)
-> (MText -> MText -> Bool)
-> (MText -> MText -> MText)
-> (MText -> MText -> MText)
-> Ord MText
MText -> MText -> Bool
MText -> MText -> Ordering
MText -> MText -> MText
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 :: MText -> MText -> MText
$cmin :: MText -> MText -> MText
max :: MText -> MText -> MText
$cmax :: MText -> MText -> MText
>= :: MText -> MText -> Bool
$c>= :: MText -> MText -> Bool
> :: MText -> MText -> Bool
$c> :: MText -> MText -> Bool
<= :: MText -> MText -> Bool
$c<= :: MText -> MText -> Bool
< :: MText -> MText -> Bool
$c< :: MText -> MText -> Bool
compare :: MText -> MText -> Ordering
$ccompare :: MText -> MText -> Ordering
Ord, Typeable MText
Typeable MText
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> MText -> c MText)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c MText)
-> (MText -> Constr)
-> (MText -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c MText))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c MText))
-> ((forall b. Data b => b -> b) -> MText -> MText)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> MText -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> MText -> r)
-> (forall u. (forall d. Data d => d -> u) -> MText -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> MText -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> MText -> m MText)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> MText -> m MText)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> MText -> m MText)
-> Data MText
MText -> DataType
MText -> Constr
(forall b. Data b => b -> b) -> MText -> MText
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> MText -> u
forall u. (forall d. Data d => d -> u) -> MText -> [u]
forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> MText -> r
forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> MText -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> MText -> m MText
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> MText -> m MText
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c MText
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> MText -> c MText
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c MText)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c MText)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> MText -> m MText
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> MText -> m MText
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> MText -> m MText
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> MText -> m MText
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> MText -> m MText
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> MText -> m MText
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> MText -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> MText -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> MText -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> MText -> [u]
gmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> MText -> r
$cgmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> MText -> r
gmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> MText -> r
$cgmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> MText -> r
gmapT :: (forall b. Data b => b -> b) -> MText -> MText
$cgmapT :: (forall b. Data b => b -> b) -> MText -> MText
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c MText)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c MText)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c MText)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c MText)
dataTypeOf :: MText -> DataType
$cdataTypeOf :: MText -> DataType
toConstr :: MText -> Constr
$ctoConstr :: MText -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c MText
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c MText
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> MText -> c MText
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> MText -> c MText
Data, (forall x. MText -> Rep MText x)
-> (forall x. Rep MText x -> MText) -> Generic MText
forall x. Rep MText x -> MText
forall x. MText -> Rep MText x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MText x -> MText
$cfrom :: forall x. MText -> Rep MText x
Generic)
  deriving newtype (NonEmpty MText -> MText
MText -> MText -> MText
(MText -> MText -> MText)
-> (NonEmpty MText -> MText)
-> (forall b. Integral b => b -> MText -> MText)
-> Semigroup MText
forall b. Integral b => b -> MText -> MText
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> MText -> MText
$cstimes :: forall b. Integral b => b -> MText -> MText
sconcat :: NonEmpty MText -> MText
$csconcat :: NonEmpty MText -> MText
<> :: MText -> MText -> MText
$c<> :: MText -> MText -> MText
Semigroup, Semigroup MText
MText
Semigroup MText
-> MText
-> (MText -> MText -> MText)
-> ([MText] -> MText)
-> Monoid MText
[MText] -> MText
MText -> MText -> MText
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [MText] -> MText
$cmconcat :: [MText] -> MText
mappend :: MText -> MText -> MText
$cmappend :: MText -> MText -> MText
mempty :: MText
$cmempty :: MText
Monoid, Eq (Element MText) => Element MText -> MText -> Bool
Ord (Element MText) => MText -> Maybe (Element MText)
Monoid (Element MText) => MText -> Element MText
(Element MText ~ Bool) => MText -> Bool
MText -> Bool
MText -> Int
MText -> [Element MText]
MText -> Maybe (Element MText)
(Element MText -> Bool) -> MText -> Bool
(Element MText -> Bool) -> MText -> Maybe (Element MText)
(Element MText -> Element MText -> Element MText)
-> MText -> Maybe (Element MText)
(MText -> [Element MText])
-> (MText -> Bool)
-> (forall b. (Element MText -> b -> b) -> b -> MText -> b)
-> (forall b. (b -> Element MText -> b) -> b -> MText -> b)
-> (forall b. (b -> Element MText -> b) -> b -> MText -> b)
-> (MText -> Int)
-> (Eq (Element MText) => Element MText -> MText -> Bool)
-> (forall m. Monoid m => (Element MText -> m) -> MText -> m)
-> (Monoid (Element MText) => MText -> Element MText)
-> (forall b. (Element MText -> b -> b) -> b -> MText -> b)
-> (Eq (Element MText) => Element MText -> MText -> Bool)
-> ((Element MText -> Bool) -> MText -> Bool)
-> ((Element MText -> Bool) -> MText -> Bool)
-> ((Element MText ~ Bool) => MText -> Bool)
-> ((Element MText ~ Bool) => MText -> Bool)
-> ((Element MText -> Bool) -> MText -> Maybe (Element MText))
-> (MText -> Maybe (Element MText))
-> (Ord (Element MText) => MText -> Maybe (Element MText))
-> (Ord (Element MText) => MText -> Maybe (Element MText))
-> ((Element MText -> Element MText -> Element MText)
    -> MText -> Maybe (Element MText))
-> ((Element MText -> Element MText -> Element MText)
    -> MText -> Maybe (Element MText))
-> Container MText
forall m. Monoid m => (Element MText -> m) -> MText -> m
forall t.
(t -> [Element t])
-> (t -> Bool)
-> (forall b. (Element t -> b -> b) -> b -> t -> b)
-> (forall b. (b -> Element t -> b) -> b -> t -> b)
-> (forall b. (b -> Element t -> b) -> b -> t -> b)
-> (t -> Int)
-> (Eq (Element t) => Element t -> t -> Bool)
-> (forall m. Monoid m => (Element t -> m) -> t -> m)
-> (Monoid (Element t) => t -> Element t)
-> (forall b. (Element t -> b -> b) -> b -> t -> b)
-> (Eq (Element t) => Element t -> t -> Bool)
-> ((Element t -> Bool) -> t -> Bool)
-> ((Element t -> Bool) -> t -> Bool)
-> ((Element t ~ Bool) => t -> Bool)
-> ((Element t ~ Bool) => t -> Bool)
-> ((Element t -> Bool) -> t -> Maybe (Element t))
-> (t -> Maybe (Element t))
-> (Ord (Element t) => t -> Maybe (Element t))
-> (Ord (Element t) => t -> Maybe (Element t))
-> ((Element t -> Element t -> Element t)
    -> t -> Maybe (Element t))
-> ((Element t -> Element t -> Element t)
    -> t -> Maybe (Element t))
-> Container t
forall b. (b -> Element MText -> b) -> b -> MText -> b
forall b. (Element MText -> b -> b) -> b -> MText -> b
safeFoldl1 :: (Element MText -> Element MText -> Element MText)
-> MText -> Maybe (Element MText)
$csafeFoldl1 :: (Element MText -> Element MText -> Element MText)
-> MText -> Maybe (Element MText)
safeFoldr1 :: (Element MText -> Element MText -> Element MText)
-> MText -> Maybe (Element MText)
$csafeFoldr1 :: (Element MText -> Element MText -> Element MText)
-> MText -> Maybe (Element MText)
safeMinimum :: Ord (Element MText) => MText -> Maybe (Element MText)
$csafeMinimum :: Ord (Element MText) => MText -> Maybe (Element MText)
safeMaximum :: Ord (Element MText) => MText -> Maybe (Element MText)
$csafeMaximum :: Ord (Element MText) => MText -> Maybe (Element MText)
safeHead :: MText -> Maybe (Element MText)
$csafeHead :: MText -> Maybe (Element MText)
find :: (Element MText -> Bool) -> MText -> Maybe (Element MText)
$cfind :: (Element MText -> Bool) -> MText -> Maybe (Element MText)
or :: (Element MText ~ Bool) => MText -> Bool
$cor :: (Element MText ~ Bool) => MText -> Bool
and :: (Element MText ~ Bool) => MText -> Bool
$cand :: (Element MText ~ Bool) => MText -> Bool
any :: (Element MText -> Bool) -> MText -> Bool
$cany :: (Element MText -> Bool) -> MText -> Bool
all :: (Element MText -> Bool) -> MText -> Bool
$call :: (Element MText -> Bool) -> MText -> Bool
notElem :: Eq (Element MText) => Element MText -> MText -> Bool
$cnotElem :: Eq (Element MText) => Element MText -> MText -> Bool
foldr' :: forall b. (Element MText -> b -> b) -> b -> MText -> b
$cfoldr' :: forall b. (Element MText -> b -> b) -> b -> MText -> b
fold :: Monoid (Element MText) => MText -> Element MText
$cfold :: Monoid (Element MText) => MText -> Element MText
foldMap :: forall m. Monoid m => (Element MText -> m) -> MText -> m
$cfoldMap :: forall m. Monoid m => (Element MText -> m) -> MText -> m
elem :: Eq (Element MText) => Element MText -> MText -> Bool
$celem :: Eq (Element MText) => Element MText -> MText -> Bool
length :: MText -> Int
$clength :: MText -> Int
foldl' :: forall b. (b -> Element MText -> b) -> b -> MText -> b
$cfoldl' :: forall b. (b -> Element MText -> b) -> b -> MText -> b
foldl :: forall b. (b -> Element MText -> b) -> b -> MText -> b
$cfoldl :: forall b. (b -> Element MText -> b) -> b -> MText -> b
foldr :: forall b. (Element MText -> b -> b) -> b -> MText -> b
$cfoldr :: forall b. (Element MText -> b -> b) -> b -> MText -> b
null :: MText -> Bool
$cnull :: MText -> Bool
toList :: MText -> [Element MText]
$ctoList :: MText -> [Element MText]
Container, MText -> Builder
(MText -> Builder) -> Buildable MText
forall p. (p -> Builder) -> Buildable p
build :: MText -> Builder
$cbuild :: MText -> Builder
Buildable, Int -> MText -> Int
MText -> Int
(Int -> MText -> Int) -> (MText -> Int) -> Hashable MText
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: MText -> Int
$chash :: MText -> Int
hashWithSalt :: Int -> MText -> Int
$chashWithSalt :: Int -> MText -> Int
Hashable)

instance NFData MText

minBoundMChar, maxBoundMChar :: Int
minBoundMChar :: Int
minBoundMChar = Int
32
maxBoundMChar :: Int
maxBoundMChar = Int
126

-- | Constraint on literals appearing in Michelson contract code.
isMChar :: Char -> Bool
isMChar :: Char -> Bool
isMChar Char
c = Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
minBoundMChar Bool -> Bool -> Bool
forall a. Boolean a => a -> a -> a
&& Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxBoundMChar

-- | Error message indicating bad character in a string literal.
invalidMCharError :: Char -> Text
invalidMCharError :: Char -> Text
invalidMCharError Char
c = Text
"Invalid character in string literal: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
forall a. ToText a => a -> Text
toText [Char
c]

-- | Wrap a Haskell text into 'MText', performing necessary checks.
--
-- You can use e.g. @'\n'@ character directly in supplied argument,
-- but attempt to use other bad characters like @'\r'@ will cause failure.
mkMText :: Text -> Either Text MText
mkMText :: Text -> Either Text MText
mkMText Text
txt = (Char -> Either Text ()) -> [Char] -> Either Text [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Char -> Either Text ()
checkMChar (Text -> [Char]
forall a. ToString a => a -> [Char]
toString Text
txt) Either Text [()] -> MText -> Either Text MText
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Text -> MText
UnsafeMText Text
txt
  where
    checkMChar :: Char -> Either Text ()
checkMChar Char
c
      | Char -> Bool
isMChar Char
c Bool -> Bool -> Bool
forall a. Boolean a => a -> a -> a
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n' = Either Text ()
forall (f :: * -> *). Applicative f => f ()
pass
      | Bool
otherwise = Text -> Either Text ()
forall a b. a -> Either a b
Left (Text -> Either Text ()) -> Text -> Either Text ()
forall a b. (a -> b) -> a -> b
$ Char -> Text
invalidMCharError Char
c

-- | Construct 'MText' from a Haskell text, eliminating all characters which
-- should not appear in Michelson strings.
-- Characters which can be displayed normally via escaping are preserved.
mkMTextCut :: Text -> MText
mkMTextCut :: Text -> MText
mkMTextCut Text
txt =
  Text -> MText
UnsafeMText (Text -> MText) -> ([Char] -> Text) -> [Char] -> MText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
forall a. ToText a => a -> Text
toText ([Char] -> Text) -> ShowS -> [Char] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
isAllowed ([Char] -> MText) -> [Char] -> MText
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
forall a. ToString a => a -> [Char]
toString Text
txt
  where
    isAllowed :: Char -> Bool
isAllowed Char
c = Char -> Bool
isMChar Char
c Bool -> Bool -> Bool
forall a. Boolean a => a -> a -> a
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n'

-- | Print 'MText' for Michelson code, with all unusual characters escaped.
writeMText :: MText -> Text
writeMText :: MText -> Text
writeMText (UnsafeMText Text
t) = Text
t
  Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& Text -> Text -> Text -> Text
T.replace Text
"\\" Text
"\\\\"
  Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& Text -> Text -> Text -> Text
T.replace Text
"\n" Text
"\\n"
  Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& Text -> Text -> Text -> Text
T.replace Text
"\"" Text
"\\\""

takeMText :: Int -> MText -> MText
takeMText :: Int -> MText -> MText
takeMText Int
n (UnsafeMText Text
txt) = Text -> MText
UnsafeMText (Text -> MText) -> Text -> MText
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.take Int
n Text
txt

dropMText :: Int -> MText -> MText
dropMText :: Int -> MText -> MText
dropMText Int
n (UnsafeMText Text
txt) = Text -> MText
UnsafeMText (Text -> MText) -> Text -> MText
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop Int
n Text
txt

instance ToText MText where
  toText :: MText -> Text
toText = MText -> Text
unMText

instance ToJSON MText where
  toJSON :: MText -> Value
toJSON = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> (MText -> Text) -> MText -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MText -> Text
unMText
instance FromJSON MText where
  parseJSON :: Value -> Parser MText
parseJSON Value
v =
    (Text -> Parser MText)
-> (MText -> Parser MText) -> Either Text MText -> Parser MText
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> Parser MText
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Parser MText)
-> (Text -> [Char]) -> Text -> Parser MText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
forall a. ToString a => a -> [Char]
toString) MText -> Parser MText
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text MText -> Parser MText)
-> (Text -> Either Text MText) -> Text -> Parser MText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text MText
mkMText (Text -> Parser MText) -> Parser Text -> Parser MText
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. FromJSON a => Value -> Parser a
parseJSON @Text Value
v

instance HasCLReader MText where
  getReader :: ReadM MText
getReader = ([Char] -> Either [Char] MText) -> ReadM MText
forall a. ([Char] -> Either [Char] a) -> ReadM a
eitherReader ((Text -> [Char]) -> Either Text MText -> Either [Char] MText
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> [Char]
forall a. ToString a => a -> [Char]
toString (Either Text MText -> Either [Char] MText)
-> ([Char] -> Either Text MText) -> [Char] -> Either [Char] MText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text MText
mkMText (Text -> Either Text MText)
-> ([Char] -> Text) -> [Char] -> Either Text MText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
forall a. ToText a => a -> Text
toText)
  getMetavar :: [Char]
getMetavar = [Char]
"MICHELSON STRING"

-- | QuasyQuoter for constructing Michelson strings.
--
-- Validity of result will be checked at compile time.
-- Note:
--
-- * slash must be escaped
-- * newline character must appear as '\n'
-- * use quotes as is
-- * other special characters are not allowed.
mt :: TH.QuasiQuoter
mt :: QuasiQuoter
mt = QuasiQuoter :: ([Char] -> Q Exp)
-> ([Char] -> Q Pat)
-> ([Char] -> Q Type)
-> ([Char] -> Q [Dec])
-> QuasiQuoter
TH.QuasiQuoter
  { quoteExp :: [Char] -> Q Exp
TH.quoteExp = \[Char]
s ->
      case [Char] -> Either Text [Char]
qqMText [Char]
s of
        Left Text
err -> [Char] -> Q Exp
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q Exp) -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
forall a. ToString a => a -> [Char]
toString Text
err
        Right [Char]
txt -> [e| UnsafeMText (toText @String txt) |]
  , quotePat :: [Char] -> Q Pat
TH.quotePat = \[Char]
s ->
      case [Char] -> Either Text [Char]
qqMText [Char]
s of
        Left Text
err -> [Char] -> Q Pat
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q Pat) -> [Char] -> Q Pat
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
forall a. ToString a => a -> [Char]
toString Text
err
        Right [Char]
txt -> [p| UnsafeMText $(TH.litP $ TH.StringL txt) |]
  , quoteType :: [Char] -> Q Type
TH.quoteType = \[Char]
_ ->
      [Char] -> Q Type
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Cannot use this QuasiQuoter at type position"
  , quoteDec :: [Char] -> Q [Dec]
TH.quoteDec = \[Char]
_ ->
      [Char] -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Cannot use this QuasiQuoter at declaration position"
  }

{-# ANN module ("HLint: ignore Use list literal pattern" :: Text) #-}

-- | Parser used in 'mt' quasi quoter.
qqMText :: String -> Either Text String
qqMText :: [Char] -> Either Text [Char]
qqMText [Char]
txt = [Char] -> Either Text [Char]
scan [Char]
txt
  where
  scan :: [Char] -> Either Text [Char]
scan = \case
    Char
'\\' : [] -> Text -> Either Text [Char]
forall a b. a -> Either a b
Left Text
"Unterminated '\\' in string literal"
    Char
'\\' : Char
'\\' : [Char]
s -> (Char
'\\' Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> Either Text [Char] -> Either Text [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Either Text [Char]
scan [Char]
s
    Char
'\\' : Char
'n'  : [Char]
s -> (Char
'\n' Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> Either Text [Char] -> Either Text [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Either Text [Char]
scan [Char]
s
    Char
'\\' : Char
c : [Char]
_ -> Text -> Either Text [Char]
forall a b. a -> Either a b
Left (Text -> Either Text [Char]) -> Text -> Either Text [Char]
forall a b. (a -> b) -> a -> b
$ Text
"Unknown escape sequence: '\\" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
forall a. ToText a => a -> Text
toText [Char
c] Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"
    Char
c : [Char]
s
      | Char -> Bool
isMChar Char
c -> (Char
c Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> Either Text [Char] -> Either Text [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Either Text [Char]
scan [Char]
s
      | Bool
otherwise -> Text -> Either Text [Char]
forall a b. a -> Either a b
Left (Text -> Either Text [Char]) -> Text -> Either Text [Char]
forall a b. (a -> b) -> a -> b
$ Char -> Text
invalidMCharError Char
c
    [] -> [Char] -> Either Text [Char]
forall a b. b -> Either a b
Right []

-- | A type error asking to use 'MText' instead of t'Text'.
type DoNotUseTextError = DelayError
  ( 'Text "`Text` is not isomorphic to Michelson strings," ':$$:
    'Text "consider using `MText` type instead"
  )

-- | Create a 'MText' from type-level string.
--
-- We assume that no unicode characters are used in plain Haskell code,
-- so unless special tricky manipulations are used this should be safe.
symbolToMText :: forall name. KnownSymbol name => MText
symbolToMText :: forall (name :: Symbol). KnownSymbol name => MText
symbolToMText = Either Text MText -> MText
forall a b. (HasCallStack, Buildable a) => Either a b -> b
unsafe (Either Text MText -> MText)
-> (Text -> Either Text MText) -> Text -> MText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text MText
mkMText (Text -> MText) -> Text -> MText
forall a b. (a -> b) -> a -> b
$ forall (s :: Symbol). KnownSymbol s => Text
symbolValT' @name

-- | Create a 'MText' from label.
--
-- We assume that no unicode characters are used in plain Haskell code,
-- so unless special tricky manipulations are used this should be safe.
labelToMText :: Label name -> MText
labelToMText :: forall (name :: Symbol). Label name -> MText
labelToMText = Either Text MText -> MText
forall a b. (HasCallStack, Buildable a) => Either a b -> b
unsafe (Either Text MText -> MText)
-> (Label name -> Either Text MText) -> Label name -> MText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text MText
mkMText (Text -> Either Text MText)
-> (Label name -> Text) -> Label name -> Either Text MText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label name -> Text
forall (name :: Symbol). Label name -> Text
labelToText

-- | Leads first character of text to upper case.
--
-- For empty text this will throw an error.
mtextHeadToUpper :: HasCallStack => MText -> MText
mtextHeadToUpper :: HasCallStack => MText -> MText
mtextHeadToUpper (UnsafeMText Text
txt) = case Text -> Maybe (Char, Text)
T.uncons Text
txt of
  Maybe (Char, Text)
Nothing -> Text -> MText
forall a. HasCallStack => Text -> a
error Text
"Empty text"
  Just (Char
c, Text
cs) -> Text -> MText
UnsafeMText (Text -> MText) -> Text -> MText
forall a b. (a -> b) -> a -> b
$ Char -> Text -> Text
T.cons (Char -> Char
C.toUpper Char
c) Text
cs