{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE DeriveDataTypeable, DerivingStrategies #-}
module Morley.Types
(
Parameter
, Storage
, Contract (..)
, Value (..)
, Elt (..)
, InstrAbstract (..)
, Instr
, Op (..)
, TypeAnn
, FieldAnn
, VarAnn
, ann
, noAnn
, Type (..)
, Comparable (..)
, T (..)
, CT (..)
, Annotation (..)
, InternalByteString(..)
, unInternalByteString
, CustomParserException (..)
, Parser
, Parsec
, ParseErrorBundle
, ParserException (..)
, LetEnv (..)
, noLetEnv
, UExtInstrAbstract(..)
, ParsedInstr
, ParsedOp (..)
, ParsedUTestAssert
, ParsedUExtInstr
, ExpandedInstr
, ExpandedOp (..)
, ExpandedUExtInstr
, PairStruct (..)
, CadrStruct (..)
, Macro (..)
, ExtInstr(..)
, TestAssert (..)
, UTestAssert (..)
, PrintComment (..)
, StackTypePattern (..)
, StackRef(..)
, MorleyLogs (..)
, noMorleyLogs
, StackFn(..)
, Var (..)
, TyVar (..)
, varSet
, LetMacro (..)
, LetValue (..)
, LetType (..)
) where
import Data.Aeson.TH (defaultOptions, deriveJSON)
import Data.Data (Data(..))
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Text as T
import Fmt (Buildable(build), Builder, genericF, listF, (+|), (|+))
import Text.Megaparsec (ParseErrorBundle, Parsec, ShowErrorComponent(..), errorBundlePretty)
import qualified Text.PrettyPrint.Leijen.Text as PP (empty)
import qualified Text.Show (show)
import Michelson.EqParam (eqParam2)
import Michelson.Printer (RenderDoc(..))
import Michelson.Typed (instrToOps)
import qualified Michelson.Typed as T
import Michelson.Untyped
(Annotation(..), CT(..), Comparable(..), Contract(..), Elt(..), ExpandedInstr, ExpandedOp(..),
ExtU, FieldAnn, Instr, InstrAbstract(..), InternalByteString(..), Op(..), Parameter, Storage,
T(..), Type(..), TypeAnn, Value(..), VarAnn, ann, noAnn, unInternalByteString)
import Morley.Default (Default(..))
data CustomParserException
= UnknownTypeException
| OddNumberBytesException
| UnexpectedLineBreak
deriving (Eq, Data, Ord, Show)
instance ShowErrorComponent CustomParserException where
showErrorComponent UnknownTypeException = "unknown type"
showErrorComponent OddNumberBytesException = "odd number bytes"
showErrorComponent UnexpectedLineBreak = "unexpected linebreak"
type Parser = ReaderT LetEnv (Parsec CustomParserException T.Text)
instance Default a => Default (Parser a) where
def = pure def
data ParserException =
ParserException (ParseErrorBundle T.Text CustomParserException)
instance Show ParserException where
show (ParserException bundle) = errorBundlePretty bundle
instance Exception ParserException where
displayException (ParserException bundle) = errorBundlePretty bundle
instance Buildable ParserException where
build = build @String . show
data LetEnv = LetEnv
{ letMacros :: Map Text LetMacro
, letValues :: Map Text LetValue
, letTypes :: Map Text LetType
} deriving (Show, Eq)
noLetEnv :: LetEnv
noLetEnv = LetEnv Map.empty Map.empty Map.empty
data UExtInstrAbstract op =
STACKTYPE StackTypePattern
| FN T.Text StackFn
| FN_END
| UTEST_ASSERT (UTestAssert op)
| UPRINT PrintComment
deriving (Eq, Show, Data, Generic, Functor)
instance Buildable op => Buildable (UExtInstrAbstract op) where
build = genericF
type instance ExtU InstrAbstract = UExtInstrAbstract
type instance T.ExtT T.Instr = ExtInstr
type ParsedUTestAssert = UTestAssert ParsedOp
type ParsedUExtInstr = UExtInstrAbstract ParsedOp
type ParsedInstr = InstrAbstract ParsedOp
data ParsedOp
= Prim ParsedInstr
| Mac Macro
| LMac LetMacro
| Seq [ParsedOp]
deriving (Eq, Show, Data, Generic)
instance RenderDoc ParsedOp where
renderDoc _ = PP.empty
instance Buildable ParsedOp where
build (Prim parseInstr) = "<Prim: "+|parseInstr|+">"
build (Mac macro) = "<Mac: "+|macro|+">"
build (LMac letMacro) = "<LMac: "+|letMacro|+">"
build (Seq parsedOps) = "<Seq: "+|parsedOps|+">"
type ExpandedUExtInstr = UExtInstrAbstract ExpandedOp
data TestAssert where
TestAssert
:: (Typeable inp, Typeable out)
=> T.Text
-> PrintComment
-> T.Instr inp ('T.Tc 'CBool ': out)
-> TestAssert
deriving instance Show TestAssert
instance Eq TestAssert where
TestAssert name1 pattern1 instr1
==
TestAssert name2 pattern2 instr2
= and
[ name1 == name2
, pattern1 == pattern2
, instr1 `eqParam2` instr2
]
data ExtInstr
= TEST_ASSERT TestAssert
| PRINT PrintComment
deriving (Show, Eq)
instance T.Conversible ExtInstr (UExtInstrAbstract ExpandedOp) where
convert (PRINT pc) = UPRINT pc
convert (TEST_ASSERT (TestAssert nm pc i)) =
UTEST_ASSERT $ UTestAssert nm pc (instrToOps i)
newtype MorleyLogs = MorleyLogs
{ unMorleyLogs :: [T.Text]
} deriving stock (Eq, Show)
deriving newtype (Default, Buildable)
noMorleyLogs :: MorleyLogs
noMorleyLogs = MorleyLogs []
data PairStruct
= F (VarAnn, FieldAnn)
| P PairStruct PairStruct
deriving (Eq, Show, Data, Generic)
instance Buildable PairStruct where
build = genericF
data CadrStruct
= A
| D
deriving (Eq, Show, Data, Generic)
instance Buildable CadrStruct where
build = genericF
data Macro
= CMP ParsedInstr VarAnn
| IFX ParsedInstr [ParsedOp] [ParsedOp]
| IFCMP ParsedInstr VarAnn [ParsedOp] [ParsedOp]
| FAIL
| PAPAIR PairStruct TypeAnn VarAnn
| UNPAIR PairStruct
| CADR [CadrStruct] VarAnn FieldAnn
| SET_CADR [CadrStruct] VarAnn FieldAnn
| MAP_CADR [CadrStruct] VarAnn FieldAnn [ParsedOp]
| DIIP Integer [ParsedOp]
| DUUP Integer VarAnn
| ASSERT
| ASSERTX ParsedInstr
| ASSERT_CMP ParsedInstr
| ASSERT_NONE
| ASSERT_SOME
| ASSERT_LEFT
| ASSERT_RIGHT
| IF_SOME [ParsedOp] [ParsedOp]
deriving (Eq, Show, Data, Generic)
instance Buildable Macro where
build (CMP parsedInstr carAnn) = "<CMP: "+|parsedInstr|+", "+|carAnn|+">"
build (IFX parsedInstr parsedOps1 parsedOps2) = "<IFX: "+|parsedInstr|+", "+|parsedOps1|+", "+|parsedOps2|+">"
build (IFCMP parsedInstr varAnn parsedOps1 parsedOps2) = "<IFCMP: "+|parsedInstr|+", "+|varAnn|+", "+|parsedOps1|+", "+|parsedOps2|+">"
build FAIL = "FAIL"
build (PAPAIR pairStruct typeAnn varAnn) = "<PAPAIR: "+|pairStruct|+", "+|typeAnn|+", "+|varAnn|+">"
build (UNPAIR pairStruct) = "<UNPAIR: "+|pairStruct|+">"
build (CADR cadrStructs varAnn fieldAnn) = "<CADR: "+|cadrStructs|+", "+|varAnn|+", "+|fieldAnn|+">"
build (SET_CADR cadrStructs varAnn fieldAnn) = "<SET_CADR: "+|cadrStructs|+", "+|varAnn|+", "+|fieldAnn|+">"
build (MAP_CADR cadrStructs varAnn fieldAnn parsedOps) = "<MAP_CADR: "+|cadrStructs|+", "+|varAnn|+", "+|fieldAnn|+", "+|parsedOps|+">"
build (DIIP integer parsedOps) = "<DIIP: "+|integer|+", "+|parsedOps|+">"
build (DUUP integer varAnn) = "<DUUP: "+|integer|+", "+|varAnn|+">"
build ASSERT = "ASSERT"
build (ASSERTX parsedInstr) = "<ASSERTX: "+|parsedInstr|+">"
build (ASSERT_CMP parsedInstr) = "<ASSERT_CMP: "+|parsedInstr|+">"
build ASSERT_NONE = "ASSERT_NONE"
build ASSERT_SOME = "ASSERT_SOME"
build ASSERT_LEFT = "ASSERT_LEFT"
build ASSERT_RIGHT = "ASSERT_RIGHT"
build (IF_SOME parsedOps1 parsedOps2) = "<IF_SOME: "+|parsedOps1|+", "+|parsedOps2|+">"
newtype StackRef = StackRef Integer
deriving (Eq, Show, Data, Generic)
instance Buildable StackRef where
build (StackRef i) = "%[" <> build i <> "]"
newtype Var = Var T.Text deriving (Eq, Show, Ord, Data, Generic)
instance Buildable Var where
build = genericF
data TyVar =
VarID Var
| TyCon Type
deriving (Eq, Show, Data, Generic)
instance Buildable TyVar where
build = genericF
data StackTypePattern
= StkEmpty
| StkRest
| StkCons TyVar StackTypePattern
deriving (Eq, Show, Data, Generic)
stackTypePatternToList :: StackTypePattern -> ([TyVar], Bool)
stackTypePatternToList StkEmpty = ([], True)
stackTypePatternToList StkRest = ([], False)
stackTypePatternToList (StkCons t pat) =
first (t :) $ stackTypePatternToList pat
instance Buildable StackTypePattern where
build = listF . pairToList . stackTypePatternToList
where
pairToList :: ([TyVar], Bool) -> [Builder]
pairToList (types, fixed)
| fixed = map build types
| otherwise = map build types ++ ["..."]
data StackFn = StackFn
{ quantifiedVars :: Maybe (Set Var)
, inPattern :: StackTypePattern
, outPattern :: StackTypePattern
} deriving (Eq, Show, Data, Generic)
instance Buildable StackFn where
build = genericF
varSet :: StackTypePattern -> Set Var
varSet StkEmpty = Set.empty
varSet StkRest = Set.empty
varSet (StkCons (VarID v) stk) = v `Set.insert` (varSet stk)
varSet (StkCons _ stk) = varSet stk
data LetMacro = LetMacro
{ lmName :: T.Text
, lmSig :: StackFn
, lmExpr :: [ParsedOp]
} deriving (Eq, Show, Data, Generic)
instance Buildable LetMacro where
build = genericF
data LetValue = LetValue
{ lvName :: T.Text
, lvSig :: Type
, lvVal :: (Value ParsedOp)
} deriving (Eq, Show)
data LetType = LetType
{ ltName :: T.Text
, ltSig :: Type
} deriving (Eq, Show)
newtype PrintComment = PrintComment
{ unPrintComment :: [Either T.Text StackRef]
} deriving (Eq, Show, Data, Generic)
instance Buildable PrintComment where
build = foldMap (either build build) . unPrintComment
data UTestAssert op = UTestAssert
{ tassName :: T.Text
, tassComment :: PrintComment
, tassInstrs :: [op]
} deriving (Eq, Show, Functor, Data, Generic)
instance Buildable code => Buildable (UTestAssert code) where
build = genericF
deriveJSON defaultOptions ''ParsedOp
deriveJSON defaultOptions ''UExtInstrAbstract
deriveJSON defaultOptions ''PrintComment
deriveJSON defaultOptions ''StackTypePattern
deriveJSON defaultOptions ''StackRef
deriveJSON defaultOptions ''StackFn
deriveJSON defaultOptions ''Var
deriveJSON defaultOptions ''TyVar
deriveJSON defaultOptions ''LetMacro
deriveJSON defaultOptions ''LetValue
deriveJSON defaultOptions ''LetType
deriveJSON defaultOptions ''UTestAssert
deriveJSON defaultOptions ''PairStruct
deriveJSON defaultOptions ''CadrStruct
deriveJSON defaultOptions ''Macro