-- | This module exposes the labels that can be used to stamp
-- 'Cooked.Skeleton.TxSkel' with additional arbitrary pieces of information.
module Cooked.Skeleton.Label
  ( LabelConstrs,
    TxSkelLabel (..),
    txSkelLabelTypedP,
  )
where

import Cooked.Pretty.Class
import Data.Typeable (cast)
import Optics.Core
import Type.Reflection

-- | These are type constraints that must be satisfied by labels
type LabelConstrs x = (PrettyCooked x, Show x, Typeable x, Eq x, Ord x)

-- | Labels are arbitrary information that can be added to skeleton. They are
-- meant to be pretty-printed. The common use case we currently have is to tag
-- skeletons that have been modified by tweaks and automated attacks.
data TxSkelLabel where
  TxSkelLabel :: (LabelConstrs x) => x -> TxSkelLabel

instance Eq TxSkelLabel where
  TxSkelLabel
a == :: TxSkelLabel -> TxSkelLabel -> Bool
== TxSkelLabel
x = TxSkelLabel -> TxSkelLabel -> Ordering
forall a. Ord a => a -> a -> Ordering
compare TxSkelLabel
a TxSkelLabel
x Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ

instance Show TxSkelLabel where
  show :: TxSkelLabel -> String
show (TxSkelLabel x
x) = x -> String
forall a. Show a => a -> String
show x
x

instance PrettyCooked TxSkelLabel where
  prettyCookedOpt :: PrettyCookedOpts -> TxSkelLabel -> DocCooked
prettyCookedOpt PrettyCookedOpts
opts (TxSkelLabel x
x) = PrettyCookedOpts -> x -> DocCooked
forall a. PrettyCooked a => PrettyCookedOpts -> a -> DocCooked
prettyCookedOpt PrettyCookedOpts
opts x
x

instance Ord TxSkelLabel where
  compare :: TxSkelLabel -> TxSkelLabel -> Ordering
compare (TxSkelLabel x
a) (TxSkelLabel x
b) =
    Ordering -> (x -> Ordering) -> Maybe x -> Ordering
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      (SomeTypeRep -> SomeTypeRep -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (TypeRep x -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep (x -> TypeRep x
forall a. Typeable a => a -> TypeRep a
typeOf x
a)) (TypeRep x -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep (x -> TypeRep x
forall a. Typeable a => a -> TypeRep a
typeOf x
b)))
      (x -> x -> Ordering
forall a. Ord a => a -> a -> Ordering
compare x
b)
      (x -> Maybe x
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast x
a)

-- | A prism to create a label and retrieve a typed content
txSkelLabelTypedP :: (LabelConstrs a) => Prism' TxSkelLabel a
txSkelLabelTypedP :: forall a. LabelConstrs a => Prism' TxSkelLabel a
txSkelLabelTypedP =
  (a -> TxSkelLabel)
-> (TxSkelLabel -> Either TxSkelLabel a)
-> Prism TxSkelLabel TxSkelLabel a a
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism
    a -> TxSkelLabel
forall x. LabelConstrs x => x -> TxSkelLabel
TxSkelLabel
    (\txSkelLabel :: TxSkelLabel
txSkelLabel@(TxSkelLabel x
lbl) -> Either TxSkelLabel a
-> (a -> Either TxSkelLabel a) -> Maybe a -> Either TxSkelLabel a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (TxSkelLabel -> Either TxSkelLabel a
forall a b. a -> Either a b
Left TxSkelLabel
txSkelLabel) a -> Either TxSkelLabel a
forall a b. b -> Either a b
Right (x -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast x
lbl))