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

-- | Michelson instructions in untyped model.

module Morley.Michelson.Untyped.Instr
  ( InstrAbstract (..)
  , ExpandedOp (..)
  , ExpandedInstr
  , flattenExpandedOp
  ) where

import Prelude hiding (EQ, GT, LT, group)

import Data.Aeson.TH (deriveJSON)
import Data.Aeson.Types
  (FromJSON(..), ToJSON(..), genericParseJSON, genericToEncoding, genericToJSON)
import Data.Data (Data(..))
import Fmt (Buildable(build), Doc, isEmpty, (+|), (<+>), (|+))
import Generics.SYB (everywhere, mkT)
import Prettyprinter (align, braces, enclose, group, space)
import Prettyprinter qualified as PP

import Morley.Michelson.ErrorPos (ErrorSrcPos)
import Morley.Michelson.Printer.Util (RenderDoc(..), doesntNeedParens, needsParens, renderOpsList)
import Morley.Michelson.Untyped.Annotation
  (Annotation, AnyAnn, FieldAnn, KnownAnnTag, TypeAnn, VarAnn, fullAnnSet, renderAnyAnns,
  singleAnnSet)
import Morley.Michelson.Untyped.Contract (Contract'(..))
import Morley.Michelson.Untyped.Ext
import Morley.Michelson.Untyped.HoistInstr
import Morley.Michelson.Untyped.Type (Ty)
import Morley.Michelson.Untyped.Value (Value'(..))
import Morley.Michelson.Untyped.View
import Morley.Util.Aeson

-------------------------------------
-- Types after macroexpander
-------------------------------------

type ExpandedInstr = InstrAbstract [] ExpandedOp

data ExpandedOp
  = PrimEx ExpandedInstr
  | SeqEx [ExpandedOp]
  | WithSrcEx ErrorSrcPos ExpandedOp
  deriving stock (Show, Eq, Data, Generic)

instance NFData ExpandedOp

instance RenderDoc ExpandedOp where
  renderDoc pn (WithSrcEx _ op) = renderDoc pn op
  renderDoc pn (PrimEx i) = renderDoc pn i
  renderDoc _  (SeqEx i) = renderOpsList False i
  isRenderable =
    \case PrimEx i -> isRenderable i
          WithSrcEx _ op -> isRenderable op
          _ -> True

instance Buildable ExpandedOp where
  build (WithSrcEx _ op) = build op
  build (PrimEx expandedInstr) = "<PrimEx: " +| expandedInstr |+ ">"
  build (SeqEx expandedOps)    = "<SeqEx: " +| expandedOps |+ ">"

-- | Flatten all 'SeqEx' in 'ExpandedOp'. This function is mostly for
-- testing. It returns instructions with the same logic, but they are
-- not strictly equivalent, because they are serialized differently
-- (grouping instructions into sequences affects the way they are
-- PACK'ed).
flattenExpandedOp :: ExpandedOp -> [ExpandedInstr]
flattenExpandedOp =
  \case
    PrimEx i -> [flattenInstr i]
    SeqEx ops -> concatMap flattenExpandedOp ops
    WithSrcEx _ op -> flattenExpandedOp op
  where
    flattenInstr :: ExpandedInstr -> ExpandedInstr
    flattenInstr = everywhere (mkT flattenOps)

    flattenOps :: [ExpandedOp] -> [ExpandedOp]
    flattenOps [] = []
    flattenOps (SeqEx s : xs) = s ++ flattenOps xs
    flattenOps (x@(PrimEx _) : xs) = x : flattenOps xs
    flattenOps (WithSrcEx _ op : xs) = op : flattenOps xs

-------------------------------------
-- Abstract instruction
-------------------------------------

instance HoistInstr InstrAbstract where
  hoistInstr f = \case
    EXT x -> EXT $ hoistInstr f x
    IF_NONE l r -> IF_NONE (f l) (f r)
    IF_LEFT l r -> IF_LEFT (f l) (f r)
    IF_CONS l r -> IF_CONS (f l) (f r)
    MAP ann r -> MAP ann (f r)
    ITER l -> ITER (f l)
    IF l r -> IF (f l) (f r)
    LOOP l -> LOOP (f l)
    LOOP_LEFT l -> LOOP_LEFT (f l)
    LAMBDA ann tl tr r -> LAMBDA ann tl tr (f r)
    LAMBDA_REC ann tl tr r -> LAMBDA_REC ann tl tr (f r)
    DIP l -> DIP (f l)
    DIPN w r -> DIPN w (f r)
    PUSH va x y               -> PUSH va x $ hoistInstr f y
    ---
    DROPN va                  -> DROPN va
    DROP                      -> DROP
    DUP va                    -> DUP va
    DUPN va x                 -> DUPN va x
    SWAP                      -> SWAP
    DIG va                    -> DIG va
    DUG va                    -> DUG va
    SOME va x                 -> SOME va x
    NONE va x y               -> NONE va x y
    UNIT va x                 -> UNIT va x
    PAIR va x y z             -> PAIR va x y z
    UNPAIR va x y z           -> UNPAIR va x y z
    PAIRN va x                -> PAIRN va x
    UNPAIRN va                -> UNPAIRN va
    CAR va x                  -> CAR va x
    CDR va x                  -> CDR va x
    LEFT va x y z w           -> LEFT va x y z w
    RIGHT va x y z w          -> RIGHT va x y z w
    NIL va x y                -> NIL va x y
    CONS va                   -> CONS va
    SIZE va                   -> SIZE va
    EMPTY_SET va x y          -> EMPTY_SET va x y
    EMPTY_MAP va x y z        -> EMPTY_MAP va x y z
    EMPTY_BIG_MAP va x y z    -> EMPTY_BIG_MAP va x y z
    MEM va                    -> MEM va
    GET va                    -> GET va
    GETN va x                 -> GETN va x
    UPDATE va                 -> UPDATE va
    UPDATEN va x              -> UPDATEN va x
    GET_AND_UPDATE va         -> GET_AND_UPDATE va
    EXEC va                   -> EXEC va
    APPLY va                  -> APPLY va
    FAILWITH                  -> FAILWITH
    CAST va x                 -> CAST va x
    RENAME va                 -> RENAME va
    PACK va                   -> PACK va
    UNPACK va x y             -> UNPACK va x y
    CONCAT va                 -> CONCAT va
    SLICE va                  -> SLICE va
    ISNAT va                  -> ISNAT va
    ADD va                    -> ADD va
    SUB va                    -> SUB va
    SUB_MUTEZ va              -> SUB_MUTEZ va
    MUL va                    -> MUL va
    EDIV va                   -> EDIV va
    ABS va                    -> ABS va
    NEG va                    -> NEG va
    LSL va                    -> LSL va
    LSR va                    -> LSR va
    OR va                     -> OR va
    AND va                    -> AND va
    XOR va                    -> XOR va
    NOT va                    -> NOT va
    COMPARE va                -> COMPARE va
    EQ va                     -> EQ va
    NEQ va                    -> NEQ va
    LT va                     -> LT va
    GT va                     -> GT va
    LE va                     -> LE va
    GE va                     -> GE va
    INT va                    -> INT va
    VIEW va x y               -> VIEW va x y
    SELF va x                 -> SELF va x
    CONTRACT va x y           -> CONTRACT va x y
    TRANSFER_TOKENS va        -> TRANSFER_TOKENS va
    SET_DELEGATE va           -> SET_DELEGATE va
    CREATE_CONTRACT va x y    -> CREATE_CONTRACT va x y
    IMPLICIT_ACCOUNT va       -> IMPLICIT_ACCOUNT va
    NOW va                    -> NOW va
    AMOUNT va                 -> AMOUNT va
    BALANCE va                -> BALANCE va
    VOTING_POWER va           -> VOTING_POWER va
    TOTAL_VOTING_POWER va     -> TOTAL_VOTING_POWER va
    CHECK_SIGNATURE va        -> CHECK_SIGNATURE va
    SHA256 va                 -> SHA256 va
    SHA512 va                 -> SHA512 va
    BLAKE2B va                -> BLAKE2B va
    SHA3 va                   -> SHA3 va
    KECCAK va                 -> KECCAK va
    HASH_KEY va               -> HASH_KEY va
    PAIRING_CHECK va          -> PAIRING_CHECK va
    SOURCE va                 -> SOURCE va
    SENDER va                 -> SENDER va
    ADDRESS va                -> ADDRESS va
    CHAIN_ID va               -> CHAIN_ID va
    LEVEL va                  -> LEVEL va
    SELF_ADDRESS va           -> SELF_ADDRESS va
    NEVER                     -> NEVER
    TICKET va                 -> TICKET va
    TICKET_DEPRECATED va      -> TICKET_DEPRECATED va
    READ_TICKET va            -> READ_TICKET va
    SPLIT_TICKET va           -> SPLIT_TICKET va
    JOIN_TICKETS va           -> JOIN_TICKETS va
    OPEN_CHEST va             -> OPEN_CHEST va
    SAPLING_EMPTY_STATE va x  -> SAPLING_EMPTY_STATE va x
    SAPLING_VERIFY_UPDATE va  -> SAPLING_VERIFY_UPDATE va
    MIN_BLOCK_TIME va         -> MIN_BLOCK_TIME va
    EMIT va x y               -> EMIT va x y
    BYTES va                  -> BYTES va
    NAT va                    -> NAT va

-- | Michelson instruction with abstract parameter @op@.  This
-- parameter is necessary, because at different stages of our pipeline
-- it will be different. Initially it can contain macros and
-- non-flattened instructions, but then it contains only vanilla
-- Michelson instructions.
data InstrAbstract f op
  = EXT               (ExtInstrAbstract f op)
  | DROPN              Word
  -- ^ "DROP n" instruction.
  -- Note: reference implementation permits int16 here.
  -- Negative numbers are parsed successfully there, but rejected later.
  -- Morley is more permissive, so we use 'Word' here,
  -- i. e. permit more positive numbers. We do not permit negative numbers
  -- at type level.
  -- In practice, probably nobody will ever have numbers greater than ≈1000
  -- here, at least due to gas limits.
  -- Same reasoning applies to other instructions which have a numeric
  -- parameter representing number of elements on stack.
  | DROP
  -- ^ 'DROP' is essentially as special case for 'DROPN', but we need
  -- both because they are packed differently.
  | DUP               VarAnn
  | DUPN              VarAnn Word
  | SWAP
  | DIG               Word
  | DUG               Word
  | PUSH              VarAnn Ty (Value' f op)
  | SOME              TypeAnn VarAnn
  | NONE              TypeAnn VarAnn Ty
  | UNIT              TypeAnn VarAnn
  | IF_NONE           (f op) (f op)
  | PAIR              TypeAnn VarAnn FieldAnn FieldAnn
  | UNPAIR            VarAnn VarAnn FieldAnn FieldAnn
  | PAIRN             VarAnn Word
  | UNPAIRN           Word
  | CAR               VarAnn FieldAnn
  | CDR               VarAnn FieldAnn
  | LEFT              TypeAnn VarAnn FieldAnn FieldAnn Ty
  | RIGHT             TypeAnn VarAnn FieldAnn FieldAnn Ty
  | IF_LEFT           (f op) (f op)
  | NIL               TypeAnn VarAnn Ty
  | CONS              VarAnn
  | IF_CONS           (f op) (f op)
  | SIZE              VarAnn
  | EMPTY_SET         TypeAnn VarAnn Ty
  | EMPTY_MAP         TypeAnn VarAnn Ty Ty
  | EMPTY_BIG_MAP     TypeAnn VarAnn Ty Ty
  | MAP               VarAnn (f op)
  | ITER              (f op)
  | MEM               VarAnn
  | GET               VarAnn
  | GETN              VarAnn Word
  | UPDATE            VarAnn
  | UPDATEN           VarAnn Word
  | GET_AND_UPDATE    VarAnn
  | IF                (f op) (f op)
  | LOOP              (f op)
  | LOOP_LEFT         (f op)
  | LAMBDA            VarAnn Ty Ty (f op)
  | LAMBDA_REC        VarAnn Ty Ty (f op)
  | EXEC              VarAnn
  | APPLY             VarAnn
  | DIP               (f op)
  | DIPN              Word (f op)
  | FAILWITH
  | CAST              VarAnn Ty
  | RENAME            VarAnn
  | PACK              VarAnn
  | UNPACK            TypeAnn VarAnn Ty
  | CONCAT            VarAnn
  | SLICE             VarAnn
  | ISNAT             VarAnn
  | ADD               VarAnn
  | SUB               VarAnn
  | SUB_MUTEZ         VarAnn
  | MUL               VarAnn
  | EDIV              VarAnn
  | ABS               VarAnn
  | NEG               VarAnn
  | LSL               VarAnn
  | LSR               VarAnn
  | OR                VarAnn
  | AND               VarAnn
  | XOR               VarAnn
  | NOT               VarAnn
  | COMPARE           VarAnn
  | EQ                VarAnn
  | NEQ               VarAnn
  | LT                VarAnn
  | GT                VarAnn
  | LE                VarAnn
  | GE                VarAnn
  | INT               VarAnn
  | VIEW              VarAnn ViewName Ty
  | SELF              VarAnn FieldAnn
  | CONTRACT          VarAnn FieldAnn Ty
  | TRANSFER_TOKENS   VarAnn
  | SET_DELEGATE      VarAnn
  | CREATE_CONTRACT   VarAnn VarAnn (Contract' op)
  | IMPLICIT_ACCOUNT  VarAnn
  | NOW               VarAnn
  | AMOUNT            VarAnn
  | BALANCE           VarAnn
  | VOTING_POWER      VarAnn
  | TOTAL_VOTING_POWER VarAnn
  | CHECK_SIGNATURE   VarAnn
  | SHA256            VarAnn
  | SHA512            VarAnn
  | BLAKE2B           VarAnn
  | SHA3              VarAnn
  | KECCAK            VarAnn
  | HASH_KEY          VarAnn
  | PAIRING_CHECK     VarAnn
  | SOURCE            VarAnn
  | SENDER            VarAnn
  | ADDRESS           VarAnn
  | CHAIN_ID          VarAnn
  | LEVEL             VarAnn
  | SELF_ADDRESS      VarAnn
  | NEVER
  | TICKET            VarAnn
  | TICKET_DEPRECATED VarAnn
  | READ_TICKET       VarAnn
  | SPLIT_TICKET      VarAnn
  | JOIN_TICKETS      VarAnn
  | OPEN_CHEST        VarAnn
  | SAPLING_EMPTY_STATE VarAnn Natural
  | SAPLING_VERIFY_UPDATE VarAnn
  | MIN_BLOCK_TIME    [AnyAnn]
  | EMIT              VarAnn FieldAnn (Maybe Ty)
  | BYTES             VarAnn
  | NAT               VarAnn
  deriving stock (Eq, Functor, Data, Generic, Show)

instance (NFData op, NFData (f op)) => NFData (InstrAbstract f op)

instance (RenderDoc op, Foldable f) => RenderDoc (InstrAbstract f op) where
  renderDoc pn = \case
    EXT extInstr            -> renderDoc pn extInstr
    DROP                    -> "DROP"
    DROPN n                 -> "DROP" <+> build n
    DUP va                  -> "DUP" <+> renderAnnot va
    DUPN va n               -> "DUP" <+> renderAnnot va <+> build n
    SWAP                    -> "SWAP"
    DIG n                   -> "DIG" <+> build n
    DUG n                   -> "DUG" <+> build n
    PUSH va t v             ->
      renderArgs "PUSH" (renderAnnot va) [renderTy t, renderDoc needsParens v]
    SOME ta va              -> "SOME" <+> renderAnnots [ta] [] [va]
    NONE ta va t            -> renderArgs "NONE" (renderAnnots [ta] [] [va]) [renderTy t]
    UNIT ta va              -> "UNIT" <+> renderAnnots [ta] [] [va]
    IF_NONE x y             -> renderArgs "IF_NONE" mempty [renderOps x, renderOps y]
    PAIR ta va fa1 fa2      -> "PAIR" <+> renderAnnots [ta] [fa1, fa2] [va]
    UNPAIR va1 va2 fa1 fa2  -> "UNPAIR" <+> renderAnnots [] [fa1, fa2] [va1, va2]
    PAIRN va n              -> "PAIR" <+> renderAnnots [] [] [va] <+> build n
    UNPAIRN n               -> "UNPAIR" <+> build n
    CAR va fa               -> "CAR" <+> renderAnnots [] [fa] [va]
    CDR va fa               -> "CDR" <+> renderAnnots [] [fa] [va]
    LEFT ta va fa1 fa2 t    -> renderArgs "LEFT" (renderAnnots [ta] [fa1, fa2] [va]) [renderTy t]
    RIGHT ta va fa1 fa2 t   -> renderArgs "RIGHT" (renderAnnots [ta] [fa1, fa2] [va]) [renderTy t]
    IF_LEFT x y             -> renderArgs "IF_LEFT" mempty [renderOps x, renderOps y]
    NIL ta va t             -> renderArgs "NIL" (renderAnnots [ta] [] [va]) [renderTy t]
    CONS va                 -> "CONS" <+> renderAnnot va
    IF_CONS x y             -> renderArgs "IF_CONS" mempty [renderOps x, renderOps y]
    SIZE va                 -> "SIZE" <+> renderAnnot va
    EMPTY_SET ta va t       -> renderArgs "EMPTY_SET" (renderAnnots [ta] [] [va]) [renderComp t]
    EMPTY_MAP ta va c t     ->
      renderArgs "EMPTY_MAP" (renderAnnots [ta] [] [va]) [renderComp c, renderTy t]
    EMPTY_BIG_MAP ta va c t ->
      renderArgs "EMPTY_BIG_MAP" (renderAnnots [ta] [] [va]) [renderComp c, renderTy t]
    MAP va s                -> renderArgs "MAP" (renderAnnot va) [renderOps s]
    ITER s                  -> renderArgs "ITER" mempty [renderOps s]
    MEM va                  -> "MEM" <+> renderAnnot va
    GET va                  -> "GET" <+> renderAnnot va
    GETN va n               -> "GET" <+> renderAnnot va <+> build n
    UPDATE va               -> "UPDATE" <+> renderAnnot va
    UPDATEN va n            -> "UPDATE" <+> renderAnnot va <+> build n
    GET_AND_UPDATE va       -> "GET_AND_UPDATE" <+> renderAnnot va
    IF x y                  -> renderArgs "IF" mempty [renderOps x, renderOps y]
    LOOP s                  -> renderArgs "LOOP" mempty [renderOps s]
    LOOP_LEFT s             -> renderArgs "LOOP_LEFT" mempty [renderOps s]
    LAMBDA va t r s         ->
      renderArgs "LAMBDA" (renderAnnot va) [renderTy t, renderTy r, renderOps s]
    LAMBDA_REC va t r s     ->
      renderArgs "LAMBDA_REC" (renderAnnot va) [renderTy t, renderTy r, renderOps s]
    EXEC va                 -> "EXEC" <+> renderAnnot va
    APPLY va                -> "APPLY" <+> renderAnnot va
    DIP s                   -> renderArgs "DIP" mempty [renderOps s]
    DIPN n s                -> renderArgs "DIP" mempty [build n, renderOps s]
    FAILWITH                -> "FAILWITH"
    CAST va t               -> renderArgs "CAST" (renderAnnot va) [renderTy t]
    RENAME va               -> "RENAME" <+> renderAnnot va
    PACK va                 -> "PACK" <+> renderAnnot va
    UNPACK ta va t          -> renderArgs "UNPACK" (renderAnnots [ta] [] [va]) [renderTy t]
    CONCAT va               -> "CONCAT" <+> renderAnnot va
    SLICE va                -> "SLICE" <+> renderAnnot va
    ISNAT va                -> "ISNAT" <+> renderAnnot va
    ADD va                  -> "ADD" <+> renderAnnot va
    SUB va                  -> "SUB" <+> renderAnnot va
    SUB_MUTEZ va            -> "SUB_MUTEZ" <+> renderAnnot va
    MUL va                  -> "MUL" <+> renderAnnot va
    EDIV va                 -> "EDIV" <+> renderAnnot va
    ABS va                  -> "ABS" <+> renderAnnot va
    NEG va                  -> "NEG" <+> renderAnnot va
    LSL va                  -> "LSL" <+> renderAnnot va
    LSR va                  -> "LSR" <+> renderAnnot va
    OR  va                  -> "OR" <+> renderAnnot va
    AND va                  -> "AND" <+> renderAnnot va
    XOR va                  -> "XOR" <+> renderAnnot va
    NOT va                  -> "NOT" <+> renderAnnot va
    COMPARE va              -> "COMPARE" <+> renderAnnot va
    EQ va                   -> "EQ" <+> renderAnnot va
    NEQ va                  -> "NEQ" <+> renderAnnot va
    LT va                   -> "LT" <+> renderAnnot va
    GT va                   -> "GT" <+> renderAnnot va
    LE va                   -> "LE" <+> renderAnnot va
    GE va                   -> "GE" <+> renderAnnot va
    INT va                  -> "INT" <+> renderAnnot va
    VIEW va name ty         ->
      renderArgs "VIEW" (renderAnnot va) [renderViewName name, renderTy ty]
    SELF va fa              -> "SELF" <+> renderAnnots [] [fa] [va]
    CONTRACT va fa t        -> renderArgs "CONTRACT" (renderAnnots [] [fa] [va]) [renderTy t]
    TRANSFER_TOKENS va      -> "TRANSFER_TOKENS" <+> renderAnnot va
    SET_DELEGATE va         -> "SET_DELEGATE" <+> renderAnnot va
    CREATE_CONTRACT va1 va2 contract -> let
      body = enclose space space $ align $ renderDoc doesntNeedParens contract
      in renderArgs "CREATE_CONTRACT" (renderAnnots [] [] [va1, va2]) [braces $ body]
    IMPLICIT_ACCOUNT va      -> "IMPLICIT_ACCOUNT" <+> renderAnnot va
    NOW va                   -> "NOW" <+> renderAnnot va
    AMOUNT va                -> "AMOUNT" <+> renderAnnot va
    BALANCE va               -> "BALANCE" <+> renderAnnot va
    VOTING_POWER va          -> "VOTING_POWER" <+> renderAnnot va
    TOTAL_VOTING_POWER va    -> "TOTAL_VOTING_POWER" <+> renderAnnot va
    CHECK_SIGNATURE va       -> "CHECK_SIGNATURE" <+> renderAnnot va
    SHA256 va                -> "SHA256" <+> renderAnnot va
    SHA512 va                -> "SHA512" <+> renderAnnot va
    BLAKE2B va               -> "BLAKE2B" <+> renderAnnot va
    SHA3 va                  -> "SHA3" <+> renderAnnot va
    KECCAK va                -> "KECCAK" <+> renderAnnot va
    HASH_KEY va              -> "HASH_KEY" <+> renderAnnot va
    PAIRING_CHECK va         -> "PAIRING_CHECK" <+> renderAnnot va
    SOURCE va                -> "SOURCE" <+> renderAnnot va
    SENDER va                -> "SENDER" <+> renderAnnot va
    ADDRESS va               -> "ADDRESS" <+> renderAnnot va
    CHAIN_ID va              -> "CHAIN_ID" <+> renderAnnot va
    LEVEL va                 -> "LEVEL" <+> renderAnnot va
    SELF_ADDRESS va          -> "SELF_ADDRESS" <+> renderAnnot va
    NEVER                    -> "NEVER"
    TICKET va                -> "TICKET" <+> renderAnnot va
    TICKET_DEPRECATED va     -> "TICKET_DEPRECATED" <+> renderAnnot va
    READ_TICKET va           -> "READ_TICKET" <+> renderAnnot va
    SPLIT_TICKET va          -> "SPLIT_TICKET" <+> renderAnnot va
    JOIN_TICKETS va          -> "JOIN_TICKETS" <+> renderAnnot va
    OPEN_CHEST va            -> "OPEN_CHEST" <+> renderAnnot va
    EMIT va fa ty            ->
      renderArgs "EMIT" (renderAnnots [] [fa] [va]) $ maybeToList $ renderTy <$> ty
    SAPLING_EMPTY_STATE va n -> "SAPLING_EMPTY_STATE" <+> renderAnnot va <+> build n
    SAPLING_VERIFY_UPDATE va -> "SAPLING_VERIFY_UPDATE" <+> renderAnnot va
    MIN_BLOCK_TIME anns      -> "MIN_BLOCK_TIME" <+> renderAnyAnns anns
    BYTES va                 -> "BYTES" <+> renderAnnot va
    NAT va                   -> "NAT" <+> renderAnnot va
    where
      renderTy = renderDoc @Ty needsParens
      renderComp = renderDoc @Ty needsParens
      renderOps = renderOpsList False

      renderAnnot :: KnownAnnTag tag => Annotation tag -> Doc
      renderAnnot = renderDoc doesntNeedParens . singleAnnSet

      renderAnnots :: [TypeAnn] -> [FieldAnn] -> [VarAnn] -> Doc
      renderAnnots ts fs vs = renderDoc doesntNeedParens $ fullAnnSet ts fs vs

      renderArgs :: Text -> Doc -> [Doc] -> Doc
      renderArgs name annots args
        | isEmpty annots && length name <= 3
        = group $ build name <+> annots <+> PP.align (PP.vsep args)
        | otherwise
        = group $ PP.hang 2 $ PP.vsep $ build name <+> annots : args

  isRenderable = \case
    EXT extInstr -> isRenderable extInstr
    _ -> True

instance (Foldable f, RenderDoc op, Buildable op)
  => Buildable (InstrAbstract f op) where
  build = \case
    EXT ext -> build ext
    mi -> group $ renderDoc doesntNeedParens mi

----------------------------------------------------------------------------
-- JSON serialization
----------------------------------------------------------------------------

instance (FromJSON op, FromJSON (f op)) => FromJSON (InstrAbstract f op) where
    parseJSON = genericParseJSON morleyAesonOptions
instance (ToJSON op, ToJSON (f op)) => ToJSON (InstrAbstract f op) where
    toJSON     = genericToJSON morleyAesonOptions
    toEncoding = genericToEncoding morleyAesonOptions

deriveJSON morleyAesonOptions ''ExpandedOp