{-# 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.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 Data.Text qualified as T
import Optics.Core (set, (%~), (^.))

type HuddleM = State Huddle

-- | Overridden version of assignment which also adds the rule to the state
(=:=) :: IsType0 a => T.Text -> a -> HuddleM Rule
Text
n =:= :: forall a. IsType0 a => Text -> a -> HuddleM Rule
=:= a
b = let r :: Rule
r = Text
n Text -> a -> Rule
forall a. IsType0 a => Text -> 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
(=:~) :: T.Text -> Group -> HuddleM (Named Group)
Text
n =:~ :: Text -> Group -> HuddleM (Named Group)
=:~ Group
b = let r :: Named Group
r = Text
n Text -> Group -> Named Group
Huddle.=:~ Group
b in Named Group -> HuddleM (Named Group)
forall a. Includable a => a -> HuddleM a
include Named Group
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 => T.Text -> a -> Rule
Text
n =::= :: forall a. IsType0 a => Text -> a -> Rule
=::= a
b = Text
n Text -> a -> Rule
forall a. IsType0 a => Text -> 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 Rule
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 Text HuddleItem) (OMap Text HuddleItem)
-> (OMap Text HuddleItem -> OMap Text 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 Text HuddleItem -> (Text, HuddleItem) -> OMap Text HuddleItem
forall k v. Ord k => OMap k v -> (k, v) -> OMap k v
OMap.|> (Rule
r Rule -> Optic' A_Lens NoIx Rule Text -> Text
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 @"name", 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 (Named Group) where
  include :: Named Group -> HuddleM (Named Group)
include Named Group
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 Text HuddleItem) (OMap Text HuddleItem)
-> (OMap Text HuddleItem -> OMap Text 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 Text HuddleItem -> (Text, HuddleItem) -> OMap Text HuddleItem
forall k v. Ord k => OMap k v -> (k, v) -> OMap k v
OMap.|> (Named Group
r Named Group -> Optic' A_Lens NoIx (Named Group) Text -> Text
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 @"name", Named Group -> HuddleItem
HIGroup Named Group
r))
      )
      HuddleM () -> HuddleM (Named Group) -> HuddleM (Named Group)
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
>> Named Group -> HuddleM (Named Group)
forall a. a -> StateT Huddle Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Named Group
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"
        grDef :: Named (GRule GRef)
grDef = GRule Type2 -> GRule GRef
callToDef (GRule Type2 -> GRule GRef) -> GRuleCall -> Named (GRule GRef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t0 -> GRuleCall
gr t0
forall {a}. a
fakeT0
        n :: Text
n = Named (GRule GRef)
grDef Named (GRule GRef)
-> Optic' A_Lens NoIx (Named (GRule GRef)) Text -> Text
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 @"name"
     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 Text HuddleItem) (OMap Text HuddleItem)
-> (OMap Text HuddleItem -> OMap Text 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 Text HuddleItem -> (Text, HuddleItem) -> OMap Text HuddleItem
forall k v. Ord k => OMap k v -> (k, v) -> OMap k v
OMap.|> (Text
n, Named (GRule GRef) -> HuddleItem
HIGRule Named (GRule GRef)
grDef)))
          (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 Named Group
g) = Named Group -> HuddleM (Named Group)
forall a. Includable a => a -> HuddleM a
include Named Group
g HuddleM (Named Group) -> 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 Named (GRule GRef)
g) =
    let n :: Text
n = Named (GRule GRef)
g Named (GRule GRef)
-> Optic' A_Lens NoIx (Named (GRule GRef)) Text -> Text
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 @"name"
     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 Text HuddleItem) (OMap Text HuddleItem)
-> (OMap Text HuddleItem -> OMap Text 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 Text HuddleItem -> (Text, HuddleItem) -> OMap Text HuddleItem
forall k v. Ord k => OMap k v -> (k, v) -> OMap k v
OMap.|> (Text
n, 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 ->
  T.Text ->
  HuddleM HuddleItem
unsafeIncludeFromHuddle :: Huddle -> Text -> HuddleM HuddleItem
unsafeIncludeFromHuddle Huddle
h Text
name =
  let items :: OMap Text HuddleItem
items = Huddle
h Huddle
-> Lens Huddle Huddle (OMap Text HuddleItem) (OMap Text HuddleItem)
-> OMap Text 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 Text -> OMap Text HuddleItem -> Maybe HuddleItem
forall k v. Ord k => k -> OMap k v -> Maybe v
OMap.lookup Text
name OMap Text 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
$ Text -> [Char]
forall a. Show a => a -> [Char]
show Text
name [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" was not found in Huddle spec"