Type.hs

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

-- | Parsing of Michelson types.

module Michelson.Parser.Type
  ( type_
  , typeWithParen
  , field
  ) where

import Prelude hiding (note, some, try)

import Data.Default (Default, def)
import qualified Data.Map as Map
import Fmt (pretty)
import Text.Megaparsec (choice, customFailure, sepBy)

import Michelson.Let (LetType(..))
import Michelson.Parser.Annotations
import Michelson.Parser.Error
import Michelson.Parser.Helpers
import Michelson.Parser.Lexer
import Michelson.Parser.Types (Parser, letTypes)
import Michelson.Untyped
import Util.Generic

type_ :: Parser Type
type_ = snd <$> typeInner (pure noAnn)

field :: Parser (FieldAnn, Type)
field = typeInner note

t_operator :: Parser FieldAnn -> Parser (FieldAnn, Type)
t_operator fp = do
  whole <- parens do
    optional do
      ty   <- field
      rest <- optional do
        isOr <- (symbol' "|" >> return True)
            <|> (symbol' "," >> return False)
        others <- field `sepBy` symbol' if isOr then "|" else ","
        return (isOr, others)
      return (ty, rest)

  (f, t) <- fieldType fp
  case whole of
    Just (ty, Just (isOr, tys)) -> do
      let (f', Type ty' _) = mkGenericTree (mergeTwo isOr) (ty :| tys)
      f'' <- mergeAnnots f f'
      return (f'', Type ty' t)
    Just (res, _) -> do
      return res
    Nothing -> do
      return (f, Type TUnit t)
  where
    mergeTwo isOr _ (l, a) (r, b) =
      (noAnn, Type ((if isOr then TOr else TPair) l r a b) noAnn)

    mergeAnnots l r
      | l == def  = return r
      | r == def  = return l
      | otherwise = customFailure ExcessFieldAnnotation

typeInner
  :: Parser FieldAnn -> Parser (FieldAnn, Type)
typeInner fp = lexeme $ choice $ (\x -> x fp) <$>
  [ t_int, t_nat, t_string, t_bytes, t_mutez, t_bool
  , t_keyhash, t_timestamp, t_address
  , t_key, t_unit, t_signature, t_chain_id
  , t_option, t_list, t_set
  , t_operation, t_contract, t_pair, t_or
  , t_lambda, t_map, t_big_map, t_view
  , t_void, t_letType
  , t_operator
  , const (customFailure UnknownTypeException)
  ]

----------------------------------------------------------------------------
-- Comparable types
----------------------------------------------------------------------------

typeWithParen :: Parser Type
typeWithParen = mparens type_

----------------------------------------------------------------------------
-- Non-comparable types
----------------------------------------------------------------------------

mkType :: T -> (a, TypeAnn) -> (a, Type)
mkType t (a, ta) = (a, Type t ta)


t_int :: (Default a) => Parser a -> Parser (a, Type)
t_int fp = word' "Int" (mkType TInt) <*> fieldType fp

t_nat :: (Default a) => Parser a -> Parser (a, Type)
t_nat fp = word' "Nat" (mkType TNat) <*> fieldType fp

t_string :: (Default a) => Parser a -> Parser (a, Type)
t_string fp = word' "String" (mkType TString) <*> fieldType fp

t_bytes :: (Default a) => Parser a -> Parser (a, Type)
t_bytes fp = word' "Bytes" (mkType TBytes) <*> fieldType fp

t_mutez :: (Default a) => Parser a -> Parser (a, Type)
t_mutez fp = word' "Mutez" (mkType TMutez) <*> fieldType fp

t_bool :: (Default a) => Parser a -> Parser (a, Type)
t_bool fp = word' "Bool" (mkType TBool) <*> fieldType fp

t_keyhash :: (Default a) => Parser a -> Parser (a, Type)
t_keyhash fp = ((word' "KeyHash" (mkType TKeyHash)) <|> (word "key_hash" (mkType TKeyHash))) <*> fieldType fp

t_timestamp :: (Default a) => Parser a -> Parser (a, Type)
t_timestamp fp = word' "Timestamp" (mkType TTimestamp) <*> fieldType fp

t_address :: (Default a) => Parser a -> Parser (a, Type)
t_address fp = word' "Address" (mkType TAddress) <*> fieldType fp

t_key :: (Default a) => Parser a -> Parser (a, Type)
t_key fp = word' "Key" (mkType TKey) <*> fieldType fp

t_signature :: (Default a) => Parser a -> Parser (a, Type)
t_signature fp = word' "Signature" (mkType TSignature) <*> fieldType fp

t_chain_id :: (Default a) => Parser a -> Parser (a, Type)
t_chain_id fp = do
  symbol' "ChainId" <|> symbol' "chain_id"
  mkType TChainId <$> fieldType fp

t_operation :: (Default a) => Parser a -> Parser (a, Type)
t_operation fp = word' "Operation" (mkType TOperation) <*> fieldType fp

t_contract :: (Default a) => Parser a -> Parser (a, Type)
t_contract fp = do
  symbol' "Contract"
  (f, t) <- fieldType fp
  a <- type_
  return (f, Type (TContract a) t)

t_unit :: (Default a) => Parser a -> Parser (a, Type)
t_unit fp = do
  symbol' "Unit" <|> symbol' "()"
  (f,t) <- fieldType fp
  return (f, Type TUnit t)

t_pair :: (Default a) => Parser a -> Parser (a, Type)
t_pair fp = do
  symbol' "Pair"
  (fieldAnn, typeAnn) <- fieldType fp
  fields <- many field
  tPair <- go fields
  pure $ (fieldAnn, Type tPair typeAnn)
  where
    go :: [(FieldAnn, Type)] -> Parser T
    go = \case
      [] -> fail "The 'pair' type expects at least 2 type arguments, but 0 were given."
      [(_, t)] -> fail $ "The 'pair' type expects at least 2 type arguments, but only 1 was given: '" <> pretty t <> "'."
      [(fieldAnnL, typeL), (fieldAnnR, typeR)] ->
        pure $ TPair fieldAnnL fieldAnnR typeL typeR
      (fieldAnnL, typeL) : fields -> do
        rightCombedT <- go fields
        pure $ TPair fieldAnnL noAnn typeL (Type rightCombedT noAnn)

t_or :: (Default a) => Parser a -> Parser (a, Type)
t_or fp = do
  symbol' "Or"
  (f, t) <- fieldType fp
  (l, a) <- field
  (r, b) <- field
  return (f, Type (TOr l r a b) t)

t_option :: (Default a) => Parser a -> Parser (a, Type)
t_option fp = do
  symbol' "Option"
  (f, t) <- fieldType fp
  a <- mparens $ snd <$> typeInner (pure noAnn)
  return (f, Type (TOption a) t)

t_lambda :: (Default a) => Parser a -> Parser (a, Type)
t_lambda fp = core <|> slashLambda
  where
    core = do
      symbol' "Lambda"
      (f, t) <- fieldType fp
      a <- type_
      b <- type_
      return (f, Type (TLambda a b) t)
    slashLambda = do
      symbol "\\"
      (f, t) <- fieldType fp
      a <- type_
      symbol "->"
      b <- type_
      return (f, Type (TLambda a b) t)

-- Container types
t_list :: (Default a) => Parser a -> Parser (a, Type)
t_list fp = core <|> bracketList
  where
    core = do
      symbol' "List"
      (f, t) <- fieldType fp
      a <- type_
      return (f, Type (TList a) t)
    bracketList = do
      a <- brackets type_
      (f, t) <- fieldType fp
      return (f, Type (TList a) t)

t_set :: (Default a) => Parser a -> Parser (a, Type)
t_set fp = core <|> braceSet
  where
    core = do
      symbol' "Set"
      (f, t) <- fieldType fp
      a <- typeWithParen
      return (f, Type (TSet a) t)
    braceSet = do
      a <- braces typeWithParen
      (f, t) <- fieldType fp
      return (f, Type (TSet a) t)

t_map_like
  :: Default a
  => Parser a -> Parser (Type, Type, a, TypeAnn)
t_map_like fp = do
  (f, t) <- fieldType fp
  a <- typeWithParen
  b <- type_
  return (a, b, f, t)

t_map :: (Default a) => Parser a -> Parser (a, Type)
t_map fp = do
  symbol' "Map"
  (a, b, f, t) <- t_map_like fp
  return (f, Type (TMap a b) t)

t_big_map :: (Default a) => Parser a -> Parser (a, Type)
t_big_map fp = do
  symbol' "BigMap" <|> symbol "big_map"
  (a, b, f, t) <- t_map_like fp
  return (f, Type (TBigMap a b) t)

----------------------------------------------------------------------------
-- Non-standard types (Morley extensions)
----------------------------------------------------------------------------

t_view :: Default a => Parser a -> Parser (a, Type)
t_view fp = do
  symbol' "View"
  a <- type_
  r <- type_
  (f, t) <- fieldType fp
  let c' = Type (TContract r) noAnn
  return (f, Type (TPair noAnn noAnn a c') t)

t_void :: Default a => Parser a -> Parser (a, Type)
t_void fp = do
  symbol' "Void"
  a <- type_
  b <- type_
  (f, t) <- fieldType fp
  let c = Type (TLambda b b) noAnn
  return (f, Type (TPair noAnn noAnn a c) t)

t_letType :: Default fp => Parser fp -> Parser (fp, Type)
t_letType fp = do
  lts <- asks letTypes
  lt <- ltSig <$> (mkLetType lts)
  f <- parseDef fp
  return (f, lt)

mkLetType :: Map Text LetType -> Parser LetType
mkLetType lts = choice $ mkParser ltName <$> (Map.elems lts)