{-# LANGUAGE DeriveDataTypeable, DerivingStrategies #-}
module Michelson.Untyped.Ext
( ExtInstrAbstract (..)
, StackRef (..)
, PrintComment (..)
, TestAssert (..)
, Var (..)
, TyVar (..)
, StackTypePattern (..)
, StackFn (..)
, varSet
, stackTypePatternToList
) where
import Data.Aeson.TH (defaultOptions, deriveJSON)
import Data.Data (Data(..))
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Text as T
import Fmt (Buildable(build), Builder, genericF, listF)
import Michelson.Printer.Util (RenderDoc(..), renderOpsList)
import Michelson.Untyped.Type
data ExtInstrAbstract op =
STACKTYPE StackTypePattern
| FN T.Text StackFn [op]
| UTEST_ASSERT (TestAssert op)
| UPRINT PrintComment
deriving (Eq, Show, Data, Generic, Functor)
instance RenderDoc op => RenderDoc (ExtInstrAbstract op) where
renderDoc _ =
\case
FN _ _ ops -> renderOpsList False ops
_ -> mempty
isRenderable =
\case
FN {} -> True
_ -> False
instance Buildable op => Buildable (ExtInstrAbstract op) where
build = genericF
newtype StackRef = StackRef Natural
deriving (Eq, Show, Data, Generic)
instance Buildable StackRef where
build (StackRef i) = "%[" <> show 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
newtype PrintComment = PrintComment
{ unUPrintComment :: [Either T.Text StackRef]
} deriving (Eq, Show, Data, Generic)
instance Buildable PrintComment where
build = foldMap (either build build) . unUPrintComment
data TestAssert op = TestAssert
{ tassName :: T.Text
, tassComment :: PrintComment
, tassInstrs :: [op]
} deriving (Eq, Show, Functor, Data, Generic)
instance Buildable code => Buildable (TestAssert code) where
build = genericF
deriveJSON defaultOptions ''ExtInstrAbstract
deriveJSON defaultOptions ''PrintComment
deriveJSON defaultOptions ''StackTypePattern
deriveJSON defaultOptions ''StackRef
deriveJSON defaultOptions ''StackFn
deriveJSON defaultOptions ''Var
deriveJSON defaultOptions ''TyVar
deriveJSON defaultOptions ''TestAssert