ViewName.hs

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

{-# OPTIONS_HADDOCK not-home #-}

-- | Michelson view name.
module Morley.Michelson.Internal.ViewName
  ( module Morley.Michelson.Internal.ViewName
  ) where

import Control.Monad.Except (throwError)
import Data.Aeson (FromJSONKey(..), ToJSONKey(..))
import Data.Aeson.TH (deriveJSON)
import Data.Aeson.Types qualified as AesonTypes
import Data.Data (Data)
import Data.Text qualified as Text
import Fmt (Buildable(..), Doc, pretty, (+|), (|+))
import Prettyprinter (dquotes)

import Morley.Michelson.Printer.Util
import Morley.Michelson.Text
import Morley.Util.Aeson
import Morley.Util.CLI

-- | Name of the view.
--
-- 1. It must not exceed 31 chars length;
-- 2. Must use [a-zA-Z0-9_.%@] charset.
newtype ViewName = UnsafeViewName { unViewName :: Text }
  deriving stock (Show, Eq, Ord, Data, Generic)
  deriving newtype (Buildable, NFData)

pattern ViewName :: Text -> ViewName
pattern ViewName name <- UnsafeViewName name
{-# COMPLETE ViewName #-}

deriveJSON morleyAesonOptions ''ViewName

instance HasCLReader ViewName where
  getReader = eitherReader (first pretty . mkViewName . toText)
  getMetavar = "VIEW NAME"

instance ToJSONKey ViewName where
  toJSONKey = AesonTypes.toJSONKeyText unViewName

instance FromJSONKey ViewName where
  fromJSONKey = AesonTypes.FromJSONKeyTextParser $ either (fail . pretty) pure . mkViewName

-- | Whether the given character is valid for a view.
isValidViewNameChar :: Char -> Bool
isValidViewNameChar c = or
  [ 'A' <= c && c <= 'Z'
  , 'a' <= c && c <= 'z'
  , '0' <= c && c <= '9'
  , c `elem` ['_', '.', '%', '@']
  ]

-- | Maximum allowed name length for a view.
viewNameMaxLength :: Int
viewNameMaxLength = 31

data BadViewNameError
  = BadViewTooLong Int
  | BadViewIllegalChars Text
  deriving stock (Show, Eq, Ord, Data, Generic)
  deriving anyclass (NFData)

instance Buildable BadViewNameError where
  build = \case
    BadViewTooLong l ->
      "Bad view name length of " +| l |+ " characters, must not exceed \
      \" +| viewNameMaxLength |+ " characters length"
    BadViewIllegalChars txt ->
      "Invalid characters in the view \"" +| txt |+ ", allowed characters set \
      \is [a-zA-Z0-9_.%@]"

-- | Construct t'ViewName' performing all the checks.
mkViewName :: Text -> Either BadViewNameError ViewName
mkViewName txt = do
  unless (length txt <= viewNameMaxLength) $
    throwError (BadViewTooLong $ length txt)
  unless (Text.all isValidViewNameChar txt) $
    throwError (BadViewIllegalChars txt)
  return (UnsafeViewName txt)

renderViewName :: ViewName -> Doc
renderViewName = dquotes . build . unViewName

instance RenderDoc ViewName where
  renderDoc _ = renderViewName

-- | Valid view names form a subset of valid Michelson texts.
viewNameToMText :: ViewName -> MText
viewNameToMText = unsafe . mkMText . unViewName