-- SPDX-FileCopyrightText: 2020 Tocqueville Group
-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA
-- SPDX-License-Identifier: LicenseRef-MIT-obsidian-systems

{-# LANGUAGE DeriveLift #-}

-- | Module that defines Expression type, its related types
-- and its JSON instance.
module Morley.Micheline.Expression
  ( Exp
    ( ..
    , ExpPrim'
    )
  , expressionInt
  , expressionString
  , expressionBytes
  , expressionSeq
  , expressionPrim
  , expressionPrim'
  , RegularExp
  , Expression
  , MichelinePrimAp(..)
  , MichelinePrimitive(..)
  , michelsonPrimitive
  , ExpExtensionDescriptorKind
  , ExpExtensionDescriptor (..)

  , ExpExtrasConstrained
  , ExpAllExtrasConstrainted
  , ExpExtras (..)
  , mkUniformExpExtras
  , hoistExpExtras

  , Annotation (..)
  , annotToText
  , annotFromText
  , isAnnotationField
  , isAnnotationType
  , isAnnotationVariable
  , isNoAnn
  , mkAnns
  , toAnnSet
  , mkAnnsFromAny

  -- * Prisms
  , _ExpInt
  , _ExpString
  , _ExpBytes
  , _ExpSeq
  , _ExpPrim
  , _ExpressionInt
  , _ExpressionString
  , _ExpressionBytes
  , _ExpressionSeq
  , _ExpressionPrim
  , _AnnotationField
  , _AnnotationVariable
  , _AnnotationType

  -- * Lenses
  , mpaPrimL
  , mpaArgsL
  , mpaAnnotsL
  ) where

import Control.Lens (Iso', Plated, Prism', iso, prism')
import Control.Lens.TH (makeLensesWith, makePrisms)

import Data.Aeson
  (FromJSON, ToJSON, object, parseJSON, toEncoding, toJSON, withObject, withText, (.!=), (.:),
  (.:?), (.=))
import Data.Aeson.Encoding.Internal qualified as Aeson
import Data.Aeson.KeyMap qualified as KeyMap
import Data.Aeson.Types qualified as Aeson
import Data.Data (Data)
import Data.Sequence qualified as Seq
import Data.Text qualified as T (uncons)
import Fmt (Buildable(..), pretty, (+|), (|+))

import Language.Haskell.TH.Syntax (Lift)
import Morley.Micheline.Json (StringEncode(StringEncode, unStringEncode))
import Morley.Michelson.Untyped qualified as U
import Morley.Michelson.Untyped.Annotation
  (AnnotationSet(..), FieldAnn, FieldTag, KnownAnnTag(..), TypeAnn, TypeTag, VarAnn, VarTag,
  annPrefix, fullAnnSet, minimizeAnnSet, mkAnnotation)
import Morley.Tezos.Crypto (encodeBase58Check)
import Morley.Util.ByteString (HexJSONByteString(..))
import Morley.Util.Lens (postfixLFields)

newtype MichelinePrimitive = MichelinePrimitive Text
  deriving newtype (MichelinePrimitive -> MichelinePrimitive -> Bool
(MichelinePrimitive -> MichelinePrimitive -> Bool)
-> (MichelinePrimitive -> MichelinePrimitive -> Bool)
-> Eq MichelinePrimitive
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MichelinePrimitive -> MichelinePrimitive -> Bool
$c/= :: MichelinePrimitive -> MichelinePrimitive -> Bool
== :: MichelinePrimitive -> MichelinePrimitive -> Bool
$c== :: MichelinePrimitive -> MichelinePrimitive -> Bool
Eq, Eq MichelinePrimitive
Eq MichelinePrimitive
-> (MichelinePrimitive -> MichelinePrimitive -> Ordering)
-> (MichelinePrimitive -> MichelinePrimitive -> Bool)
-> (MichelinePrimitive -> MichelinePrimitive -> Bool)
-> (MichelinePrimitive -> MichelinePrimitive -> Bool)
-> (MichelinePrimitive -> MichelinePrimitive -> Bool)
-> (MichelinePrimitive -> MichelinePrimitive -> MichelinePrimitive)
-> (MichelinePrimitive -> MichelinePrimitive -> MichelinePrimitive)
-> Ord MichelinePrimitive
MichelinePrimitive -> MichelinePrimitive -> Bool
MichelinePrimitive -> MichelinePrimitive -> Ordering
MichelinePrimitive -> MichelinePrimitive -> MichelinePrimitive
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: MichelinePrimitive -> MichelinePrimitive -> MichelinePrimitive
$cmin :: MichelinePrimitive -> MichelinePrimitive -> MichelinePrimitive
max :: MichelinePrimitive -> MichelinePrimitive -> MichelinePrimitive
$cmax :: MichelinePrimitive -> MichelinePrimitive -> MichelinePrimitive
>= :: MichelinePrimitive -> MichelinePrimitive -> Bool
$c>= :: MichelinePrimitive -> MichelinePrimitive -> Bool
> :: MichelinePrimitive -> MichelinePrimitive -> Bool
$c> :: MichelinePrimitive -> MichelinePrimitive -> Bool
<= :: MichelinePrimitive -> MichelinePrimitive -> Bool
$c<= :: MichelinePrimitive -> MichelinePrimitive -> Bool
< :: MichelinePrimitive -> MichelinePrimitive -> Bool
$c< :: MichelinePrimitive -> MichelinePrimitive -> Bool
compare :: MichelinePrimitive -> MichelinePrimitive -> Ordering
$ccompare :: MichelinePrimitive -> MichelinePrimitive -> Ordering
Ord, String -> MichelinePrimitive
(String -> MichelinePrimitive) -> IsString MichelinePrimitive
forall a. (String -> a) -> IsString a
fromString :: String -> MichelinePrimitive
$cfromString :: String -> MichelinePrimitive
IsString, [MichelinePrimitive] -> Encoding
[MichelinePrimitive] -> Value
MichelinePrimitive -> Encoding
MichelinePrimitive -> Value
(MichelinePrimitive -> Value)
-> (MichelinePrimitive -> Encoding)
-> ([MichelinePrimitive] -> Value)
-> ([MichelinePrimitive] -> Encoding)
-> ToJSON MichelinePrimitive
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [MichelinePrimitive] -> Encoding
$ctoEncodingList :: [MichelinePrimitive] -> Encoding
toJSONList :: [MichelinePrimitive] -> Value
$ctoJSONList :: [MichelinePrimitive] -> Value
toEncoding :: MichelinePrimitive -> Encoding
$ctoEncoding :: MichelinePrimitive -> Encoding
toJSON :: MichelinePrimitive -> Value
$ctoJSON :: MichelinePrimitive -> Value
ToJSON, Value -> Parser [MichelinePrimitive]
Value -> Parser MichelinePrimitive
(Value -> Parser MichelinePrimitive)
-> (Value -> Parser [MichelinePrimitive])
-> FromJSON MichelinePrimitive
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [MichelinePrimitive]
$cparseJSONList :: Value -> Parser [MichelinePrimitive]
parseJSON :: Value -> Parser MichelinePrimitive
$cparseJSON :: Value -> Parser MichelinePrimitive
FromJSON)
  deriving stock (Int -> MichelinePrimitive -> ShowS
[MichelinePrimitive] -> ShowS
MichelinePrimitive -> String
(Int -> MichelinePrimitive -> ShowS)
-> (MichelinePrimitive -> String)
-> ([MichelinePrimitive] -> ShowS)
-> Show MichelinePrimitive
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MichelinePrimitive] -> ShowS
$cshowList :: [MichelinePrimitive] -> ShowS
show :: MichelinePrimitive -> String
$cshow :: MichelinePrimitive -> String
showsPrec :: Int -> MichelinePrimitive -> ShowS
$cshowsPrec :: Int -> MichelinePrimitive -> ShowS
Show, Typeable MichelinePrimitive
Typeable MichelinePrimitive
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g)
    -> MichelinePrimitive
    -> c MichelinePrimitive)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c MichelinePrimitive)
-> (MichelinePrimitive -> Constr)
-> (MichelinePrimitive -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c MichelinePrimitive))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c MichelinePrimitive))
-> ((forall b. Data b => b -> b)
    -> MichelinePrimitive -> MichelinePrimitive)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> MichelinePrimitive -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> MichelinePrimitive -> r)
-> (forall u.
    (forall d. Data d => d -> u) -> MichelinePrimitive -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> MichelinePrimitive -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d)
    -> MichelinePrimitive -> m MichelinePrimitive)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> MichelinePrimitive -> m MichelinePrimitive)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> MichelinePrimitive -> m MichelinePrimitive)
-> Data MichelinePrimitive
MichelinePrimitive -> DataType
MichelinePrimitive -> Constr
(forall b. Data b => b -> b)
-> MichelinePrimitive -> MichelinePrimitive
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int -> (forall d. Data d => d -> u) -> MichelinePrimitive -> u
forall u. (forall d. Data d => d -> u) -> MichelinePrimitive -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> MichelinePrimitive -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> MichelinePrimitive -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> MichelinePrimitive -> m MichelinePrimitive
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> MichelinePrimitive -> m MichelinePrimitive
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c MichelinePrimitive
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> MichelinePrimitive
-> c MichelinePrimitive
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c MichelinePrimitive)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c MichelinePrimitive)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> MichelinePrimitive -> m MichelinePrimitive
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> MichelinePrimitive -> m MichelinePrimitive
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> MichelinePrimitive -> m MichelinePrimitive
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> MichelinePrimitive -> m MichelinePrimitive
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> MichelinePrimitive -> m MichelinePrimitive
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> MichelinePrimitive -> m MichelinePrimitive
gmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> MichelinePrimitive -> u
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> MichelinePrimitive -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> MichelinePrimitive -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> MichelinePrimitive -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> MichelinePrimitive -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> MichelinePrimitive -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> MichelinePrimitive -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> MichelinePrimitive -> r
gmapT :: (forall b. Data b => b -> b)
-> MichelinePrimitive -> MichelinePrimitive
$cgmapT :: (forall b. Data b => b -> b)
-> MichelinePrimitive -> MichelinePrimitive
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c MichelinePrimitive)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c MichelinePrimitive)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c MichelinePrimitive)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c MichelinePrimitive)
dataTypeOf :: MichelinePrimitive -> DataType
$cdataTypeOf :: MichelinePrimitive -> DataType
toConstr :: MichelinePrimitive -> Constr
$ctoConstr :: MichelinePrimitive -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c MichelinePrimitive
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c MichelinePrimitive
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> MichelinePrimitive
-> c MichelinePrimitive
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> MichelinePrimitive
-> c MichelinePrimitive
Data, (forall (m :: * -> *). Quote m => MichelinePrimitive -> m Exp)
-> (forall (m :: * -> *).
    Quote m =>
    MichelinePrimitive -> Code m MichelinePrimitive)
-> Lift MichelinePrimitive
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => MichelinePrimitive -> m Exp
forall (m :: * -> *).
Quote m =>
MichelinePrimitive -> Code m MichelinePrimitive
liftTyped :: forall (m :: * -> *).
Quote m =>
MichelinePrimitive -> Code m MichelinePrimitive
$cliftTyped :: forall (m :: * -> *).
Quote m =>
MichelinePrimitive -> Code m MichelinePrimitive
lift :: forall (m :: * -> *). Quote m => MichelinePrimitive -> m Exp
$clift :: forall (m :: * -> *). Quote m => MichelinePrimitive -> m Exp
Lift)

michelsonPrimitive :: Seq Text
michelsonPrimitive :: Seq Text
michelsonPrimitive = [Text] -> Seq Text
forall a. [a] -> Seq a
Seq.fromList [
  -- NOTE: The order of this list *matters*!
  --
  -- The position of each item in the list determines which binary code it gets packed to.
  -- E.g.
  --   * "parameter" is at index 0 on the list, so it gets packed to `0x0300`
  --   * "storage" is at index 1, so it gets packed to `0x0301`
  --
  -- You can ask `tezos-client` which code corresponds to a given instruction/type/constructor.
  --
  -- > tezos-client convert data 'storage' from michelson to binary
  -- > 0x0301
  --
  -- Whenever new instructions/types/constructors are added to the protocol,
  -- we can regenerate this list using this script:
  --
  -- > ./scripts/get-micheline-exprs.sh
  --
  -- or find the full primitives list in the <https://gitlab.com/tezos/tezos/blob/master/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml | sources>,
  -- see "prim_encoding" variable.
  --
  Text
"parameter", Text
"storage", Text
"code", Text
"False", Text
"Elt", Text
"Left", Text
"None", Text
"Pair",
  Text
"Right", Text
"Some", Text
"True", Text
"Unit", Text
"PACK", Text
"UNPACK", Text
"BLAKE2B", Text
"SHA256",
  Text
"SHA512", Text
"ABS", Text
"ADD", Text
"AMOUNT", Text
"AND", Text
"BALANCE", Text
"CAR", Text
"CDR",
  Text
"CHECK_SIGNATURE", Text
"COMPARE", Text
"CONCAT", Text
"CONS", Text
"CREATE_ACCOUNT", Text
"CREATE_CONTRACT", Text
"IMPLICIT_ACCOUNT", Text
"DIP",
  Text
"DROP", Text
"DUP", Text
"EDIV", Text
"EMPTY_MAP", Text
"EMPTY_SET", Text
"EQ", Text
"EXEC", Text
"FAILWITH",
  Text
"GE", Text
"GET", Text
"GT", Text
"HASH_KEY", Text
"IF", Text
"IF_CONS", Text
"IF_LEFT", Text
"IF_NONE",
  Text
"INT", Text
"LAMBDA", Text
"LE", Text
"LEFT", Text
"LOOP", Text
"LSL", Text
"LSR", Text
"LT",
  Text
"MAP", Text
"MEM", Text
"MUL", Text
"NEG", Text
"NEQ", Text
"NIL", Text
"NONE", Text
"NOT",
  Text
"NOW", Text
"OR", Text
"PAIR", Text
"PUSH", Text
"RIGHT", Text
"SIZE", Text
"SOME", Text
"SOURCE",
  Text
"SENDER", Text
"SELF", Text
"STEPS_TO_QUOTA", Text
"SUB", Text
"SWAP", Text
"TRANSFER_TOKENS", Text
"SET_DELEGATE", Text
"UNIT",
  Text
"UPDATE", Text
"XOR", Text
"ITER", Text
"LOOP_LEFT", Text
"ADDRESS", Text
"CONTRACT", Text
"ISNAT", Text
"CAST",
  Text
"RENAME", Text
"bool", Text
"contract", Text
"int", Text
"key", Text
"key_hash", Text
"lambda", Text
"list",
  Text
"map", Text
"big_map", Text
"nat", Text
"option", Text
"or", Text
"pair", Text
"set", Text
"signature",
  Text
"string", Text
"bytes", Text
"mutez", Text
"timestamp", Text
"unit", Text
"operation", Text
"address", Text
"SLICE",
  Text
"DIG", Text
"DUG", Text
"EMPTY_BIG_MAP", Text
"APPLY", Text
"chain_id", Text
"CHAIN_ID", Text
"LEVEL", Text
"SELF_ADDRESS",
  Text
"never", Text
"NEVER", Text
"UNPAIR", Text
"VOTING_POWER", Text
"TOTAL_VOTING_POWER", Text
"KECCAK", Text
"SHA3", Text
"PAIRING_CHECK",
  Text
"bls12_381_g1", Text
"bls12_381_g2", Text
"bls12_381_fr", Text
"sapling_state", Text
"sapling_transaction_deprecated", Text
"SAPLING_EMPTY_STATE", Text
"SAPLING_VERIFY_UPDATE", Text
"ticket",
  Text
"TICKET", Text
"READ_TICKET", Text
"SPLIT_TICKET", Text
"JOIN_TICKETS", Text
"GET_AND_UPDATE", Text
"chest", Text
"chest_key", Text
"OPEN_CHEST",
  Text
"VIEW", Text
"view", Text
"constant", Text
"SUB_MUTEZ", Text
"tx_rollup_l2_address", Text
"MIN_BLOCK_TIME", Text
"sapling_transaction", Text
"EMIT"
  ]

-- | Type for Micheline Expression with extension points.
--
-- Following the Trees-that-Grow approach, this type provides the core set
-- of constructors used by Tezos accompanied with additional data (@XExp*@).
-- Plus additional constructors provided by @XExp@.
--
-- The type argument @x@ will be called /extension descriptor/ and it must have
-- @ExpExtensionDescriptor@ instance.
data Exp x
  = ExpInt (XExpInt x) Integer
  | ExpString (XExpString x) Text
  | ExpBytes (XExpBytes x) ByteString
  | ExpSeq (XExpSeq x) [Exp x]
  | ExpPrim (XExpPrim x) (MichelinePrimAp x)
  | ExpX (XExp x)

pattern ExpPrim' :: XExpPrim x -> MichelinePrimitive -> [Exp x] -> [Annotation] -> Exp x
pattern $bExpPrim' :: forall (x :: ExpExtensionDescriptorKind).
XExpPrim x
-> MichelinePrimitive -> [Exp x] -> [Annotation] -> Exp x
$mExpPrim' :: forall {r} {x :: ExpExtensionDescriptorKind}.
Exp x
-> (XExpPrim x
    -> MichelinePrimitive -> [Exp x] -> [Annotation] -> r)
-> (Void# -> r)
-> r
ExpPrim' x primAp exprs anns = ExpPrim x (MichelinePrimAp primAp exprs anns)

deriving stock instance ExpAllExtrasConstrainted Eq x => Eq (Exp x)
deriving stock instance ExpAllExtrasConstrainted Show x => Show (Exp x)
deriving stock instance (ExpAllExtrasConstrainted Data x, Typeable x) => Data (Exp x)
deriving stock instance ExpAllExtrasConstrainted Lift x => Lift (Exp x)

-- | Kind of extension descriptors.
--
-- We use a dedicated open type for this, not just @Type@, to notice earlier
-- when type arguments are mis-placed.
type ExpExtensionDescriptorKind = ExpExtensionTag -> Type
data ExpExtensionTag

-- | Defines details of extension descriptor.
class ExpExtensionDescriptor (x :: ExpExtensionDescriptorKind) where

  -- | Additional data in 'ExpInt' constructor.
  type XExpInt x :: Type
  type XExpInt _ = ()

  -- | Additional data in 'ExpString' constructor.
  type XExpString x :: Type
  type XExpString _ = ()

  -- | Additional data in 'ExpBytes' constructor.
  type XExpBytes x :: Type
  type XExpBytes _ = ()

  -- | Additional data in 'ExpSeq' constructor.
  type XExpSeq x :: Type
  type XExpSeq _ = ()

  -- | Additional data in 'ExpPrim' constructor.
  type XExpPrim x :: Type
  type XExpPrim _ = ()

  -- | Additional constructors.
  type XExp x :: Type
  type XExp _ = Void

-- | Constraint all the extra fields provided by this extension.
type ExpExtrasConstrained c x =
  Each '[c]
  [XExpInt x, XExpString x, XExpBytes x, XExpSeq x, XExpPrim x]

-- | Constraint all the extra fields and the constructor provided by
-- this extension.
type ExpAllExtrasConstrainted c x = (ExpExtrasConstrained c x, c (XExp x))

-- | A helper type that carries something for all extra fields.
--
-- Fields are carried in the given functor @f@ so that one could provide
-- a generator, parser or something else.
--
-- Extra constructor is not included here as it may need special treatment,
-- you have to carry it separately.
data ExpExtras f x = ExpExtras
  { forall (f :: * -> *) (x :: ExpExtensionDescriptorKind).
ExpExtras f x -> f (XExpInt x)
eeInt :: f (XExpInt x)
  , forall (f :: * -> *) (x :: ExpExtensionDescriptorKind).
ExpExtras f x -> f (XExpString x)
eeString :: f (XExpString x)
  , forall (f :: * -> *) (x :: ExpExtensionDescriptorKind).
ExpExtras f x -> f (XExpBytes x)
eeBytes :: f (XExpBytes x)
  , forall (f :: * -> *) (x :: ExpExtensionDescriptorKind).
ExpExtras f x -> f (XExpSeq x)
eeSeq :: f (XExpSeq x)
  , forall (f :: * -> *) (x :: ExpExtensionDescriptorKind).
ExpExtras f x -> f (XExpPrim x)
eePrim :: f (XExpPrim x)
  }

-- | Fill 'ExpExtras' with the same data, assuming all types of extras are
-- the same.
mkUniformExpExtras
  :: ( extra ~ XExpInt x
     , extra ~ XExpString x
     , extra ~ XExpBytes x
     , extra ~ XExpSeq x
     , extra ~ XExpPrim x
     )
  => f extra -> ExpExtras f x
mkUniformExpExtras :: forall extra (x :: ExpExtensionDescriptorKind) (f :: * -> *).
(extra ~ XExpInt x, extra ~ XExpString x, extra ~ XExpBytes x,
 extra ~ XExpSeq x, extra ~ XExpPrim x) =>
f extra -> ExpExtras f x
mkUniformExpExtras f extra
x = f (XExpInt x)
-> f (XExpString x)
-> f (XExpBytes x)
-> f (XExpSeq x)
-> f (XExpPrim x)
-> ExpExtras f x
forall (f :: * -> *) (x :: ExpExtensionDescriptorKind).
f (XExpInt x)
-> f (XExpString x)
-> f (XExpBytes x)
-> f (XExpSeq x)
-> f (XExpPrim x)
-> ExpExtras f x
ExpExtras f extra
f (XExpInt x)
x f extra
f (XExpString x)
x f extra
f (XExpBytes x)
x f extra
f (XExpSeq x)
x f extra
f (XExpPrim x)
x

-- | Change the functor used in 'ExpExtras'.
hoistExpExtras
  :: (forall extra. f1 extra -> f2 extra)
  -> ExpExtras f1 x -> ExpExtras f2 x
hoistExpExtras :: forall (f1 :: * -> *) (f2 :: * -> *)
       (x :: ExpExtensionDescriptorKind).
(forall extra. f1 extra -> f2 extra)
-> ExpExtras f1 x -> ExpExtras f2 x
hoistExpExtras forall extra. f1 extra -> f2 extra
f ExpExtras{f1 (XExpInt x)
f1 (XExpString x)
f1 (XExpBytes x)
f1 (XExpSeq x)
f1 (XExpPrim x)
eePrim :: f1 (XExpPrim x)
eeSeq :: f1 (XExpSeq x)
eeBytes :: f1 (XExpBytes x)
eeString :: f1 (XExpString x)
eeInt :: f1 (XExpInt x)
eePrim :: forall (f :: * -> *) (x :: ExpExtensionDescriptorKind).
ExpExtras f x -> f (XExpPrim x)
eeSeq :: forall (f :: * -> *) (x :: ExpExtensionDescriptorKind).
ExpExtras f x -> f (XExpSeq x)
eeBytes :: forall (f :: * -> *) (x :: ExpExtensionDescriptorKind).
ExpExtras f x -> f (XExpBytes x)
eeString :: forall (f :: * -> *) (x :: ExpExtensionDescriptorKind).
ExpExtras f x -> f (XExpString x)
eeInt :: forall (f :: * -> *) (x :: ExpExtensionDescriptorKind).
ExpExtras f x -> f (XExpInt x)
..} = ExpExtras :: forall (f :: * -> *) (x :: ExpExtensionDescriptorKind).
f (XExpInt x)
-> f (XExpString x)
-> f (XExpBytes x)
-> f (XExpSeq x)
-> f (XExpPrim x)
-> ExpExtras f x
ExpExtras
  { eeInt :: f2 (XExpInt x)
eeInt = f1 (XExpInt x) -> f2 (XExpInt x)
forall extra. f1 extra -> f2 extra
f f1 (XExpInt x)
eeInt
  , eeString :: f2 (XExpString x)
eeString = f1 (XExpString x) -> f2 (XExpString x)
forall extra. f1 extra -> f2 extra
f f1 (XExpString x)
eeString
  , eeBytes :: f2 (XExpBytes x)
eeBytes = f1 (XExpBytes x) -> f2 (XExpBytes x)
forall extra. f1 extra -> f2 extra
f f1 (XExpBytes x)
eeBytes
  , eeSeq :: f2 (XExpSeq x)
eeSeq = f1 (XExpSeq x) -> f2 (XExpSeq x)
forall extra. f1 extra -> f2 extra
f f1 (XExpSeq x)
eeSeq
  , eePrim :: f2 (XExpPrim x)
eePrim = f1 (XExpPrim x) -> f2 (XExpPrim x)
forall extra. f1 extra -> f2 extra
f f1 (XExpPrim x)
eePrim
  }

-- | Extension descriptor for plain expressions without additional data.
data RegularExp :: ExpExtensionDescriptorKind
instance ExpExtensionDescriptor RegularExp

-- | Simple expression without any extras.
type Expression = Exp RegularExp

expressionInt :: Integer -> Expression
expressionInt :: Integer -> Expression
expressionInt Integer
a = XExpInt RegularExp -> Integer -> Expression
forall (x :: ExpExtensionDescriptorKind).
XExpInt x -> Integer -> Exp x
ExpInt () Integer
a

expressionString :: Text -> Expression
expressionString :: Text -> Expression
expressionString Text
a = XExpString RegularExp -> Text -> Expression
forall (x :: ExpExtensionDescriptorKind).
XExpString x -> Text -> Exp x
ExpString () Text
a

expressionBytes :: ByteString -> Expression
expressionBytes :: ByteString -> Expression
expressionBytes ByteString
a = XExpBytes RegularExp -> ByteString -> Expression
forall (x :: ExpExtensionDescriptorKind).
XExpBytes x -> ByteString -> Exp x
ExpBytes () ByteString
a

expressionSeq :: [Expression] -> Expression
expressionSeq :: [Expression] -> Expression
expressionSeq [Expression]
a = XExpSeq RegularExp -> [Expression] -> Expression
forall (x :: ExpExtensionDescriptorKind).
XExpSeq x -> [Exp x] -> Exp x
ExpSeq () [Expression]
a

expressionPrim :: MichelinePrimAp RegularExp -> Expression
expressionPrim :: MichelinePrimAp RegularExp -> Expression
expressionPrim MichelinePrimAp RegularExp
a = XExpPrim RegularExp -> MichelinePrimAp RegularExp -> Expression
forall (x :: ExpExtensionDescriptorKind).
XExpPrim x -> MichelinePrimAp x -> Exp x
ExpPrim () MichelinePrimAp RegularExp
a

expressionPrim' :: Text -> [Expression] -> [Annotation] -> Expression
expressionPrim' :: Text -> [Expression] -> [Annotation] -> Expression
expressionPrim' Text
primName [Expression]
args [Annotation]
anns =
  XExpPrim RegularExp -> MichelinePrimAp RegularExp -> Expression
forall (x :: ExpExtensionDescriptorKind).
XExpPrim x -> MichelinePrimAp x -> Exp x
ExpPrim () (MichelinePrimitive
-> [Expression] -> [Annotation] -> MichelinePrimAp RegularExp
forall (x :: ExpExtensionDescriptorKind).
MichelinePrimitive -> [Exp x] -> [Annotation] -> MichelinePrimAp x
MichelinePrimAp (Text -> MichelinePrimitive
MichelinePrimitive Text
primName) [Expression]
args [Annotation]
anns)

-- | Default instance that uses @uniplate@ as implementation.
--
-- If it tries to find expressions for polymorphic types too agressively
-- (requiring 'Data' where you don't what that), feel free to define an
-- overlapping manual instance.
instance ( Typeable x
         , ExpAllExtrasConstrainted Data x
         , ExpAllExtrasConstrainted Typeable x)
         => Plated (Exp x)

instance Buildable Expression where
  build :: Expression -> Builder
build = \case
    ExpInt () Integer
i -> Integer -> Builder
forall p. Buildable p => p -> Builder
build Integer
i
    ExpString () Text
s -> Text -> Builder
forall p. Buildable p => p -> Builder
build Text
s
    ExpBytes () ByteString
b ->
      Text -> Builder
forall p. Buildable p => p -> Builder
build (Text -> Builder) -> Text -> Builder
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
encodeBase58Check ByteString
b
    ExpSeq () [Expression]
s -> Builder
"(" Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| (Expression -> Builder) -> [Expression] -> Builder
forall {c} {a}. (Monoid c, IsString c) => (a -> c) -> [a] -> c
buildList Expression -> Builder
forall p. Buildable p => p -> Builder
build [Expression]
s Builder -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
")"
    ExpPrim () (MichelinePrimAp (MichelinePrimitive Text
text) [Expression]
s [Annotation]
annots) ->
      Text
text Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"(" Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|
      (Expression -> Builder) -> [Expression] -> Builder
forall {c} {a}. (Monoid c, IsString c) => (a -> c) -> [a] -> c
buildList Expression -> Builder
forall p. Buildable p => p -> Builder
build [Expression]
s Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Builder
") " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|
      (Annotation -> Builder) -> [Annotation] -> Builder
forall {c} {a}. (Monoid c, IsString c) => (a -> c) -> [a] -> c
buildList (Text -> Builder
forall p. Buildable p => p -> Builder
build (Text -> Builder) -> (Annotation -> Text) -> Annotation -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Annotation -> Text
annotToText) [Annotation]
annots
    where
      buildList :: (a -> c) -> [a] -> c
buildList a -> c
buildElem = [c] -> c
forall a. Monoid a => [a] -> a
mconcat ([c] -> c) -> ([a] -> [c]) -> [a] -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> [c] -> [c]
forall a. a -> [a] -> [a]
intersperse c
", " ([c] -> [c]) -> ([a] -> [c]) -> [a] -> [c]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> c) -> [a] -> [c]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map a -> c
buildElem

data Annotation
  = AnnotationType TypeAnn
  | AnnotationVariable VarAnn
  | AnnotationField FieldAnn
  deriving stock (Annotation -> Annotation -> Bool
(Annotation -> Annotation -> Bool)
-> (Annotation -> Annotation -> Bool) -> Eq Annotation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Annotation -> Annotation -> Bool
$c/= :: Annotation -> Annotation -> Bool
== :: Annotation -> Annotation -> Bool
$c== :: Annotation -> Annotation -> Bool
Eq, Int -> Annotation -> ShowS
[Annotation] -> ShowS
Annotation -> String
(Int -> Annotation -> ShowS)
-> (Annotation -> String)
-> ([Annotation] -> ShowS)
-> Show Annotation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Annotation] -> ShowS
$cshowList :: [Annotation] -> ShowS
show :: Annotation -> String
$cshow :: Annotation -> String
showsPrec :: Int -> Annotation -> ShowS
$cshowsPrec :: Int -> Annotation -> ShowS
Show, Typeable Annotation
Typeable Annotation
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> Annotation -> c Annotation)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c Annotation)
-> (Annotation -> Constr)
-> (Annotation -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c Annotation))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c Annotation))
-> ((forall b. Data b => b -> b) -> Annotation -> Annotation)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> Annotation -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> Annotation -> r)
-> (forall u. (forall d. Data d => d -> u) -> Annotation -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> Annotation -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> Annotation -> m Annotation)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Annotation -> m Annotation)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Annotation -> m Annotation)
-> Data Annotation
Annotation -> DataType
Annotation -> Constr
(forall b. Data b => b -> b) -> Annotation -> Annotation
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> Annotation -> u
forall u. (forall d. Data d => d -> u) -> Annotation -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Annotation -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Annotation -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Annotation -> m Annotation
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Annotation -> m Annotation
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Annotation
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Annotation -> c Annotation
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Annotation)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Annotation)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Annotation -> m Annotation
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Annotation -> m Annotation
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Annotation -> m Annotation
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Annotation -> m Annotation
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Annotation -> m Annotation
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Annotation -> m Annotation
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Annotation -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Annotation -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> Annotation -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Annotation -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Annotation -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Annotation -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Annotation -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Annotation -> r
gmapT :: (forall b. Data b => b -> b) -> Annotation -> Annotation
$cgmapT :: (forall b. Data b => b -> b) -> Annotation -> Annotation
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Annotation)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Annotation)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Annotation)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Annotation)
dataTypeOf :: Annotation -> DataType
$cdataTypeOf :: Annotation -> DataType
toConstr :: Annotation -> Constr
$ctoConstr :: Annotation -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Annotation
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Annotation
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Annotation -> c Annotation
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Annotation -> c Annotation
Data, (forall (m :: * -> *). Quote m => Annotation -> m Exp)
-> (forall (m :: * -> *).
    Quote m =>
    Annotation -> Code m Annotation)
-> Lift Annotation
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => Annotation -> m Exp
forall (m :: * -> *). Quote m => Annotation -> Code m Annotation
liftTyped :: forall (m :: * -> *). Quote m => Annotation -> Code m Annotation
$cliftTyped :: forall (m :: * -> *). Quote m => Annotation -> Code m Annotation
lift :: forall (m :: * -> *). Quote m => Annotation -> m Exp
$clift :: forall (m :: * -> *). Quote m => Annotation -> m Exp
Lift)

data MichelinePrimAp x = MichelinePrimAp
  { forall (x :: ExpExtensionDescriptorKind).
MichelinePrimAp x -> MichelinePrimitive
mpaPrim :: MichelinePrimitive
  , forall (x :: ExpExtensionDescriptorKind).
MichelinePrimAp x -> [Exp x]
mpaArgs :: [Exp x]
  , forall (x :: ExpExtensionDescriptorKind).
MichelinePrimAp x -> [Annotation]
mpaAnnots :: [Annotation]
  }

deriving stock instance Eq (Exp x) => Eq (MichelinePrimAp x)
deriving stock instance Show (Exp x) => Show (MichelinePrimAp x)
deriving stock instance (Data (Exp x), Typeable x) => Data (MichelinePrimAp x)
deriving stock instance Lift (Exp x) => Lift (MichelinePrimAp x)

instance FromJSON (Exp x) => FromJSON (MichelinePrimAp x) where
  parseJSON :: Value -> Parser (MichelinePrimAp x)
parseJSON = String
-> (Object -> Parser (MichelinePrimAp x))
-> Value
-> Parser (MichelinePrimAp x)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Prim" ((Object -> Parser (MichelinePrimAp x))
 -> Value -> Parser (MichelinePrimAp x))
-> (Object -> Parser (MichelinePrimAp x))
-> Value
-> Parser (MichelinePrimAp x)
forall a b. (a -> b) -> a -> b
$ \Object
v -> MichelinePrimitive -> [Exp x] -> [Annotation] -> MichelinePrimAp x
forall (x :: ExpExtensionDescriptorKind).
MichelinePrimitive -> [Exp x] -> [Annotation] -> MichelinePrimAp x
MichelinePrimAp
    (MichelinePrimitive
 -> [Exp x] -> [Annotation] -> MichelinePrimAp x)
-> Parser MichelinePrimitive
-> Parser ([Exp x] -> [Annotation] -> MichelinePrimAp x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser MichelinePrimitive
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"prim"
    Parser ([Exp x] -> [Annotation] -> MichelinePrimAp x)
-> Parser [Exp x] -> Parser ([Annotation] -> MichelinePrimAp x)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe [Exp x])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"args" Parser (Maybe [Exp x]) -> [Exp x] -> Parser [Exp x]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
    Parser ([Annotation] -> MichelinePrimAp x)
-> Parser [Annotation] -> Parser (MichelinePrimAp x)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe [Annotation])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"annots" Parser (Maybe [Annotation]) -> [Annotation] -> Parser [Annotation]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []

instance ToJSON (Exp x) => ToJSON (MichelinePrimAp x) where
  toJSON :: MichelinePrimAp x -> Value
toJSON MichelinePrimAp {[Annotation]
[Exp x]
MichelinePrimitive
mpaAnnots :: [Annotation]
mpaArgs :: [Exp x]
mpaPrim :: MichelinePrimitive
mpaAnnots :: forall (x :: ExpExtensionDescriptorKind).
MichelinePrimAp x -> [Annotation]
mpaArgs :: forall (x :: ExpExtensionDescriptorKind).
MichelinePrimAp x -> [Exp x]
mpaPrim :: forall (x :: ExpExtensionDescriptorKind).
MichelinePrimAp x -> MichelinePrimitive
..} = [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [Maybe Pair] -> [Pair]
forall a. [Maybe a] -> [a]
catMaybes
    [ Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Key
"prim" Key -> MichelinePrimitive -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= MichelinePrimitive
mpaPrim)
    , if [Exp x] -> Bool
forall t. Container t => t -> Bool
null [Exp x]
mpaArgs then Maybe Pair
forall a. Maybe a
Nothing else Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Key
"args" Key -> [Exp x] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Exp x]
mpaArgs)
    , if [Annotation] -> Bool
forall t. Container t => t -> Bool
null [Annotation]
mpaAnnots then Maybe Pair
forall a. Maybe a
Nothing else Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Key
"annots" Key -> [Annotation] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Annotation]
mpaAnnots)
    ]

annotFromText :: forall m. MonadFail m => Text -> m Annotation
annotFromText :: forall (m :: * -> *). MonadFail m => Text -> m Annotation
annotFromText Text
txt = do
  (Char
n, Text
t) <-
    m (Char, Text)
-> ((Char, Text) -> m (Char, Text))
-> Maybe (Char, Text)
-> m (Char, Text)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> m (Char, Text)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m (Char, Text)) -> String -> m (Char, Text)
forall a b. (a -> b) -> a -> b
$ String
"Annotation '" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. ToString a => a -> String
toString Text
txt String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"' is missing an annotation prefix.") (Char, Text) -> m (Char, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Char, Text) -> m (Char, Text))
-> Maybe (Char, Text) -> m (Char, Text)
forall a b. (a -> b) -> a -> b
$
      Text -> Maybe (Char, Text)
T.uncons Text
txt
  if | String -> Text
forall a. ToText a => a -> Text
toText [Char
n] Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== forall tag. KnownAnnTag tag => Text
annPrefix @TypeTag  -> Either Text Annotation -> m Annotation
forall a. Either Text a -> m a
handleErr (Either Text Annotation -> m Annotation)
-> Either Text Annotation -> m Annotation
forall a b. (a -> b) -> a -> b
$ TypeAnn -> Annotation
AnnotationType (TypeAnn -> Annotation)
-> Either Text TypeAnn -> Either Text Annotation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either Text TypeAnn
forall {k} (a :: k). Text -> Either Text (Annotation a)
mkAnnotation Text
t
     | String -> Text
forall a. ToText a => a -> Text
toText [Char
n] Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== forall tag. KnownAnnTag tag => Text
annPrefix @VarTag   -> Either Text Annotation -> m Annotation
forall a. Either Text a -> m a
handleErr (Either Text Annotation -> m Annotation)
-> Either Text Annotation -> m Annotation
forall a b. (a -> b) -> a -> b
$ VarAnn -> Annotation
AnnotationVariable (VarAnn -> Annotation)
-> Either Text VarAnn -> Either Text Annotation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either Text VarAnn
forall {k} (a :: k). Text -> Either Text (Annotation a)
mkAnnotation Text
t
     | String -> Text
forall a. ToText a => a -> Text
toText [Char
n] Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== forall tag. KnownAnnTag tag => Text
annPrefix @FieldTag -> Either Text Annotation -> m Annotation
forall a. Either Text a -> m a
handleErr (Either Text Annotation -> m Annotation)
-> Either Text Annotation -> m Annotation
forall a b. (a -> b) -> a -> b
$ FieldAnn -> Annotation
AnnotationField (FieldAnn -> Annotation)
-> Either Text FieldAnn -> Either Text Annotation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either Text FieldAnn
forall {k} (a :: k). Text -> Either Text (Annotation a)
mkAnnotation Text
t
     | Bool
otherwise                         -> String -> m Annotation
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m Annotation) -> String -> m Annotation
forall a b. (a -> b) -> a -> b
$ String
"Unknown annotation type: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. ToString a => a -> String
toString Text
txt

  where
    handleErr :: Either Text a -> m a
    handleErr :: forall a. Either Text a -> m a
handleErr = \case
      Left Text
err -> String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
"Failed to parse annotation '" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. ToString a => a -> String
toString Text
txt String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"': " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. ToString a => a -> String
toString Text
err
      Right a
a -> a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

annotToText :: Annotation -> Text
annotToText :: Annotation -> Text
annotToText = \case
  AnnotationType TypeAnn
n -> TypeAnn -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty TypeAnn
n
  AnnotationVariable VarAnn
n -> VarAnn -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty VarAnn
n
  AnnotationField FieldAnn
n -> FieldAnn -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty FieldAnn
n

mkAnns :: [TypeAnn] -> [FieldAnn] -> [VarAnn] -> [Annotation]
mkAnns :: [TypeAnn] -> [FieldAnn] -> [VarAnn] -> [Annotation]
mkAnns [TypeAnn]
tas [FieldAnn]
fas [VarAnn]
vas =
  let minAnnSet :: AnnotationSet
minAnnSet = AnnotationSet -> AnnotationSet
minimizeAnnSet (AnnotationSet -> AnnotationSet) -> AnnotationSet -> AnnotationSet
forall a b. (a -> b) -> a -> b
$ [TypeAnn] -> [FieldAnn] -> [VarAnn] -> AnnotationSet
fullAnnSet [TypeAnn]
tas [FieldAnn]
fas [VarAnn]
vas
  in (TypeAnn -> Annotation
AnnotationType (TypeAnn -> Annotation) -> [TypeAnn] -> [Annotation]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnnotationSet -> [TypeAnn]
asTypes AnnotationSet
minAnnSet) [Annotation] -> [Annotation] -> [Annotation]
forall a. Semigroup a => a -> a -> a
<>
     (FieldAnn -> Annotation
AnnotationField (FieldAnn -> Annotation) -> [FieldAnn] -> [Annotation]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnnotationSet -> [FieldAnn]
asFields AnnotationSet
minAnnSet) [Annotation] -> [Annotation] -> [Annotation]
forall a. Semigroup a => a -> a -> a
<>
     (VarAnn -> Annotation
AnnotationVariable (VarAnn -> Annotation) -> [VarAnn] -> [Annotation]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnnotationSet -> [VarAnn]
asVars AnnotationSet
minAnnSet)

mkAnnsFromAny :: [U.AnyAnn] -> [Annotation]
mkAnnsFromAny :: [AnyAnn] -> [Annotation]
mkAnnsFromAny [AnyAnn]
xs = [AnyAnn]
xs [AnyAnn] -> (AnyAnn -> Annotation) -> [Annotation]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
  U.AnyAnnType TypeAnn
x -> TypeAnn -> Annotation
AnnotationType TypeAnn
x
  U.AnyAnnField FieldAnn
x -> FieldAnn -> Annotation
AnnotationField FieldAnn
x
  U.AnyAnnVar VarAnn
x -> VarAnn -> Annotation
AnnotationVariable VarAnn
x

isAnnotationField :: Annotation -> Bool
isAnnotationField :: Annotation -> Bool
isAnnotationField = \case
  AnnotationField FieldAnn
_ -> Bool
True
  Annotation
_                 -> Bool
False

isAnnotationVariable :: Annotation -> Bool
isAnnotationVariable :: Annotation -> Bool
isAnnotationVariable = \case
  AnnotationVariable VarAnn
_ -> Bool
True
  Annotation
_                    -> Bool
False

isAnnotationType :: Annotation -> Bool
isAnnotationType :: Annotation -> Bool
isAnnotationType = \case
  AnnotationType TypeAnn
_ -> Bool
True
  Annotation
_                -> Bool
False

isNoAnn :: Annotation -> Bool
isNoAnn :: Annotation -> Bool
isNoAnn = \case
  AnnotationVariable (U.Annotation Text
"") -> Bool
True
  AnnotationField (U.Annotation Text
"")    -> Bool
True
  AnnotationType (U.Annotation Text
"")     -> Bool
True
  Annotation
_                                    -> Bool
False

toAnnSet :: [Annotation] -> AnnotationSet
toAnnSet :: [Annotation] -> AnnotationSet
toAnnSet = (Element [Annotation] -> AnnotationSet)
-> [Annotation] -> AnnotationSet
forall t m. (Container t, Monoid m) => (Element t -> m) -> t -> m
foldMap ((Element [Annotation] -> AnnotationSet)
 -> [Annotation] -> AnnotationSet)
-> (Element [Annotation] -> AnnotationSet)
-> [Annotation]
-> AnnotationSet
forall a b. (a -> b) -> a -> b
$ \case
  AnnotationType TypeAnn
a     -> TypeAnn -> AnnotationSet
forall tag. KnownAnnTag tag => Annotation tag -> AnnotationSet
U.singleAnnSet TypeAnn
a
  AnnotationField FieldAnn
a    -> FieldAnn -> AnnotationSet
forall tag. KnownAnnTag tag => Annotation tag -> AnnotationSet
U.singleAnnSet FieldAnn
a
  AnnotationVariable VarAnn
a -> VarAnn -> AnnotationSet
forall tag. KnownAnnTag tag => Annotation tag -> AnnotationSet
U.singleAnnSet VarAnn
a

instance FromJSON Annotation where
  parseJSON :: Value -> Parser Annotation
parseJSON = String -> (Text -> Parser Annotation) -> Value -> Parser Annotation
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Annotation" Text -> Parser Annotation
forall (m :: * -> *). MonadFail m => Text -> m Annotation
annotFromText

instance ToJSON Annotation where
  toJSON :: Annotation -> Value
toJSON = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> (Annotation -> Text) -> Annotation -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Annotation -> Text
annotToText
  toEncoding :: Annotation -> Encoding
toEncoding = Text -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding (Text -> Encoding)
-> (Annotation -> Text) -> Annotation -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Annotation -> Text
annotToText

instance FromJSON Expression where
  parseJSON :: Value -> Parser Expression
parseJSON Value
v = XExpSeq RegularExp -> [Expression] -> Expression
forall (x :: ExpExtensionDescriptorKind).
XExpSeq x -> [Exp x] -> Exp x
ExpSeq () ([Expression] -> Expression)
-> Parser [Expression] -> Parser Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser [Expression]
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
            Parser Expression -> Parser Expression -> Parser Expression
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> XExpPrim RegularExp -> MichelinePrimAp RegularExp -> Expression
forall (x :: ExpExtensionDescriptorKind).
XExpPrim x -> MichelinePrimAp x -> Exp x
ExpPrim () (MichelinePrimAp RegularExp -> Expression)
-> Parser (MichelinePrimAp RegularExp) -> Parser Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (MichelinePrimAp RegularExp)
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
            Parser Expression -> Parser Expression -> Parser Expression
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> XExpString RegularExp -> Text -> Expression
forall (x :: ExpExtensionDescriptorKind).
XExpString x -> Text -> Exp x
ExpString () (Text -> Expression) -> Parser Text -> Parser Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> (Object -> Parser Text) -> Value -> Parser Text
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"ExpressionString" (Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"string") Value
v
            Parser Expression -> Parser Expression -> Parser Expression
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> XExpInt RegularExp -> Integer -> Expression
forall (x :: ExpExtensionDescriptorKind).
XExpInt x -> Integer -> Exp x
ExpInt () (Integer -> Expression)
-> (StringEncode Integer -> Integer)
-> StringEncode Integer
-> Expression
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StringEncode Integer -> Integer
forall a. StringEncode a -> a
unStringEncode (StringEncode Integer -> Expression)
-> Parser (StringEncode Integer) -> Parser Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> (Object -> Parser (StringEncode Integer))
-> Value
-> Parser (StringEncode Integer)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"ExpressionInt" (Object -> Key -> Parser (StringEncode Integer)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"int") Value
v
            Parser Expression -> Parser Expression -> Parser Expression
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> XExpBytes RegularExp -> ByteString -> Expression
forall (x :: ExpExtensionDescriptorKind).
XExpBytes x -> ByteString -> Exp x
ExpBytes () (ByteString -> Expression)
-> (HexJSONByteString -> ByteString)
-> HexJSONByteString
-> Expression
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HexJSONByteString -> ByteString
unHexJSONByteString (HexJSONByteString -> Expression)
-> Parser HexJSONByteString -> Parser Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> (Object -> Parser HexJSONByteString)
-> Value
-> Parser HexJSONByteString
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"ExpressionBytes" (Object -> Key -> Parser HexJSONByteString
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"bytes") Value
v

instance ToJSON Expression where
  toJSON :: Expression -> Value
toJSON (ExpSeq () [Expression]
xs) = [Expression] -> Value
forall a. ToJSON a => a -> Value
toJSON [Expression]
xs
  toJSON (ExpPrim () MichelinePrimAp RegularExp
xs) = MichelinePrimAp RegularExp -> Value
forall a. ToJSON a => a -> Value
toJSON MichelinePrimAp RegularExp
xs
  toJSON (ExpString () Text
x) = Object -> Value
Aeson.Object (Key -> Value -> Object
forall v. Key -> v -> KeyMap v
KeyMap.singleton Key
"string" (Value -> Object) -> Value -> Object
forall a b. (a -> b) -> a -> b
$ Text -> Value
forall a. ToJSON a => a -> Value
toJSON Text
x)
  toJSON (ExpInt () Integer
x) = Object -> Value
Aeson.Object (Key -> Value -> Object
forall v. Key -> v -> KeyMap v
KeyMap.singleton Key
"int" (Value -> Object) -> Value -> Object
forall a b. (a -> b) -> a -> b
$ StringEncode Integer -> Value
forall a. ToJSON a => a -> Value
toJSON (StringEncode Integer -> Value) -> StringEncode Integer -> Value
forall a b. (a -> b) -> a -> b
$ Integer -> StringEncode Integer
forall a. a -> StringEncode a
StringEncode Integer
x)
  toJSON (ExpBytes () ByteString
x) = Object -> Value
Aeson.Object (Key -> Value -> Object
forall v. Key -> v -> KeyMap v
KeyMap.singleton Key
"bytes" (Value -> Object) -> Value -> Object
forall a b. (a -> b) -> a -> b
$ HexJSONByteString -> Value
forall a. ToJSON a => a -> Value
toJSON (HexJSONByteString -> Value) -> HexJSONByteString -> Value
forall a b. (a -> b) -> a -> b
$ ByteString -> HexJSONByteString
HexJSONByteString ByteString
x)

  toEncoding :: Expression -> Encoding
toEncoding (ExpSeq () [Expression]
xs) = [Expression] -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding [Expression]
xs
  toEncoding (ExpPrim () MichelinePrimAp RegularExp
xs) = MichelinePrimAp RegularExp -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding MichelinePrimAp RegularExp
xs
  toEncoding (ExpString () Text
x) = Series -> Encoding
Aeson.pairs (Key -> Encoding -> Series
Aeson.pair Key
"string" (Text -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding Text
x))
  toEncoding (ExpInt () Integer
x) = Series -> Encoding
Aeson.pairs (Key -> Encoding -> Series
Aeson.pair Key
"int" (StringEncode Integer -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding (StringEncode Integer -> Encoding)
-> StringEncode Integer -> Encoding
forall a b. (a -> b) -> a -> b
$ Integer -> StringEncode Integer
forall a. a -> StringEncode a
StringEncode Integer
x))
  toEncoding (ExpBytes () ByteString
x) = Series -> Encoding
Aeson.pairs (Key -> Encoding -> Series
Aeson.pair Key
"bytes" (HexJSONByteString -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding (HexJSONByteString -> Encoding) -> HexJSONByteString -> Encoding
forall a b. (a -> b) -> a -> b
$ ByteString -> HexJSONByteString
HexJSONByteString ByteString
x))

--------------------------------------------------------------------------------
-- Optics
--------------------------------------------------------------------------------

_ExpInt :: Prism' (Exp d) (XExpInt d, Integer)
_ExpInt :: forall (d :: ExpExtensionDescriptorKind).
Prism' (Exp d) (XExpInt d, Integer)
_ExpInt = ((XExpInt d, Integer) -> Exp d)
-> (Exp d -> Maybe (XExpInt d, Integer))
-> Prism (Exp d) (Exp d) (XExpInt d, Integer) (XExpInt d, Integer)
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' ((XExpInt d -> Integer -> Exp d) -> (XExpInt d, Integer) -> Exp d
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry XExpInt d -> Integer -> Exp d
forall (x :: ExpExtensionDescriptorKind).
XExpInt x -> Integer -> Exp x
ExpInt) \case
  ExpInt XExpInt d
x Integer
a -> (XExpInt d, Integer) -> Maybe (XExpInt d, Integer)
forall a. a -> Maybe a
Just (XExpInt d
x, Integer
a)
  Exp d
_ -> Maybe (XExpInt d, Integer)
forall a. Maybe a
Nothing

_ExpString :: Prism' (Exp d) (XExpString d, Text)
_ExpString :: forall (d :: ExpExtensionDescriptorKind).
Prism' (Exp d) (XExpString d, Text)
_ExpString = ((XExpString d, Text) -> Exp d)
-> (Exp d -> Maybe (XExpString d, Text))
-> Prism (Exp d) (Exp d) (XExpString d, Text) (XExpString d, Text)
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' ((XExpString d -> Text -> Exp d) -> (XExpString d, Text) -> Exp d
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry XExpString d -> Text -> Exp d
forall (x :: ExpExtensionDescriptorKind).
XExpString x -> Text -> Exp x
ExpString) \case
  ExpString XExpString d
x Text
a -> (XExpString d, Text) -> Maybe (XExpString d, Text)
forall a. a -> Maybe a
Just (XExpString d
x, Text
a)
  Exp d
_ -> Maybe (XExpString d, Text)
forall a. Maybe a
Nothing

_ExpBytes :: Prism' (Exp d) (XExpBytes d, ByteString)
_ExpBytes :: forall (d :: ExpExtensionDescriptorKind).
Prism' (Exp d) (XExpBytes d, ByteString)
_ExpBytes = ((XExpBytes d, ByteString) -> Exp d)
-> (Exp d -> Maybe (XExpBytes d, ByteString))
-> Prism
     (Exp d) (Exp d) (XExpBytes d, ByteString) (XExpBytes d, ByteString)
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' ((XExpBytes d -> ByteString -> Exp d)
-> (XExpBytes d, ByteString) -> Exp d
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry XExpBytes d -> ByteString -> Exp d
forall (x :: ExpExtensionDescriptorKind).
XExpBytes x -> ByteString -> Exp x
ExpBytes) \case
  ExpBytes XExpBytes d
x ByteString
a -> (XExpBytes d, ByteString) -> Maybe (XExpBytes d, ByteString)
forall a. a -> Maybe a
Just (XExpBytes d
x, ByteString
a)
  Exp d
_ -> Maybe (XExpBytes d, ByteString)
forall a. Maybe a
Nothing

_ExpSeq :: Prism' (Exp d) (XExpSeq d, [Exp d])
_ExpSeq :: forall (d :: ExpExtensionDescriptorKind).
Prism' (Exp d) (XExpSeq d, [Exp d])
_ExpSeq = ((XExpSeq d, [Exp d]) -> Exp d)
-> (Exp d -> Maybe (XExpSeq d, [Exp d]))
-> Prism (Exp d) (Exp d) (XExpSeq d, [Exp d]) (XExpSeq d, [Exp d])
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' ((XExpSeq d -> [Exp d] -> Exp d) -> (XExpSeq d, [Exp d]) -> Exp d
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry XExpSeq d -> [Exp d] -> Exp d
forall (x :: ExpExtensionDescriptorKind).
XExpSeq x -> [Exp x] -> Exp x
ExpSeq) \case
  ExpSeq XExpSeq d
x [Exp d]
a -> (XExpSeq d, [Exp d]) -> Maybe (XExpSeq d, [Exp d])
forall a. a -> Maybe a
Just (XExpSeq d
x, [Exp d]
a)
  Exp d
_ -> Maybe (XExpSeq d, [Exp d])
forall a. Maybe a
Nothing

_ExpPrim :: Prism' (Exp d) (XExpPrim d, MichelinePrimAp d)
_ExpPrim :: forall (d :: ExpExtensionDescriptorKind).
Prism' (Exp d) (XExpPrim d, MichelinePrimAp d)
_ExpPrim = ((XExpPrim d, MichelinePrimAp d) -> Exp d)
-> (Exp d -> Maybe (XExpPrim d, MichelinePrimAp d))
-> Prism
     (Exp d)
     (Exp d)
     (XExpPrim d, MichelinePrimAp d)
     (XExpPrim d, MichelinePrimAp d)
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' ((XExpPrim d -> MichelinePrimAp d -> Exp d)
-> (XExpPrim d, MichelinePrimAp d) -> Exp d
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry XExpPrim d -> MichelinePrimAp d -> Exp d
forall (x :: ExpExtensionDescriptorKind).
XExpPrim x -> MichelinePrimAp x -> Exp x
ExpPrim) \case
  ExpPrim XExpPrim d
x MichelinePrimAp d
a -> (XExpPrim d, MichelinePrimAp d)
-> Maybe (XExpPrim d, MichelinePrimAp d)
forall a. a -> Maybe a
Just (XExpPrim d
x, MichelinePrimAp d
a)
  Exp d
_ -> Maybe (XExpPrim d, MichelinePrimAp d)
forall a. Maybe a
Nothing

neglecting :: Iso' ((), a) a
neglecting :: forall a. Iso' ((), a) a
neglecting = (((), a) -> a) -> (a -> ((), a)) -> Iso ((), a) ((), a) a a
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso ((), a) -> a
forall a b. (a, b) -> b
snd a -> ((), a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure

_ExpressionInt :: Prism' Expression Integer
_ExpressionInt :: Prism' Expression Integer
_ExpressionInt = p ((), Integer) (f ((), Integer)) -> p Expression (f Expression)
forall (d :: ExpExtensionDescriptorKind).
Prism' (Exp d) (XExpInt d, Integer)
_ExpInt (p ((), Integer) (f ((), Integer)) -> p Expression (f Expression))
-> (p Integer (f Integer) -> p ((), Integer) (f ((), Integer)))
-> p Integer (f Integer)
-> p Expression (f Expression)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p Integer (f Integer) -> p ((), Integer) (f ((), Integer))
forall a. Iso' ((), a) a
neglecting

_ExpressionString :: Prism' Expression Text
_ExpressionString :: Prism' Expression Text
_ExpressionString = p ((), Text) (f ((), Text)) -> p Expression (f Expression)
forall (d :: ExpExtensionDescriptorKind).
Prism' (Exp d) (XExpString d, Text)
_ExpString (p ((), Text) (f ((), Text)) -> p Expression (f Expression))
-> (p Text (f Text) -> p ((), Text) (f ((), Text)))
-> p Text (f Text)
-> p Expression (f Expression)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p Text (f Text) -> p ((), Text) (f ((), Text))
forall a. Iso' ((), a) a
neglecting

_ExpressionBytes :: Prism' Expression ByteString
_ExpressionBytes :: Prism' Expression ByteString
_ExpressionBytes = p ((), ByteString) (f ((), ByteString))
-> p Expression (f Expression)
forall (d :: ExpExtensionDescriptorKind).
Prism' (Exp d) (XExpBytes d, ByteString)
_ExpBytes (p ((), ByteString) (f ((), ByteString))
 -> p Expression (f Expression))
-> (p ByteString (f ByteString)
    -> p ((), ByteString) (f ((), ByteString)))
-> p ByteString (f ByteString)
-> p Expression (f Expression)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p ByteString (f ByteString)
-> p ((), ByteString) (f ((), ByteString))
forall a. Iso' ((), a) a
neglecting

_ExpressionSeq :: Prism' Expression [Expression]
_ExpressionSeq :: Prism' Expression [Expression]
_ExpressionSeq = p ((), [Expression]) (f ((), [Expression]))
-> p Expression (f Expression)
forall (d :: ExpExtensionDescriptorKind).
Prism' (Exp d) (XExpSeq d, [Exp d])
_ExpSeq (p ((), [Expression]) (f ((), [Expression]))
 -> p Expression (f Expression))
-> (p [Expression] (f [Expression])
    -> p ((), [Expression]) (f ((), [Expression])))
-> p [Expression] (f [Expression])
-> p Expression (f Expression)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p [Expression] (f [Expression])
-> p ((), [Expression]) (f ((), [Expression]))
forall a. Iso' ((), a) a
neglecting

_ExpressionPrim :: Prism' Expression (MichelinePrimAp RegularExp)
_ExpressionPrim :: Prism' Expression (MichelinePrimAp RegularExp)
_ExpressionPrim = p ((), MichelinePrimAp RegularExp)
  (f ((), MichelinePrimAp RegularExp))
-> p Expression (f Expression)
forall (d :: ExpExtensionDescriptorKind).
Prism' (Exp d) (XExpPrim d, MichelinePrimAp d)
_ExpPrim (p ((), MichelinePrimAp RegularExp)
   (f ((), MichelinePrimAp RegularExp))
 -> p Expression (f Expression))
-> (p (MichelinePrimAp RegularExp) (f (MichelinePrimAp RegularExp))
    -> p ((), MichelinePrimAp RegularExp)
         (f ((), MichelinePrimAp RegularExp)))
-> p (MichelinePrimAp RegularExp) (f (MichelinePrimAp RegularExp))
-> p Expression (f Expression)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p (MichelinePrimAp RegularExp) (f (MichelinePrimAp RegularExp))
-> p ((), MichelinePrimAp RegularExp)
     (f ((), MichelinePrimAp RegularExp))
forall a. Iso' ((), a) a
neglecting

makePrisms ''Annotation
makeLensesWith postfixLFields ''MichelinePrimAp