-- 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 @tezos-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 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 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 { unMText :: Text }
  deriving stock (Show, Eq, Ord, Data, Generic)
  deriving newtype (Semigroup, Monoid, Container, Buildable, Hashable)

instance NFData MText

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

-- | Constraint on literals appearing in Michelson contract code.
isMChar :: Char -> Bool
isMChar c = fromEnum c >= minBoundMChar && fromEnum c <= maxBoundMChar

-- | Error message indicating bad character in a string literal.
invalidMCharError :: Char -> Text
invalidMCharError c = "Invalid character in string literal: " <> toText [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 txt = mapM checkMChar (toString txt) $> MTextUnsafe txt
  where
    checkMChar c
      | isMChar c || c == '\n' = pass
      | otherwise = Left $ invalidMCharError c

-- | Contruct 'MText' from a Haskell text, failing if provided Haskell text
-- is invalid Michelson string.
mkMTextUnsafe :: HasCallStack => Text -> MText
mkMTextUnsafe = either error id . 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 txt =
  MTextUnsafe . toText . filter isAllowed $ toString txt
  where
    isAllowed c = isMChar c || c == '\n'

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

takeMText :: Int -> MText -> MText
takeMText n (MTextUnsafe txt) = MTextUnsafe $ T.take n txt

dropMText :: Int -> MText -> MText
dropMText n (MTextUnsafe txt) = MTextUnsafe $ T.drop n txt

instance ToText MText where
  toText = unMText

instance ToJSON MText where
  toJSON = toJSON . unMText
instance FromJSON MText where
  parseJSON v =
    either (fail . toString) pure . mkMText =<< parseJSON @Text v

instance HasCLReader MText where
  getReader = eitherReader (first toString . mkMText . toText)
  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 = TH.QuasiQuoter
  { TH.quoteExp = \s ->
      case qqMText s of
        Left err -> fail $ toString err
        Right txt -> [e| MTextUnsafe (toText @String txt) |]
  , TH.quotePat = \s ->
      case qqMText s of
        Left err -> fail $ toString err
        Right txt -> [p| MTextUnsafe $(TH.litP $ TH.StringL txt) |]
  , TH.quoteType = \_ ->
      fail "Cannot use this QuasyQuotation at type position"
  , TH.quoteDec = \_ ->
      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 txt = scan txt
  where
  scan = \case
    '\\' : [] -> Left "Unterminated '\\' in string literal"
    '\\' : '\\' : s -> ('\\' :) <$> scan s
    '\\' : 'n'  : s -> ('\n' :) <$> scan s
    '\\' : c : _ -> Left $ "Unknown escape sequence: '\\" <> toText [c] <> "'"
    c : s
      | isMChar c -> (c :) <$> scan s
      | otherwise -> Left $ invalidMCharError c
    [] -> Right []

instance
    TypeError ('Text "There is no instance defined for (IsString MText)" ':$$:
               'Text "Consider using QuasiQuotes: `[mt|some text...|]`"
              ) =>
    IsString MText where
  fromString = 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 = mkMTextUnsafe $ 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 = mkMTextUnsafe . labelToText

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