{-# LANGUAGE DeriveDataTypeable, DerivingStrategies #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
module Michelson.Text
( MText (..)
, mkMText
, mkMTextUnsafe
, mkMTextCut
, writeMText
, takeMText
, dropMText
, isMChar
, qqMText
, mt
, DoNotUseTextError
) where
import Data.Aeson (FromJSON(..), ToJSON(..))
import Data.Data (Data)
import qualified Data.Text as T
import Fmt (Buildable)
import GHC.TypeLits (ErrorMessage(..), TypeError)
import qualified Language.Haskell.TH.Quote as TH
import Test.QuickCheck (Arbitrary(..), choose, listOf)
newtype MText = MTextUnsafe { unMText :: Text }
deriving stock (Show, Eq, Ord, Data)
deriving newtype (Semigroup, Monoid, Container, Buildable)
isMChar :: Char -> Bool
isMChar c = fromEnum c >= 32 && fromEnum c <= 126
invalidMCharError :: Char -> Text
invalidMCharError c = "Invalid character in string literal: " <> toText [c]
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
mkMTextUnsafe :: HasCallStack => Text -> MText
mkMTextUnsafe = either error id . mkMText
mkMTextCut :: Text -> MText
mkMTextCut txt =
MTextUnsafe . toText . filter isAllowed $ toString txt
where
isAllowed c = isMChar c || c == '\n'
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 Arbitrary MText where
arbitrary =
mkMTextUnsafe . toText <$>
listOf (choose @Char (toEnum 32, toEnum 126))
instance ToJSON MText where
toJSON = toJSON . unMText
instance FromJSON MText where
parseJSON v =
either (fail . toString) pure . mkMText =<< parseJSON @Text v
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 = \_ ->
fail "Cannot use this QuasyQuotation at pattern position"
, 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) #-}
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"
type family DoNotUseTextError where
DoNotUseTextError = TypeError
( 'Text "`Text` is not isomorphic to Michelson strings," ':$$:
'Text "consider using `MText` type instead"
)