-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

-- 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 @alphanet.sh@.
--
-- 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 Michelson.Text
  ( MText (..)
  , mkMText
  , mkMTextUnsafe
  , mkMTextCut
  , writeMText
  , takeMText
  , dropMText
  , isMChar
  , minBoundMChar
  , maxBoundMChar

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

import Data.Aeson (FromJSON(..), ToJSON(..))
import qualified Data.Char as C
import Data.Data (Data)
import qualified Data.Text as T
import Fmt (Buildable)
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Quote as TH
import Test.QuickCheck (Arbitrary(..), choose, listOf)

import Util.CLI
import Util.Label (Label(..), labelToText)
import 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|]
-- MTextUnsafe { unMText = "Some text" }
--
-- * With 'mkMText' when constructing from a runtime text value.
--
-- * With 'mkMTextUnsafe' or 'MTextUnsafe' 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 = MTextUnsafe { MText -> Text
unMText :: Text }
  deriving stock (Int -> MText -> ShowS
[MText] -> ShowS
MText -> String
(Int -> MText -> ShowS)
-> (MText -> String) -> ([MText] -> ShowS) -> Show MText
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MText] -> ShowS
$cshowList :: [MText] -> ShowS
show :: MText -> String
$cshow :: MText -> String
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
$cp1Ord :: Eq MText
Ord, Typeable MText
DataType
Constr
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 d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> MText -> c MText
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c 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)
$cMTextUnsafe :: Constr
$tMText :: DataType
gmapMo :: (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 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 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 :: Int -> (forall d. Data d => d -> u) -> MText -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> MText -> u
gmapQ :: (forall d. Data d => d -> u) -> MText -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> MText -> [u]
gmapQr :: (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 :: (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 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 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 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 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
$cp1Data :: Typeable 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 (b -> MText -> MText
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 :: 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
$cp1Monoid :: Semigroup MText
Monoid, Eq (Element MText) => Element MText -> MText -> Bool
Ord (Element MText) => MText -> Element MText
Monoid (Element MText) => MText -> Element MText
(Element MText ~ Bool) => MText -> Bool
Element MText -> MText -> Bool
MText -> Bool
MText -> Int
MText -> [Element MText]
MText -> Maybe (Element MText)
MText -> Element MText
(b -> Element MText -> b) -> b -> MText -> b
(b -> Element MText -> b) -> b -> MText -> b
(Element MText -> m) -> MText -> m
(Element MText -> Bool) -> MText -> Bool
(Element MText -> Bool) -> MText -> Maybe (Element MText)
(Element MText -> b -> b) -> b -> MText -> b
(Element MText -> b -> b) -> b -> MText -> b
(Element MText -> Element MText -> Element MText)
-> MText -> 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)
-> (Ord (Element MText) => MText -> Element MText)
-> (Ord (Element MText) => MText -> Element MText)
-> (forall m. Monoid m => (Element MText -> m) -> MText -> m)
-> (Monoid (Element MText) => MText -> Element MText)
-> (forall b. (Element MText -> b -> b) -> b -> MText -> b)
-> ((Element MText -> Element MText -> Element MText)
    -> MText -> Element MText)
-> ((Element MText -> Element MText -> Element MText)
    -> MText -> Element MText)
-> (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))
-> 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)
-> (Ord (Element t) => t -> Element t)
-> (Ord (Element t) => t -> Element t)
-> (forall m. Monoid m => (Element t -> m) -> t -> m)
-> (Monoid (Element t) => t -> Element t)
-> (forall b. (Element t -> b -> b) -> b -> t -> b)
-> ((Element t -> Element t -> Element t) -> t -> Element t)
-> ((Element t -> Element t -> Element t) -> t -> Element t)
-> (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))
-> Container t
forall b. (b -> Element MText -> b) -> b -> MText -> b
forall b. (Element MText -> b -> b) -> b -> MText -> b
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 :: MText -> Bool
$cor :: (Element MText ~ Bool) => MText -> Bool
and :: 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 :: Element MText -> MText -> Bool
$cnotElem :: Eq (Element MText) => Element MText -> MText -> Bool
foldl1 :: (Element MText -> Element MText -> Element MText)
-> MText -> Element MText
$cfoldl1 :: (Element MText -> Element MText -> Element MText)
-> MText -> Element MText
foldr1 :: (Element MText -> Element MText -> Element MText)
-> MText -> Element MText
$cfoldr1 :: (Element MText -> Element MText -> Element MText)
-> MText -> Element MText
foldr' :: (Element MText -> b -> b) -> b -> MText -> b
$cfoldr' :: forall b. (Element MText -> b -> b) -> b -> MText -> b
fold :: MText -> Element MText
$cfold :: Monoid (Element MText) => MText -> Element MText
foldMap :: (Element MText -> m) -> MText -> m
$cfoldMap :: forall m. Monoid m => (Element MText -> m) -> MText -> m
minimum :: MText -> Element MText
$cminimum :: Ord (Element MText) => MText -> Element MText
maximum :: MText -> Element MText
$cmaximum :: Ord (Element MText) => MText -> Element MText
elem :: Element MText -> MText -> Bool
$celem :: Eq (Element MText) => Element MText -> MText -> Bool
length :: MText -> Int
$clength :: MText -> Int
foldl' :: (b -> Element MText -> b) -> b -> MText -> b
$cfoldl' :: forall b. (b -> Element MText -> b) -> b -> MText -> b
foldl :: (b -> Element MText -> b) -> b -> MText -> b
$cfoldl :: forall b. (b -> Element MText -> b) -> b -> MText -> b
foldr :: (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 = 32
maxBoundMChar :: Int
maxBoundMChar = 126

-- | Constraint on literals appearing in Michelson contract code.
isMChar :: Char -> Bool
isMChar :: Char -> Bool
isMChar c :: 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
&& 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 c :: Char
c = "Invalid character in string literal: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> 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 txt :: Text
txt = (Char -> Either Text ()) -> String -> 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 -> String
forall a. ToString a => a -> String
toString Text
txt) Either Text [()] -> MText -> Either Text MText
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Text -> MText
MTextUnsafe Text
txt
  where
    checkMChar :: Char -> Either Text ()
checkMChar c :: Char
c
      | Char -> Bool
isMChar Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\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

-- | Contruct 'MText' from a Haskell text, failing if provided Haskell text
-- is invalid Michelson string.
mkMTextUnsafe :: HasCallStack => Text -> MText
mkMTextUnsafe :: Text -> MText
mkMTextUnsafe = (Text -> MText) -> (MText -> MText) -> Either Text MText -> MText
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> MText
forall a. HasCallStack => Text -> a
error MText -> MText
forall a. a -> a
id (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

-- | 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 txt :: Text
txt =
  Text -> MText
MTextUnsafe (Text -> MText) -> (String -> Text) -> String -> MText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. ToText a => a -> Text
toText (String -> Text) -> ShowS -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
isAllowed (String -> MText) -> String -> MText
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a. ToString a => a -> String
toString Text
txt
  where
    isAllowed :: Char -> Bool
isAllowed c :: Char
c = Char -> Bool
isMChar Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\n'

-- | Print 'MText' for Michelson code, with all unusual characters escaped.
writeMText :: MText -> Text
writeMText :: MText -> Text
writeMText (MTextUnsafe t :: 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
forall a b. a -> (a -> b) -> b
& Text -> Text -> Text -> Text
T.replace "\n" "\\n"
  Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& Text -> Text -> Text -> Text
T.replace "\"" "\\\""

takeMText :: Int -> MText -> MText
takeMText :: Int -> MText -> MText
takeMText n :: Int
n (MTextUnsafe txt :: Text
txt) = Text -> MText
MTextUnsafe (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 n :: Int
n (MTextUnsafe txt :: Text
txt) = Text -> MText
MTextUnsafe (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 Arbitrary MText where
  arbitrary :: Gen MText
arbitrary =
    HasCallStack => Text -> MText
Text -> MText
mkMTextUnsafe (Text -> MText) -> (String -> Text) -> String -> MText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. ToText a => a -> Text
toText (String -> MText) -> Gen String -> Gen MText
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    Gen Char -> Gen String
forall a. Gen a -> Gen [a]
listOf ((Char, Char) -> Gen Char
forall a. Random a => (a, a) -> Gen a
choose @Char (Int -> Char
forall a. Enum a => Int -> a
toEnum Int
minBoundMChar, Int -> Char
forall a. Enum a => Int -> a
toEnum Int
maxBoundMChar))

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 v :: 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 (String -> Parser MText
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser MText)
-> (Text -> String) -> Text -> Parser MText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. ToString a => a -> String
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
=<< Value -> Parser Text
forall a. FromJSON a => Value -> Parser a
parseJSON @Text Value
v

instance HasCLReader MText where
  getReader :: ReadM MText
getReader = (String -> Either String MText) -> ReadM MText
forall a. (String -> Either String a) -> ReadM a
eitherReader ((Text -> String) -> Either Text MText -> Either String MText
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> String
forall a. ToString a => a -> String
toString (Either Text MText -> Either String MText)
-> (String -> Either Text MText) -> String -> Either String MText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text MText
mkMText (Text -> Either Text MText)
-> (String -> Text) -> String -> Either Text MText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. ToText a => a -> Text
toText)
  getMetavar :: String
getMetavar = "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.

-- TODO: maybe enforce one space in the beginning and one in the end?
-- compare:
-- >>> [mt|mystuff|]
-- vs
-- >>> [mt| mystuff |]
mt :: TH.QuasiQuoter
mt :: QuasiQuoter
mt = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
TH.QuasiQuoter
  { quoteExp :: String -> Q Exp
TH.quoteExp = \s :: String
s ->
      case String -> Either Text String
qqMText String
s of
        Left err :: Text
err -> String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a. ToString a => a -> String
toString Text
err
        Right txt :: String
txt -> [e| MTextUnsafe (toText @String txt) |]
  , quotePat :: String -> Q Pat
TH.quotePat = \s :: String
s ->
      case String -> Either Text String
qqMText String
s of
        Left err :: Text
err -> String -> Q Pat
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Pat) -> String -> Q Pat
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a. ToString a => a -> String
toString Text
err
        Right txt :: String
txt -> [p| MTextUnsafe $(TH.litP $ TH.StringL txt) |]
  , quoteType :: String -> Q Type
TH.quoteType = \_ ->
      String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Cannot use this QuasyQuotation at type position"
  , quoteDec :: String -> Q [Dec]
TH.quoteDec = \_ ->
      String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Cannot use this QuasyQuotation at declaration position"
  }

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

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

instance
    TypeError ('Text "There is no instance defined for (IsString MText)" ':$$:
               'Text "Consider using QuasiQuotes: `[mt|some text...|]`"
              ) =>
    IsString MText where
  fromString :: String -> MText
fromString = Text -> String -> MText
forall a. HasCallStack => Text -> a
error "impossible"

-- | A type error asking to use 'MText' instead of 'Text'.
type family DoNotUseTextError where
  DoNotUseTextError = TypeError
    ( '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 :: MText
symbolToMText = HasCallStack => Text -> MText
Text -> MText
mkMTextUnsafe (Text -> MText) -> Text -> MText
forall a b. (a -> b) -> a -> b
$ KnownSymbol name => Text
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 :: Label name -> MText
labelToMText = HasCallStack => Text -> MText
Text -> MText
mkMTextUnsafe (Text -> MText) -> (Label name -> Text) -> Label name -> 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 :: MText -> MText
mtextHeadToUpper (MTextUnsafe txt :: Text
txt) = case Text -> Maybe (Char, Text)
T.uncons Text
txt of
  Nothing -> Text -> MText
forall a. HasCallStack => Text -> a
error "Empty text"
  Just (c :: Char
c, cs :: Text
cs) -> Text -> MText
MTextUnsafe (Text -> MText) -> Text -> MText
forall a b. (a -> b) -> a -> b
$ Char -> Text -> Text
T.cons (Char -> Char
C.toUpper Char
c) Text
cs