{-# LANGUAGE DataKinds #-}

-- | Monad for declaring Huddle constructs
module Codec.CBOR.Cuddle.Huddle.HuddleM (
  module Huddle,
  (=:=),
  (=:~),
  (=::=),
  binding,
  setRootRules,
  huddleDef,
  huddleDef',
  include,
  unsafeIncludeFromHuddle,
)
where

import Codec.CBOR.Cuddle.CDDL (Name)
import Codec.CBOR.Cuddle.Huddle hiding (binding, (=:=), (=:~))
import Codec.CBOR.Cuddle.Huddle qualified as Huddle
import Control.Monad.State.Strict (State, modify, runState)
import Data.Default.Class (def)
import Data.Generics.Product (HasField (..))
import Data.Map.Ordered.Strict qualified as OMap
import Optics.Core (set, (%~), (^.))

type HuddleM = State Huddle

-- | Overridden version of assignment which also adds the rule to the state
(=:=) :: IsType0 a => Name -> a -> HuddleM Rule
Name
n =:= :: forall a. IsType0 a => Name -> a -> HuddleM Rule
=:= a
b = let r :: Rule
r = Name
n Name -> a -> Rule
forall a. IsType0 a => Name -> a -> Rule
Huddle.=:= a
b in Rule -> HuddleM Rule
forall a. Includable a => a -> HuddleM a
include Rule
r

infixl 1 =:=

-- | Overridden version of group assignment which adds the rule to the state
(=:~) :: Name -> Group -> HuddleM GroupDef
Name
n =:~ :: Name -> Group -> HuddleM GroupDef
=:~ Group
b = let r :: GroupDef
r = Name
n Name -> Group -> GroupDef
Huddle.=:~ Group
b in GroupDef -> HuddleM GroupDef
forall a. Includable a => a -> HuddleM a
include GroupDef
r

infixl 1 =:~

binding ::
  forall t0.
  IsType0 t0 =>
  (GRef -> Rule) ->
  HuddleM (t0 -> GRuleCall)
binding :: forall t0.
IsType0 t0 =>
(GRef -> Rule) -> HuddleM (t0 -> GRuleCall)
binding GRef -> Rule
fRule = (t0 -> GRuleCall) -> HuddleM (t0 -> GRuleCall)
forall a. Includable a => a -> HuddleM a
include ((GRef -> Rule) -> t0 -> GRuleCall
forall t0. IsType0 t0 => (GRef -> Rule) -> t0 -> GRuleCall
Huddle.binding GRef -> Rule
fRule)

-- | Renamed version of Huddle's underlying '=:=' for use in generic bindings
(=::=) :: IsType0 a => Name -> a -> Rule
Name
n =::= :: forall a. IsType0 a => Name -> a -> Rule
=::= a
b = Name
n Name -> a -> Rule
forall a. IsType0 a => Name -> a -> Rule
Huddle.=:= a
b

infixl 1 =::=

setRootRules :: [Rule] -> HuddleM ()
setRootRules :: [Rule] -> HuddleM ()
setRootRules = (Huddle -> Huddle) -> HuddleM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Huddle -> Huddle) -> HuddleM ())
-> ([Rule] -> Huddle -> Huddle) -> [Rule] -> HuddleM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic A_Lens NoIx Huddle Huddle [Rule] [Rule]
-> [Rule] -> Huddle -> Huddle
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set (forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"roots")

huddleDef :: HuddleM a -> Huddle
huddleDef :: forall a. HuddleM a -> Huddle
huddleDef = (a, Huddle) -> Huddle
forall a b. (a, b) -> b
snd ((a, Huddle) -> Huddle)
-> (HuddleM a -> (a, Huddle)) -> HuddleM a -> Huddle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HuddleM a -> (a, Huddle)
forall a. HuddleM a -> (a, Huddle)
huddleDef'

huddleDef' :: HuddleM a -> (a, Huddle)
huddleDef' :: forall a. HuddleM a -> (a, Huddle)
huddleDef' HuddleM a
mh = HuddleM a -> Huddle -> (a, Huddle)
forall s a. State s a -> s -> (a, s)
runState HuddleM a
mh Huddle
forall a. Default a => a
def

class Includable a where
  -- | Include a rule, group, or generic rule defined elsewhere
  include :: a -> HuddleM a

instance Includable Rule where
  include :: Rule -> HuddleM Rule
include r :: Rule
r@(Rule Named Type0
x XRule HuddleStage
_) =
    (Huddle -> Huddle) -> HuddleM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"items" Lens Huddle Huddle (OMap Name HuddleItem) (OMap Name HuddleItem)
-> (OMap Name HuddleItem -> OMap Name HuddleItem)
-> Huddle
-> Huddle
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ (OMap Name HuddleItem -> (Name, HuddleItem) -> OMap Name HuddleItem
forall k v. Ord k => OMap k v -> (k, v) -> OMap k v
OMap.|> (Named Type0 -> Name
forall a. HasName a => a -> Name
getName Named Type0
x, Rule -> HuddleItem
HIRule Rule
r)))
      HuddleM () -> HuddleM Rule -> HuddleM Rule
forall a b.
StateT Huddle Identity a
-> StateT Huddle Identity b -> StateT Huddle Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Rule -> HuddleM Rule
forall a. a -> StateT Huddle Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule
r

instance Includable GroupDef where
  include :: GroupDef -> HuddleM GroupDef
include GroupDef
r =
    (Huddle -> Huddle) -> HuddleM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify
      ( (forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"items")
          Lens Huddle Huddle (OMap Name HuddleItem) (OMap Name HuddleItem)
-> (OMap Name HuddleItem -> OMap Name HuddleItem)
-> Huddle
-> Huddle
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ (OMap Name HuddleItem -> (Name, HuddleItem) -> OMap Name HuddleItem
forall k v. Ord k => OMap k v -> (k, v) -> OMap k v
OMap.|> (GroupDef -> Name
forall a. HasName a => a -> Name
getName GroupDef
r, GroupDef -> HuddleItem
HIGroup GroupDef
r))
      )
      HuddleM () -> HuddleM GroupDef -> HuddleM GroupDef
forall a b.
StateT Huddle Identity a
-> StateT Huddle Identity b -> StateT Huddle Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> GroupDef -> HuddleM GroupDef
forall a. a -> StateT Huddle Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GroupDef
r

instance IsType0 t0 => Includable (t0 -> GRuleCall) where
  include :: (t0 -> GRuleCall) -> HuddleM (t0 -> GRuleCall)
include t0 -> GRuleCall
gr =
    let fakeT0 :: a
fakeT0 = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"Attempting to unwrap fake value in generic call"
        GRuleCall Named (GRule Type2)
g XRule HuddleStage
extra = t0 -> GRuleCall
gr t0
forall {a}. a
fakeT0
        grDef :: Named (GRule GRef)
grDef = GRule Type2 -> GRule GRef
callToDef (GRule Type2 -> GRule GRef)
-> Named (GRule Type2) -> Named (GRule GRef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Named (GRule Type2)
g
        n :: Name
n = Named (GRule GRef) -> Name
forall a. HasName a => a -> Name
getName Named (GRule GRef)
grDef
     in do
          (Huddle -> Huddle) -> HuddleM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"items" Lens Huddle Huddle (OMap Name HuddleItem) (OMap Name HuddleItem)
-> (OMap Name HuddleItem -> OMap Name HuddleItem)
-> Huddle
-> Huddle
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ (OMap Name HuddleItem -> (Name, HuddleItem) -> OMap Name HuddleItem
forall k v. Ord k => OMap k v -> (k, v) -> OMap k v
OMap.|> (Name
n, GRuleDef -> HuddleItem
HIGRule (GRuleDef -> HuddleItem) -> GRuleDef -> HuddleItem
forall a b. (a -> b) -> a -> b
$ Named (GRule GRef) -> XRule HuddleStage -> GRuleDef
GRuleDef Named (GRule GRef)
grDef XRule HuddleStage
extra)))
          (t0 -> GRuleCall) -> HuddleM (t0 -> GRuleCall)
forall a. a -> StateT Huddle Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure t0 -> GRuleCall
gr

instance Includable HuddleItem where
  include :: HuddleItem -> HuddleM HuddleItem
include x :: HuddleItem
x@(HIRule Rule
r) = Rule -> HuddleM Rule
forall a. Includable a => a -> HuddleM a
include Rule
r HuddleM Rule -> HuddleM HuddleItem -> HuddleM HuddleItem
forall a b.
StateT Huddle Identity a
-> StateT Huddle Identity b -> StateT Huddle Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> HuddleItem -> HuddleM HuddleItem
forall a. a -> StateT Huddle Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HuddleItem
x
  include x :: HuddleItem
x@(HIGroup GroupDef
g) = GroupDef -> HuddleM GroupDef
forall a. Includable a => a -> HuddleM a
include GroupDef
g HuddleM GroupDef -> HuddleM HuddleItem -> HuddleM HuddleItem
forall a b.
StateT Huddle Identity a
-> StateT Huddle Identity b -> StateT Huddle Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> HuddleItem -> HuddleM HuddleItem
forall a. a -> StateT Huddle Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HuddleItem
x
  include x :: HuddleItem
x@(HIGRule GRuleDef
g) =
    do
      (Huddle -> Huddle) -> HuddleM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"items" Lens Huddle Huddle (OMap Name HuddleItem) (OMap Name HuddleItem)
-> (OMap Name HuddleItem -> OMap Name HuddleItem)
-> Huddle
-> Huddle
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ (OMap Name HuddleItem -> (Name, HuddleItem) -> OMap Name HuddleItem
forall k v. Ord k => OMap k v -> (k, v) -> OMap k v
OMap.|> (GRuleDef -> Name
forall a. HasName a => a -> Name
getName GRuleDef
g, HuddleItem
x)))
      HuddleItem -> HuddleM HuddleItem
forall a. a -> StateT Huddle Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HuddleItem
x

unsafeIncludeFromHuddle ::
  Huddle ->
  Name ->
  HuddleM HuddleItem
unsafeIncludeFromHuddle :: Huddle -> Name -> HuddleM HuddleItem
unsafeIncludeFromHuddle Huddle
h Name
name =
  let items :: OMap Name HuddleItem
items = Huddle
h Huddle
-> Lens Huddle Huddle (OMap Name HuddleItem) (OMap Name HuddleItem)
-> OMap Name HuddleItem
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"items"
   in case Name -> OMap Name HuddleItem -> Maybe HuddleItem
forall k v. Ord k => k -> OMap k v -> Maybe v
OMap.lookup Name
name OMap Name HuddleItem
items of
        Just HuddleItem
v -> HuddleItem -> HuddleM HuddleItem
forall a. Includable a => a -> HuddleM a
include HuddleItem
v
        Maybe HuddleItem
Nothing -> [Char] -> HuddleM HuddleItem
forall a. HasCallStack => [Char] -> a
error ([Char] -> HuddleM HuddleItem) -> [Char] -> HuddleM HuddleItem
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
forall a. Show a => a -> [Char]
show Name
name [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" was not found in Huddle spec"