-- 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 (..)
  , MichelinePrimitiveTag (..)
  , SingMichelinePrimitiveTag (..)
  , ClassifiedMichelinePrimitive (..)
  , withClassifiedPrim
  , 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)
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.Singletons (Sing, sing)
import Data.Text qualified as T
import Fmt (Buildable(..), listF, pretty, tupleF, unwordsF)
import Language.Haskell.TH (Dec(..), caseE, conE, conP, conT, gadtC, match, normalB)

import Language.Haskell.TH.Syntax (Lift)
import Morley.Micheline.Expression.Internal.MichelinePrimitive
import Morley.Micheline.Expression.Internal.TH
import Morley.Micheline.Json (StringEncode(StringEncode, unStringEncode))
import Morley.Michelson.Typed.ClassifiedInstr.Internal.TH (promote)
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)

-- | GADT that has the same shape as 'MichelinePrimitive', but each constructor
-- carries a 'MichelinePrimitiveTag' tag with classification.
do
  [DataD cxt' name tvb mk _ ders] <-
    [d|data ClassifiedMichelinePrimitive (tag :: MichelinePrimitiveTag) where|]
  cons <- withMichelinePrimitiveCons \nm classifiedName ->
    gadtC [classifiedName] [] [t|$(conT name) $(promote $ primClassification $ primFromName nm)|]
  pure [DataD cxt' name tvb mk cons ders]

-- | Classify a 'MichelinePrimitive'. Intended to be used with @LambdaCase@,
-- similar to @withClassifiedInstr@.
withClassifiedPrim
  :: MichelinePrimitive
  -> (forall tag. Sing tag -> ClassifiedMichelinePrimitive tag -> r)
  -> r
withClassifiedPrim :: forall r.
MichelinePrimitive
-> (forall (tag :: MichelinePrimitiveTag).
    Sing tag -> ClassifiedMichelinePrimitive tag -> r)
-> r
withClassifiedPrim MichelinePrimitive
prim forall (tag :: MichelinePrimitiveTag).
Sing tag -> ClassifiedMichelinePrimitive tag -> r
f = $(do
  matches <- withMichelinePrimitiveCons \nm classifiedName ->
    match (conP nm []) (normalB [|f sing $(conE classifiedName)|]) []
  caseE [|prim|] $ pure <$> matches
  )

-- | 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 $mExpPrim' :: forall {r} {x :: ExpExtensionDescriptorKind}.
Exp x
-> (XExpPrim x
    -> MichelinePrimitive -> [Exp x] -> [Annotation] -> r)
-> ((# #) -> r)
-> r
$bExpPrim' :: forall (x :: ExpExtensionDescriptorKind).
XExpPrim x
-> MichelinePrimitive -> [Exp x] -> [Annotation] -> Exp x
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)
eeInt :: forall (f :: * -> *) (x :: ExpExtensionDescriptorKind).
ExpExtras f x -> f (XExpInt x)
eeString :: forall (f :: * -> *) (x :: ExpExtensionDescriptorKind).
ExpExtras f x -> f (XExpString x)
eeBytes :: forall (f :: * -> *) (x :: ExpExtensionDescriptorKind).
ExpExtras f x -> f (XExpBytes x)
eeSeq :: forall (f :: * -> *) (x :: ExpExtensionDescriptorKind).
ExpExtras f x -> f (XExpSeq x)
eePrim :: forall (f :: * -> *) (x :: ExpExtensionDescriptorKind).
ExpExtras f x -> f (XExpPrim x)
eeInt :: f1 (XExpInt x)
eeString :: f1 (XExpString x)
eeBytes :: f1 (XExpBytes x)
eeSeq :: f1 (XExpSeq x)
eePrim :: f1 (XExpPrim 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' :: MichelinePrimitive -> [Expression] -> [Annotation] -> Expression
expressionPrim' :: MichelinePrimitive -> [Expression] -> [Annotation] -> Expression
expressionPrim' MichelinePrimitive
prim [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 MichelinePrimitive
prim [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 -> Doc
build = \case
    ExpInt () Integer
i -> Integer -> Doc
forall a. Buildable a => a -> Doc
build Integer
i
    ExpString () Text
s -> Text -> Doc
forall a. Buildable a => a -> Doc
build Text
s
    ExpBytes () ByteString
b ->
      Text -> Doc
forall a. Buildable a => a -> Doc
build (Text -> Doc) -> Text -> Doc
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
encodeBase58Check ByteString
b
    ExpSeq () [Expression]
s -> [Expression] -> Doc
forall a (f :: * -> *). (Buildable a, Foldable f) => f a -> Doc
listF [Expression]
s
    ExpPrim () (MichelinePrimAp MichelinePrimitive
prim [Expression]
s [Annotation]
annots) ->
      [Doc] -> Doc
forall a (f :: * -> *). (Buildable a, Foldable f) => f a -> Doc
unwordsF [MichelinePrimitive -> Doc
forall a. Buildable a => a -> Doc
build MichelinePrimitive
prim, [Expression] -> Doc
forall a (f :: * -> *). (Buildable a, Foldable f) => f a -> Doc
listF [Expression]
s, [Text] -> Doc
forall a. TupleF a => a -> Doc
tupleF ([Text] -> Doc) -> [Text] -> Doc
forall a b. (a -> b) -> a -> b
$ Annotation -> Text
annotToText (Annotation -> Text) -> [Annotation] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Annotation]
annots]

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
$c== :: Annotation -> Annotation -> Bool
== :: Annotation -> Annotation -> Bool
$c/= :: Annotation -> Annotation -> Bool
/= :: 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
$cshowsPrec :: Int -> Annotation -> ShowS
showsPrec :: Int -> Annotation -> ShowS
$cshow :: Annotation -> String
show :: Annotation -> String
$cshowList :: [Annotation] -> ShowS
showList :: [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 -> Constr
Annotation -> DataType
(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)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Annotation -> c Annotation
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Annotation -> c Annotation
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Annotation
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Annotation
$ctoConstr :: Annotation -> Constr
toConstr :: Annotation -> Constr
$cdataTypeOf :: Annotation -> DataType
dataTypeOf :: Annotation -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Annotation)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Annotation)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Annotation)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Annotation)
$cgmapT :: (forall b. Data b => b -> b) -> Annotation -> Annotation
gmapT :: (forall b. Data b => b -> b) -> Annotation -> Annotation
$cgmapQl :: 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
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Annotation -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Annotation -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Annotation -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> Annotation -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Annotation -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Annotation -> u
$cgmapM :: forall (m :: * -> *).
Monad 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
$cgmapMp :: 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
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Annotation -> m Annotation
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Annotation -> m 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
$clift :: forall (m :: * -> *). Quote m => Annotation -> m Exp
lift :: forall (m :: * -> *). Quote m => Annotation -> m Exp
$cliftTyped :: forall (m :: * -> *). Quote m => Annotation -> Code m Annotation
liftTyped :: forall (m :: * -> *). Quote m => Annotation -> Code m Annotation
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 a b. Parser (a -> b) -> Parser a -> Parser b
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 a b. Parser (a -> b) -> Parser a -> Parser b
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
mpaPrim :: forall (x :: ExpExtensionDescriptorKind).
MichelinePrimAp x -> MichelinePrimitive
mpaArgs :: forall (x :: ExpExtensionDescriptorKind).
MichelinePrimAp x -> [Exp x]
mpaAnnots :: forall (x :: ExpExtensionDescriptorKind).
MichelinePrimAp x -> [Annotation]
mpaPrim :: MichelinePrimitive
mpaArgs :: [Exp x]
mpaAnnots :: [Annotation]
..} = [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
forall v. ToJSON v => Key -> v -> Pair
.= 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
forall v. ToJSON v => Key -> v -> Pair
.= [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
forall v. ToJSON v => Key -> v -> Pair
.= [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 a. String -> m a
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 a. a -> m a
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 a. String -> m a
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 a. 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 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, FromDoc b) => a -> b
pretty TypeAnn
n
  AnnotationVariable VarAnn
n -> VarAnn -> Text
forall a b. (Buildable a, FromDoc b) => a -> b
pretty VarAnn
n
  AnnotationField FieldAnn
n -> FieldAnn -> Text
forall a b. (Buildable a, FromDoc 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 m.
Monoid m =>
(Element [Annotation] -> m) -> [Annotation] -> m
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 a. Parser a -> Parser a -> Parser a
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 a. Parser a -> Parser a -> Parser a
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 a. Parser a -> Parser a -> Parser a
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 a. Parser a -> Parser a -> Parser a
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
--------------------------------------------------------------------------------

makePrisms ''Exp

neglecting :: Iso' ((), a) a
neglecting :: forall a (p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Functor f) =>
p a (f a) -> p ((), a) (f ((), 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 a. 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)
p (XExpInt RegularExp, Integer) (f (XExpInt RegularExp, Integer))
-> p Expression (f Expression)
forall (x :: ExpExtensionDescriptorKind) (p :: * -> * -> *)
       (f :: * -> *).
(Choice p, Applicative f) =>
p (XExpInt x, Integer) (f (XExpInt x, Integer))
-> p (Exp x) (f (Exp x))
_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 (p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Functor f) =>
p a (f a) -> p ((), a) (f ((), a))
neglecting

_ExpressionString :: Prism' Expression Text
_ExpressionString :: Prism' Expression Text
_ExpressionString = p ((), Text) (f ((), Text)) -> p Expression (f Expression)
p (XExpString RegularExp, Text) (f (XExpString RegularExp, Text))
-> p Expression (f Expression)
forall (x :: ExpExtensionDescriptorKind) (p :: * -> * -> *)
       (f :: * -> *).
(Choice p, Applicative f) =>
p (XExpString x, Text) (f (XExpString x, Text))
-> p (Exp x) (f (Exp x))
_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 (p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Functor f) =>
p a (f a) -> p ((), a) (f ((), a))
neglecting

_ExpressionBytes :: Prism' Expression ByteString
_ExpressionBytes :: Prism' Expression ByteString
_ExpressionBytes = p ((), ByteString) (f ((), ByteString))
-> p Expression (f Expression)
p (XExpBytes RegularExp, ByteString)
  (f (XExpBytes RegularExp, ByteString))
-> p Expression (f Expression)
forall (x :: ExpExtensionDescriptorKind) (p :: * -> * -> *)
       (f :: * -> *).
(Choice p, Applicative f) =>
p (XExpBytes x, ByteString) (f (XExpBytes x, ByteString))
-> p (Exp x) (f (Exp x))
_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 (p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Functor f) =>
p a (f a) -> p ((), a) (f ((), a))
neglecting

_ExpressionSeq :: Prism' Expression [Expression]
_ExpressionSeq :: Prism' Expression [Expression]
_ExpressionSeq = p ((), [Expression]) (f ((), [Expression]))
-> p Expression (f Expression)
p (XExpSeq RegularExp, [Expression])
  (f (XExpSeq RegularExp, [Expression]))
-> p Expression (f Expression)
forall (x :: ExpExtensionDescriptorKind) (p :: * -> * -> *)
       (f :: * -> *).
(Choice p, Applicative f) =>
p (XExpSeq x, [Exp x]) (f (XExpSeq x, [Exp x]))
-> p (Exp x) (f (Exp x))
_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 (p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Functor f) =>
p a (f a) -> p ((), a) (f ((), a))
neglecting

_ExpressionPrim :: Prism' Expression (MichelinePrimAp RegularExp)
_ExpressionPrim :: Prism' Expression (MichelinePrimAp RegularExp)
_ExpressionPrim = p ((), MichelinePrimAp RegularExp)
  (f ((), MichelinePrimAp RegularExp))
-> p Expression (f Expression)
p (XExpPrim RegularExp, MichelinePrimAp RegularExp)
  (f (XExpPrim RegularExp, MichelinePrimAp RegularExp))
-> p Expression (f Expression)
forall (x :: ExpExtensionDescriptorKind) (p :: * -> * -> *)
       (f :: * -> *).
(Choice p, Applicative f) =>
p (XExpPrim x, MichelinePrimAp x)
  (f (XExpPrim x, MichelinePrimAp x))
-> p (Exp x) (f (Exp x))
_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 (p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Functor f) =>
p a (f a) -> p ((), a) (f ((), a))
neglecting

makePrisms ''Annotation
makeLensesWith postfixLFields ''MichelinePrimAp