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

-- | Module, providing 'T' data type, representing Michelson
-- language types without annotations.
module Morley.Michelson.Typed.T
  ( T (..)
  , toUType
  , buildStack
  ) where

import Data.Data (Data)
import Fmt (Buildable(..), Builder, listF)

import Morley.Michelson.Printer.Util (Prettier(..), RenderDoc(..), buildRenderDocExtended)
import Morley.Michelson.Untyped.Annotation qualified as Un
import Morley.Michelson.Untyped.Type qualified as Un
import Morley.Util.MismatchError
import Morley.Util.Peano qualified as Peano

-- | Michelson language type with annotations stripped off.
data T =
    TKey
  | TUnit
  | TSignature
  | TChainId
  | TOption T
  | TList T
  | TSet T
  | TOperation
  | TContract T
  | TTicket T
  | TPair T T
  | TOr T T
  | TLambda T T
  | TMap T T
  | TBigMap T T
  | TInt
  | TNat
  | TString
  | TBytes
  | TMutez
  | TBool
  | TKeyHash
  | TBls12381Fr
  | TBls12381G1
  | TBls12381G2
  | TTimestamp
  | TAddress
  | TChest
  | TChestKey
  | TSaplingState Peano.Peano
  | TSaplingTransaction Peano.Peano
  | TTxRollupL2Address
  | TNever
  deriving stock (Eq, Show, Generic, Data)

instance NFData T

-- | Converts from 'T' to 'Un.Ty'.
toUType :: T -> Un.Ty
toUType t = Un.Ty (convert t) Un.noAnn
  where
    convert :: T -> Un.T
    convert TInt = Un.TInt
    convert TNat = Un.TNat
    convert TString = Un.TString
    convert TBytes = Un.TBytes
    convert TMutez = Un.TMutez
    convert TBool = Un.TBool
    convert TKeyHash = Un.TKeyHash
    convert TTimestamp = Un.TTimestamp
    convert TAddress = Un.TAddress
    convert TKey = Un.TKey
    convert TBls12381Fr = Un.TBls12381Fr
    convert TBls12381G1 = Un.TBls12381G1
    convert TBls12381G2 = Un.TBls12381G2
    convert TUnit = Un.TUnit
    convert TSignature = Un.TSignature
    convert TChainId = Un.TChainId
    convert TChest = Un.TChest
    convert TChestKey = Un.TChestKey
    convert TTxRollupL2Address = Un.TTxRollupL2Address
    convert TNever = Un.TNever
    convert (TSaplingState n) = Un.TSaplingState (Peano.toNatural n)
    convert (TSaplingTransaction n) = Un.TSaplingTransaction (Peano.toNatural n)
    convert (TOption a) = Un.TOption (toUType a)
    convert (TList a) = Un.TList (toUType a)
    convert (TSet a) = Un.TSet $ Un.Ty (Un.unwrapT $ toUType a) Un.noAnn
    convert (TOperation) = Un.TOperation
    convert (TContract a) = Un.TContract (toUType a)
    convert (TTicket a) = Un.TTicket (toUType a)
    convert (TPair a b) =
      Un.TPair Un.noAnn Un.noAnn Un.noAnn Un.noAnn (toUType a) (toUType b)
    convert (TOr a b) =
      Un.TOr Un.noAnn Un.noAnn (toUType a) (toUType b)
    convert (TLambda a b) =
      Un.TLambda (toUType a) (toUType b)
    convert (TMap a b) =
      Un.TMap (Un.Ty (Un.unwrapT $ toUType a) Un.noAnn) (toUType b)
    convert (TBigMap a b) =
      Un.TBigMap (Un.Ty (Un.unwrapT $ toUType a) Un.noAnn) (toUType b)

instance Buildable T where
  build = build . toUType

instance Buildable (MismatchError T) where
  build = buildRenderDocExtended

instance Buildable (MismatchError [T]) where
  build = buildRenderDocExtended

instance RenderDoc T where
  renderDoc context = renderDoc context . toUType

instance RenderDoc (Prettier T) where
  renderDoc context = renderDoc context . fmap toUType

instance RenderDoc (MismatchError T) where
  renderDoc ctx = renderDocDiff ctx . fmap Prettier

instance RenderDoc (MismatchError [T]) where
  renderDoc ctx = renderDocDiffList ctx . (fmap . fmap) Prettier

-- | Format type stack in a pretty way.
buildStack :: [T] -> Builder
buildStack = listF