{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE TypeInType           #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE UndecidableInstances #-}

-- |
-- Module      :  Network.Polkadot.Metadata.Type.Discovery
-- Copyright   :  Aleksandr Krupenkin 2016-2024
-- License     :  Apache-2.0
--
-- Maintainer  :  mail@akru.me
-- Stability   :  experimental
-- Portability :  portable
--
-- Runtime type discovery for generic metadata structures.
--

module Network.Polkadot.Metadata.Type.Discovery
  ( DiscoveryContext
  , Discovery(..)
  , runDiscovery
  , prefix
  , types
  ) where

import           Control.Monad.State.Class      (MonadState (..))
import           Control.Monad.State.Strict     (runState)
import           Data.ByteArray.HexString       (HexString)
import           Data.Set                       (Set, insert)
import           Data.Text                      (Text)
import           Data.Word                      (Word8)
import           Generics.SOP
import           Lens.Micro.Extras              (view)
import           Lens.Micro.Mtl                 (use, (%=), (.=))
import           Lens.Micro.TH                  (makeLenses)

import           Network.Polkadot.Metadata.Type (Type (..))

-- | Contains information about types and current context.
data DiscoveryContext = DiscoveryContext
  { DiscoveryContext -> Text
_prefix :: !Text
  , DiscoveryContext -> Set Type
_types  :: !(Set Type)
  } deriving (DiscoveryContext -> DiscoveryContext -> Bool
(DiscoveryContext -> DiscoveryContext -> Bool)
-> (DiscoveryContext -> DiscoveryContext -> Bool)
-> Eq DiscoveryContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DiscoveryContext -> DiscoveryContext -> Bool
== :: DiscoveryContext -> DiscoveryContext -> Bool
$c/= :: DiscoveryContext -> DiscoveryContext -> Bool
/= :: DiscoveryContext -> DiscoveryContext -> Bool
Eq, Int -> DiscoveryContext -> ShowS
[DiscoveryContext] -> ShowS
DiscoveryContext -> String
(Int -> DiscoveryContext -> ShowS)
-> (DiscoveryContext -> String)
-> ([DiscoveryContext] -> ShowS)
-> Show DiscoveryContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DiscoveryContext -> ShowS
showsPrec :: Int -> DiscoveryContext -> ShowS
$cshow :: DiscoveryContext -> String
show :: DiscoveryContext -> String
$cshowList :: [DiscoveryContext] -> ShowS
showList :: [DiscoveryContext] -> ShowS
Show)

instance Semigroup DiscoveryContext where
    (DiscoveryContext Text
p Set Type
a) <> :: DiscoveryContext -> DiscoveryContext -> DiscoveryContext
<> (DiscoveryContext Text
_ Set Type
b) = Text -> Set Type -> DiscoveryContext
DiscoveryContext Text
p (Set Type
a Set Type -> Set Type -> Set Type
forall a. Semigroup a => a -> a -> a
<> Set Type
b)

instance Monoid DiscoveryContext where
    mempty :: DiscoveryContext
mempty = Text -> Set Type -> DiscoveryContext
DiscoveryContext Text
forall a. Monoid a => a
mempty Set Type
forall a. Monoid a => a
mempty

makeLenses ''DiscoveryContext

-- | Collects information about runtime types.
class Discovery a where
    -- | Discover metadata structure for type information.
    discovery :: MonadState DiscoveryContext m
              => a
              -- ^ Input data structure that contains type information.
              -> m a
              -- ^ Returns the same structure wrapped with registry state monad.

-- | Skip 'Word8' when found.
instance {-# OVERLAPPING #-} Discovery Word8 where
    discovery :: forall (m :: * -> *).
MonadState DiscoveryContext m =>
Word8 -> m Word8
discovery = Word8 -> m Word8
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Skip 'HexString' when found.
instance {-# OVERLAPPING #-} Discovery HexString where
    discovery :: forall (m :: * -> *).
MonadState DiscoveryContext m =>
HexString -> m HexString
discovery = HexString -> m HexString
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Skip 'Text' when found.
instance {-# OVERLAPPING #-} Discovery Text where
    discovery :: forall (m :: * -> *).
MonadState DiscoveryContext m =>
Text -> m Text
discovery = Text -> m Text
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Register 'Type' when found.
instance {-# OVERLAPPING #-} Discovery Type where
    discovery :: forall (m :: * -> *).
MonadState DiscoveryContext m =>
Type -> m Type
discovery Type
t = Type -> m Type
forall (m :: * -> *).
MonadState DiscoveryContext m =>
Type -> m Type
update (Type -> m Type) -> (Text -> Type) -> Text -> m Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> (Text -> Type) -> Maybe Text -> Type
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Type
t Text -> Type
Type (Maybe Text -> Type) -> (Text -> Maybe Text) -> Text -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Type -> Maybe Text) -> Type -> Text -> Maybe Text
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Type -> Maybe Text
typeOverlap Type
t (Text -> m Type) -> m Text -> m Type
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Getting Text DiscoveryContext Text -> m Text
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Text DiscoveryContext Text
Lens' DiscoveryContext Text
prefix
      where
        update :: Type -> m Type
update Type
x = (Set Type -> Identity (Set Type))
-> DiscoveryContext -> Identity DiscoveryContext
Lens' DiscoveryContext (Set Type)
types ((Set Type -> Identity (Set Type))
 -> DiscoveryContext -> Identity DiscoveryContext)
-> (Set Type -> Set Type) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Type -> Set Type -> Set Type
forall a. Ord a => a -> Set a -> Set a
insert Type
x m () -> m Type -> m Type
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> m Type
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
x

-- | Type overlapping hacks
typeOverlap :: Text
            -- ^ Module name
            -> Type
            -- ^ Module type
            -> Maybe Text
            -- ^ New type name
typeOverlap :: Text -> Type -> Maybe Text
typeOverlap Text
"Society" (Type Text
"Vote")            = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"SocietyVote"
typeOverlap Text
"Treasury" (Type Text
"Proposal")       = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"TreasuryProposal"
typeOverlap Text
"Assets" (Type Text
"Balance")          = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"TAssetBalance"
typeOverlap Text
"Assets" (Type Text
"Compact<Balance>") = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Compact<TAssetBalance>"
typeOverlap Text
"Assets" (Type Text
"Approval")         = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"AssetApproval"
typeOverlap Text
"Assets" (Type Text
"ApprovalKey")      = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"AssetApprovalKey"
typeOverlap Text
"Assets" (Type Text
"DestroyWitness")   = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"AssetDestroyWitness"
typeOverlap Text
"Identity" (Type Text
"Judgement")      = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"IdentityJudgement"
typeOverlap Text
"ElectionProviderMultiPhase" (Type Text
"Phase") = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"ElectionPhase"
typeOverlap Text
a (Type Text
"Judgement")               = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Judgement")
typeOverlap Text
a (Type Text
"EquivocationProof")       = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"EquivocationProof")
typeOverlap Text
_ Type
_                                = Maybe Text
forall a. Maybe a
Nothing


-- | If input type is generic structure, let's go deep using generics.
instance (Generic a, GDiscovery (NS (NP I) (Code a))) => Discovery a where
    discovery :: forall (m :: * -> *). MonadState DiscoveryContext m => a -> m a
discovery = (NS (NP I) (Code a) -> a) -> m (NS (NP I) (Code a)) -> m a
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Rep a -> a
forall a. Generic a => Rep a -> a
to (Rep a -> a)
-> (NS (NP I) (Code a) -> Rep a) -> NS (NP I) (Code a) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NS (NP I) (Code a) -> Rep a
forall k (f :: k -> *) (xss :: [[k]]). NS (NP f) xss -> SOP f xss
SOP) (m (NS (NP I) (Code a)) -> m a)
-> (a -> m (NS (NP I) (Code a))) -> a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NS (NP I) (Code a) -> m (NS (NP I) (Code a))
forall a (m :: * -> *).
(GDiscovery a, MonadState DiscoveryContext m) =>
a -> m a
forall (m :: * -> *).
MonadState DiscoveryContext m =>
NS (NP I) (Code a) -> m (NS (NP I) (Code a))
gdiscovery (NS (NP I) (Code a) -> m (NS (NP I) (Code a)))
-> (a -> NS (NP I) (Code a)) -> a -> m (NS (NP I) (Code a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep a -> NS (NP I) (Code a)
forall {k} (f :: k -> *) (xss :: [[k]]). SOP f xss -> NS (NP f) xss
unSOP (Rep a -> NS (NP I) (Code a))
-> (a -> Rep a) -> a -> NS (NP I) (Code a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a
forall a. Generic a => a -> Rep a
from

-- | Generic version of 'Discovery' type class.
class GDiscovery a where
    gdiscovery :: MonadState DiscoveryContext m => a -> m a

-- | Discovery all constructors of the sum.
instance ( GDiscovery (NP I xs)
         , GDiscovery (NS (NP I) xss)
         ) => GDiscovery (NS (NP I) (xs ': xss)) where
    gdiscovery :: forall (m :: * -> *).
MonadState DiscoveryContext m =>
NS (NP I) (xs : xss) -> m (NS (NP I) (xs : xss))
gdiscovery (Z NP I x
xs) = NP I xs -> NS (NP I) (xs : xss)
forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z (NP I xs -> NS (NP I) (xs : xss))
-> m (NP I xs) -> m (NS (NP I) (xs : xss))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NP I xs -> m (NP I xs)
forall a (m :: * -> *).
(GDiscovery a, MonadState DiscoveryContext m) =>
a -> m a
forall (m :: * -> *).
MonadState DiscoveryContext m =>
NP I xs -> m (NP I xs)
gdiscovery NP I xs
NP I x
xs
    gdiscovery (S NS (NP I) xs
xs) = NS (NP I) xss -> NS (NP I) (xs : xss)
forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S (NS (NP I) xss -> NS (NP I) (xs : xss))
-> m (NS (NP I) xss) -> m (NS (NP I) (xs : xss))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NS (NP I) xss -> m (NS (NP I) xss)
forall a (m :: * -> *).
(GDiscovery a, MonadState DiscoveryContext m) =>
a -> m a
forall (m :: * -> *).
MonadState DiscoveryContext m =>
NS (NP I) xss -> m (NS (NP I) xss)
gdiscovery NS (NP I) xss
NS (NP I) xs
xs

-- | Finish when constructors will end.
instance GDiscovery (NS (NP I) '[]) where
    gdiscovery :: forall (m :: * -> *).
MonadState DiscoveryContext m =>
NS (NP I) '[] -> m (NS (NP I) '[])
gdiscovery = NS (NP I) '[] -> m (NS (NP I) '[])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Discovery all fileds of constructors.
instance (Discovery a, GDiscovery (NP I as)) => GDiscovery (NP I (a ': as)) where
    gdiscovery :: forall (m :: * -> *).
MonadState DiscoveryContext m =>
NP I (a : as) -> m (NP I (a : as))
gdiscovery (I x
a :* NP I xs
as) = do
        x
a' <- x -> m x
forall a (m :: * -> *).
(Discovery a, MonadState DiscoveryContext m) =>
a -> m a
forall (m :: * -> *). MonadState DiscoveryContext m => x -> m x
discovery x
a
        (a -> I a
forall a. a -> I a
I a
x
a' I a -> NP I as -> NP I (a : as)
forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:*) (NP I as -> NP I (a : as)) -> m (NP I as) -> m (NP I (a : as))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NP I as -> m (NP I as)
forall a (m :: * -> *).
(GDiscovery a, MonadState DiscoveryContext m) =>
a -> m a
forall (m :: * -> *).
MonadState DiscoveryContext m =>
NP I as -> m (NP I as)
gdiscovery NP I as
NP I xs
as

-- | Finish when fileds will end.
instance GDiscovery (NP I '[]) where
    gdiscovery :: forall (m :: * -> *).
MonadState DiscoveryContext m =>
NP I '[] -> m (NP I '[])
gdiscovery = NP I '[] -> m (NP I '[])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Discovery types and returns sanitized metadata and set of discovered types.
runDiscovery :: (Discovery a, Traversable t) => (a -> Text) -> t a -> (t a, Set Type)
runDiscovery :: forall a (t :: * -> *).
(Discovery a, Traversable t) =>
(a -> Text) -> t a -> (t a, Set Type)
runDiscovery a -> Text
p = (DiscoveryContext -> Set Type)
-> (t a, DiscoveryContext) -> (t a, Set Type)
forall a b. (a -> b) -> (t a, a) -> (t a, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Getting (Set Type) DiscoveryContext (Set Type)
-> DiscoveryContext -> Set Type
forall a s. Getting a s a -> s -> a
view Getting (Set Type) DiscoveryContext (Set Type)
Lens' DiscoveryContext (Set Type)
types)
               ((t a, DiscoveryContext) -> (t a, Set Type))
-> (t a -> (t a, DiscoveryContext)) -> t a -> (t a, Set Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State DiscoveryContext (t a)
 -> DiscoveryContext -> (t a, DiscoveryContext))
-> DiscoveryContext
-> State DiscoveryContext (t a)
-> (t a, DiscoveryContext)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State DiscoveryContext (t a)
-> DiscoveryContext -> (t a, DiscoveryContext)
forall s a. State s a -> s -> (a, s)
runState DiscoveryContext
forall a. Monoid a => a
mempty
               (State DiscoveryContext (t a) -> (t a, DiscoveryContext))
-> (t a -> State DiscoveryContext (t a))
-> t a
-> (t a, DiscoveryContext)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> StateT DiscoveryContext Identity a)
-> t a -> State DiscoveryContext (t a)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> t a -> m (t b)
mapM (\a
m -> (Text -> Identity Text)
-> DiscoveryContext -> Identity DiscoveryContext
Lens' DiscoveryContext Text
prefix ((Text -> Identity Text)
 -> DiscoveryContext -> Identity DiscoveryContext)
-> Text -> StateT DiscoveryContext Identity ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= a -> Text
p a
m StateT DiscoveryContext Identity ()
-> StateT DiscoveryContext Identity a
-> StateT DiscoveryContext Identity a
forall a b.
StateT DiscoveryContext Identity a
-> StateT DiscoveryContext Identity b
-> StateT DiscoveryContext Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> StateT DiscoveryContext Identity a
forall a (m :: * -> *).
(Discovery a, MonadState DiscoveryContext m) =>
a -> m a
forall (m :: * -> *). MonadState DiscoveryContext m => a -> m a
discovery a
m)