-- 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
  , genMText

    -- * 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 Hedgehog (MonadGen)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
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

genMText :: MonadGen m => m MText
genMText :: m MText
genMText =
  HasCallStack => Text -> MText
Text -> MText
mkMTextUnsafe (Text -> MText) -> m Text -> m MText
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range Int -> m Char -> m Text
forall (m :: * -> *). MonadGen m => Range Int -> m Char -> m Text
Gen.text
    (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear 0 100)
    (Char -> Char -> m Char
forall (m :: * -> *) a. (MonadGen m, Enum a) => a -> a -> m a
Gen.enum (Int -> Char
forall a. Enum a => Int -> a
toEnum @Char Int
minBoundMChar) (Int -> Char
forall a. Enum a => Int -> a
toEnum @Char Int
maxBoundMChar))

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