{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableSuperClasses #-}

module Cardano.Ledger.Huddle (
  module Huddle,
  (//-),
  HuddleRule (..),
  HuddleGroup (..),
  HuddleGRule (..),
  HuddleRule1 (..),
  huddleRule,
  huddleGroup,
  huddleGRule,
  huddleRule1,
  (=.=),
  (=.~),
  Era,
  genArrayTerm,
  genBytesTerm,
  genStringTerm,
  pickOne,
) where

import Cardano.Ledger.Binary (Term (..))
import Cardano.Ledger.Core (Era)
import Codec.CBOR.Cuddle.CDDL (Name (..))
import Codec.CBOR.Cuddle.Comments ((//-))
import Codec.CBOR.Cuddle.Huddle
import qualified Codec.CBOR.Cuddle.Huddle as Huddle hiding ((=:=), (=:~))
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as LBS
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NE
import Data.Proxy (Proxy (..))
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import System.Random.Stateful (StatefulGen, UniformRange (..))

class (KnownSymbol name, Era era) => HuddleRule (name :: Symbol) era where
  huddleRuleNamed :: Proxy name -> Proxy era -> Rule

class (KnownSymbol name, Era era) => HuddleGroup (name :: Symbol) era where
  huddleGroupNamed :: Proxy name -> Proxy era -> GroupDef

class (KnownSymbol name, Era era) => HuddleGRule (name :: Symbol) era where
  huddleGRuleNamed :: Proxy name -> Proxy era -> GRuleDef

class (KnownSymbol name, Era era) => HuddleRule1 (name :: Symbol) era where
  huddleRule1Named :: IsType0 a => Proxy name -> Proxy era -> a -> GRuleCall

huddleRule :: forall name era. HuddleRule name era => Proxy era -> Rule
huddleRule :: forall (name :: Symbol) era.
HuddleRule name era =>
Proxy era -> Rule
huddleRule = Proxy name -> Proxy era -> Rule
forall (name :: Symbol) era.
HuddleRule name era =>
Proxy name -> Proxy era -> Rule
huddleRuleNamed (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name)

huddleGroup :: forall name era. HuddleGroup name era => Proxy era -> GroupDef
huddleGroup :: forall (name :: Symbol) era.
HuddleGroup name era =>
Proxy era -> GroupDef
huddleGroup = Proxy name -> Proxy era -> GroupDef
forall (name :: Symbol) era.
HuddleGroup name era =>
Proxy name -> Proxy era -> GroupDef
huddleGroupNamed (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name)

huddleGRule :: forall name era. HuddleGRule name era => Proxy era -> GRuleDef
huddleGRule :: forall (name :: Symbol) era.
HuddleGRule name era =>
Proxy era -> GRuleDef
huddleGRule = Proxy name -> Proxy era -> GRuleDef
forall (name :: Symbol) era.
HuddleGRule name era =>
Proxy name -> Proxy era -> GRuleDef
huddleGRuleNamed (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name)

huddleRule1 :: forall name era a. (HuddleRule1 name era, IsType0 a) => Proxy era -> a -> GRuleCall
huddleRule1 :: forall (name :: Symbol) era a.
(HuddleRule1 name era, IsType0 a) =>
Proxy era -> a -> GRuleCall
huddleRule1 = Proxy name -> Proxy era -> a -> GRuleCall
forall a. IsType0 a => Proxy name -> Proxy era -> a -> GRuleCall
forall (name :: Symbol) era a.
(HuddleRule1 name era, IsType0 a) =>
Proxy name -> Proxy era -> a -> GRuleCall
huddleRule1Named (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name)

(=.=) :: (KnownSymbol name, IsType0 t) => Proxy (name :: Symbol) -> t -> Rule
=.= :: forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
(=.=) Proxy name
pname t
t = Text -> Name
Name (String -> Text
T.pack (Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal Proxy name
pname)) Name -> t -> Rule
forall a. IsType0 a => Name -> a -> Rule
=:= t
t

infixr 0 =.=

(=.~) :: KnownSymbol name => Proxy (name :: Symbol) -> Group -> GroupDef
=.~ :: forall (name :: Symbol).
KnownSymbol name =>
Proxy name -> Group -> GroupDef
(=.~) Proxy name
pname Group
group = Text -> Name
Name (String -> Text
T.pack (Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal Proxy name
pname)) Name -> Group -> GroupDef
=:~ Group
group

infixr 0 =.~

genArrayTerm :: StatefulGen g m => [Term] -> g -> m Term
genArrayTerm :: forall g (m :: * -> *). StatefulGen g m => [Term] -> g -> m Term
genArrayTerm [Term]
es = NonEmpty Term -> g -> m Term
forall g (m :: * -> *) a. StatefulGen g m => NonEmpty a -> g -> m a
pickOne [[Term] -> Term
TList [Term]
es, [Term] -> Term
TListI [Term]
es]

pickOne :: StatefulGen g m => NonEmpty a -> g -> m a
pickOne :: forall g (m :: * -> *) a. StatefulGen g m => NonEmpty a -> g -> m a
pickOne NonEmpty a
es g
g = do
  i <- (Int, Int) -> g -> m Int
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
forall g (m :: * -> *). StatefulGen g m => (Int, Int) -> g -> m Int
uniformRM (Int
0, NonEmpty a -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty a
es Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) g
g
  pure $ es NE.!! i

genBytesTerm :: StatefulGen g m => ByteString -> g -> m Term
genBytesTerm :: forall g (m :: * -> *).
StatefulGen g m =>
ByteString -> g -> m Term
genBytesTerm ByteString
bs = NonEmpty Term -> g -> m Term
forall g (m :: * -> *) a. StatefulGen g m => NonEmpty a -> g -> m a
pickOne [ByteString -> Term
TBytes ByteString
bs, ByteString -> Term
TBytesI (ByteString -> Term) -> ByteString -> Term
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.fromStrict ByteString
bs]

genStringTerm :: StatefulGen g m => T.Text -> g -> m Term
genStringTerm :: forall g (m :: * -> *). StatefulGen g m => Text -> g -> m Term
genStringTerm Text
t = NonEmpty Term -> g -> m Term
forall g (m :: * -> *) a. StatefulGen g m => NonEmpty a -> g -> m a
pickOne [Text -> Term
TString Text
t, Text -> Term
TStringI (Text -> Term) -> Text -> Term
forall a b. (a -> b) -> a -> b
$ Text -> Text
LT.fromStrict Text
t]