morley-1.14.0: src/Michelson/Untyped/Type.hs
-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ
-- | Michelson types represented in untyped model.
module Michelson.Untyped.Type
( Ty (..)
, T (..)
, ParameterType (..)
, toption
, tpair
, tor
, tyint
, tynat
, tyunit
, tybool
, typair
, tyor
, tyImplicitAccountParam
, isAtomicType
, isKey
, isSignature
, isComparable
, isMutez
, isKeyHash
, isBool
, isString
, isInteger
, isTimestamp
, isNat
, isInt
, isBytes
, renderType
, unwrapT
) where
import Data.Aeson.TH (deriveJSON)
import Data.Data (Data(..))
import Fmt (Buildable(build))
import Language.Haskell.TH.Lift (deriveLift)
import Prelude hiding ((<$>))
import Text.PrettyPrint.Leijen.Text (Doc, align, softbreak, (<$>), (<+>))
import Michelson.Printer.Util
(Prettier(..), RenderContext, RenderDoc(..), addParens, buildRenderDoc, doesntNeedParens,
needsParens, wrapInParens)
import Michelson.Untyped.Annotation
(AnnotationSet, FieldAnn, RootAnn, TypeAnn, VarAnn, emptyAnnSet, fullAnnSet, noAnn, singleAnnSet)
import Util.Aeson
-- Annotated type.
-- We don't name it 'Type' to avoid conflicts with 'Data.Kind.Type'.
data Ty
= Ty ~T TypeAnn
deriving stock (Eq, Show, Data, Generic)
unwrapT :: Ty -> T
unwrapT (Ty t _) = t
instance NFData Ty
instance RenderDoc (Prettier Ty) where
renderDoc pn (Prettier w) = case w of
(Ty t ta) -> renderType t False pn (singleAnnSet ta)
instance RenderDoc Ty where
renderDoc pn (Ty t ta) = renderType t True pn (singleAnnSet ta)
instance RenderDoc T where
renderDoc pn t = renderType t True pn emptyAnnSet
-- | Since Babylon parameter type can have special root annotation.
data ParameterType = ParameterType Ty RootAnn
deriving stock (Eq, Show, Data, Generic)
instance NFData ParameterType
instance RenderDoc (Prettier ParameterType) where
renderDoc pn (Prettier w) = case w of
ParameterType (Ty t ta) ra ->
renderType t False pn (fullAnnSet [ta] [ra] [])
instance RenderDoc ParameterType where
renderDoc pn (ParameterType (Ty t ta) ra) =
renderType t True pn (fullAnnSet [ta] [ra] [])
-- Ordering between different kinds of annotations is not significant,
-- but ordering among annotations of the same kind is. Annotations
-- of a same kind must be grouped together.
-- (prim @v :t %x arg1 arg2 ...)
-- these are equivalent
-- PAIR :t @my_pair %x %y
-- PAIR %x %y :t @my_pair
renderType
:: T
-> Bool
-> RenderContext
-> AnnotationSet
-> Doc
renderType t forceSingleLine pn annSet =
let annDoc = renderDoc doesntNeedParens annSet
recRenderer t' annSet' = renderType t' forceSingleLine needsParens annSet'
renderBranches d1 d2 =
if forceSingleLine
then (d1 <+> d2)
else align $ softbreak <> (d1 <$> d2)
in
case t of
TInt -> wrapInParens pn $ "int" :| [annDoc]
TNat -> wrapInParens pn $ "nat" :| [annDoc]
TString -> wrapInParens pn $ "string" :| [annDoc]
TMutez -> wrapInParens pn $ "mutez" :| [annDoc]
TBool -> wrapInParens pn $ "bool" :| [annDoc]
TKeyHash -> wrapInParens pn $ "key_hash" :| [annDoc]
TTimestamp -> wrapInParens pn $ "timestamp" :| [annDoc]
TBytes -> wrapInParens pn $ "bytes" :| [annDoc]
TAddress -> wrapInParens pn $ "address" :| [annDoc]
TKey -> wrapInParens pn $ "key" :| [annDoc]
TBls12381Fr -> wrapInParens pn $ "bls12_381_fr" :| [annDoc]
TBls12381G1 -> wrapInParens pn $ "bls12_381_g1" :| [annDoc]
TBls12381G2 -> wrapInParens pn $ "bls12_381_g2" :| [annDoc]
TUnit -> wrapInParens pn $ "unit" :| [annDoc]
TSignature -> wrapInParens pn $ "signature" :| [annDoc]
TChainId -> wrapInParens pn $ "chain_id" :| [annDoc]
TOperation -> wrapInParens pn $ "operation" :| [annDoc]
TNever -> wrapInParens pn $ "never" :| [annDoc]
TOption (Ty t1 ta1) ->
addParens pn $
"option" <+> annDoc <+> recRenderer t1 (singleAnnSet ta1)
TList (Ty t1 ta1) ->
addParens pn $
"list" <+> annDoc <+> recRenderer t1 (singleAnnSet ta1)
TSet (Ty t1 ta1) ->
addParens pn $
"set" <+> annDoc <+> recRenderer t1 (singleAnnSet ta1)
TContract (Ty t1 ta1) ->
addParens pn $
"contract" <+> annDoc <+> recRenderer t1 (singleAnnSet ta1)
TPair fa1 fa2 va1 va2 (Ty t1 ta1) (Ty t2 ta2) ->
addParens pn $
"pair" <+> annDoc <+>
renderBranches
(recRenderer t1 $ fullAnnSet [ta1] [fa1] [va1])
(recRenderer t2 $ fullAnnSet [ta2] [fa2] [va2])
TOr fa1 fa2 (Ty t1 ta1) (Ty t2 ta2) ->
addParens pn $
"or" <+> annDoc <+>
renderBranches
(recRenderer t1 $ fullAnnSet [ta1] [fa1] [])
(recRenderer t2 $ fullAnnSet [ta2] [fa2] [])
TLambda (Ty t1 ta1) (Ty t2 ta2) ->
addParens pn $
"lambda" <+> annDoc <+>
renderBranches
(recRenderer t1 $ singleAnnSet ta1)
(recRenderer t2 $ singleAnnSet ta2)
TMap (Ty t1 ta1) (Ty t2 ta2) ->
addParens pn $
"map" <+> annDoc <+>
renderBranches
(recRenderer t1 $ singleAnnSet ta1)
(recRenderer t2 $ singleAnnSet ta2)
TBigMap (Ty t1 ta1) (Ty t2 ta2) ->
addParens pn $
"big_map" <+> annDoc <+>
renderBranches
(recRenderer t1 $ singleAnnSet ta1)
(recRenderer t2 $ singleAnnSet ta2)
instance Buildable Ty where
build = buildRenderDoc
instance Buildable ParameterType where
build = buildRenderDoc
-- Michelson Type
data T =
TKey
| TUnit
| TSignature
| TChainId
| TOption Ty
| TList Ty
| TSet Ty
| TOperation
| TContract Ty
| TPair FieldAnn FieldAnn VarAnn VarAnn Ty Ty
| TOr FieldAnn FieldAnn Ty Ty
| TLambda Ty Ty
| TMap Ty Ty
| TBigMap Ty Ty
| TInt
| TNat
| TString
| TBytes
| TMutez
| TBool
| TKeyHash
| TBls12381Fr
| TBls12381G1
| TBls12381G2
| TTimestamp
| TAddress
| TNever
deriving stock (Eq, Show, Data, Generic)
instance Buildable T where
build = buildRenderDoc
instance NFData T
toption :: Ty -> T
toption t = TOption t
tpair :: Ty -> Ty -> T
tpair l r = TPair noAnn noAnn noAnn noAnn l r
tor :: Ty -> Ty -> T
tor l r = TOr noAnn noAnn l r
tyint :: Ty
tyint = Ty TInt noAnn
tynat :: Ty
tynat = Ty TNat noAnn
tyunit :: Ty
tyunit = Ty TUnit noAnn
tybool :: Ty
tybool = Ty TBool noAnn
typair :: Ty -> Ty -> Ty
typair l r = Ty (tpair l r) noAnn
tyor :: Ty -> Ty -> Ty
tyor l r = Ty (tor l r) noAnn
-- | For implicit account, which Ty its parameter seems to have
-- from outside.
tyImplicitAccountParam :: Ty
tyImplicitAccountParam = Ty TUnit noAnn
isAtomicType :: Ty -> Bool
isAtomicType t@(Ty _ tAnn) | tAnn == noAnn =
isComparable t || isKey t || isUnit t || isSignature t || isOperation t
isAtomicType _ = False
isKey :: Ty -> Bool
isKey (Ty TKey _) = True
isKey _ = False
isUnit :: Ty -> Bool
isUnit (Ty TUnit _) = True
isUnit _ = False
isSignature :: Ty -> Bool
isSignature (Ty TSignature _) = True
isSignature _ = False
isOperation :: Ty -> Bool
isOperation (Ty TOperation _) = True
isOperation _ = False
isComparable :: Ty -> Bool
isComparable (Ty t _) = case t of
TInt -> True
TNat -> True
TString -> True
TBytes -> True
TMutez -> True
TBool -> True
TKeyHash -> True
TTimestamp -> True
TAddress -> True
_ -> False
isMutez :: Ty -> Bool
isMutez (Ty TMutez _) = True
isMutez _ = False
isTimestamp :: Ty -> Bool
isTimestamp (Ty TTimestamp _) = True
isTimestamp _ = False
isKeyHash :: Ty -> Bool
isKeyHash (Ty TKeyHash _) = True
isKeyHash _ = False
isBool :: Ty -> Bool
isBool (Ty TBool _) = True
isBool _ = False
isString :: Ty -> Bool
isString (Ty TString _) = True
isString _ = False
isInteger :: Ty -> Bool
isInteger a = isNat a || isInt a || isMutez a || isTimestamp a
isNat :: Ty -> Bool
isNat (Ty TNat _) = True
isNat _ = False
isInt :: Ty -> Bool
isInt (Ty TInt _) = True
isInt _ = False
isBytes :: Ty -> Bool
isBytes (Ty TBytes _) = True
isBytes _ = False
----------------------------------------------------------------------------
-- TH derivations
----------------------------------------------------------------------------
deriveJSON morleyAesonOptions ''Ty
deriveJSON morleyAesonOptions ''T
deriveJSON morleyAesonOptions ''ParameterType
deriveLift ''Ty
deriveLift ''T
deriveLift ''ParameterType