{-# LANGUAGE UndecidableInstances #-}

-- | Provides types for the legend.
module Shrun.Configuration.Toml.Legend
  ( LegendMap,
    KeyVal (MkKeyVal),
    mkKeyVal,
    unsafeKeyVal,
  )
where

import Data.Sequence qualified as Seq
import Data.Sequence.NonEmpty qualified as NESeq
import Shrun.Configuration.Args.Parsing.Graph (parseEdges)
import Shrun.Configuration.Data.Graph (EdgeArgs)
import Shrun.Prelude

-- | Alias for our legend map.
type LegendMap = HashMap Text (Tuple2 (NESeq Text) (Maybe EdgeArgs))

-- | Holds a map key/val pair. The maintained invariants are:
--
-- * @key@ is non-empty.
-- * @val@ is non-empty.
-- * all @v_i@ in @val@ are non-empty.
data KeyVal = UnsafeKeyVal
  { KeyVal -> Maybe EdgeArgs
edges :: Maybe EdgeArgs,
    KeyVal -> Text
key :: Text,
    KeyVal -> NESeq Text
val :: NESeq Text
  }
  deriving stock (KeyVal -> KeyVal -> Bool
(KeyVal -> KeyVal -> Bool)
-> (KeyVal -> KeyVal -> Bool) -> Eq KeyVal
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: KeyVal -> KeyVal -> Bool
== :: KeyVal -> KeyVal -> Bool
$c/= :: KeyVal -> KeyVal -> Bool
/= :: KeyVal -> KeyVal -> Bool
Eq, Int -> KeyVal -> ShowS
[KeyVal] -> ShowS
KeyVal -> String
(Int -> KeyVal -> ShowS)
-> (KeyVal -> String) -> ([KeyVal] -> ShowS) -> Show KeyVal
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> KeyVal -> ShowS
showsPrec :: Int -> KeyVal -> ShowS
$cshow :: KeyVal -> String
show :: KeyVal -> String
$cshowList :: [KeyVal] -> ShowS
showList :: [KeyVal] -> ShowS
Show)

-- | Unidirectional pattern synonym for 'KeyVal'.
pattern MkKeyVal :: Maybe EdgeArgs -> Text -> NESeq Text -> KeyVal
pattern $mMkKeyVal :: forall {r}.
KeyVal
-> (Maybe EdgeArgs -> Text -> NESeq Text -> r) -> ((# #) -> r) -> r
MkKeyVal es k v <- UnsafeKeyVal es k v

{-# COMPLETE MkKeyVal #-}

instance
  ( k ~ A_Getter,
    a ~ Maybe EdgeArgs,
    b ~ Maybe EdgeArgs
  ) =>
  LabelOptic "edges" k KeyVal KeyVal a b
  where
  labelOptic :: Optic k NoIx KeyVal KeyVal a b
labelOptic = (KeyVal -> a) -> Getter KeyVal a
forall s a. (s -> a) -> Getter s a
to (\(UnsafeKeyVal Maybe EdgeArgs
es Text
_ NESeq Text
_) -> a
Maybe EdgeArgs
es)
  {-# INLINE labelOptic #-}

instance
  ( k ~ A_Getter,
    a ~ Text,
    b ~ Text
  ) =>
  LabelOptic "key" k KeyVal KeyVal a b
  where
  labelOptic :: Optic k NoIx KeyVal KeyVal a b
labelOptic = (KeyVal -> a) -> Getter KeyVal a
forall s a. (s -> a) -> Getter s a
to (\(UnsafeKeyVal Maybe EdgeArgs
_ Text
k NESeq Text
_) -> a
Text
k)
  {-# INLINE labelOptic #-}

instance
  ( k ~ A_Getter,
    a ~ NESeq Text,
    b ~ NESeq Text
  ) =>
  LabelOptic "val" k KeyVal KeyVal a b
  where
  labelOptic :: Optic k NoIx KeyVal KeyVal a b
labelOptic = (KeyVal -> a) -> Getter KeyVal a
forall s a. (s -> a) -> Getter s a
to (\(UnsafeKeyVal Maybe EdgeArgs
_ Text
_ NESeq Text
v) -> a
NESeq Text
v)
  {-# INLINE labelOptic #-}

instance DecodeTOML KeyVal where
  tomlDecoder :: Decoder KeyVal
tomlDecoder =
    Maybe EdgeArgs -> Text -> NESeq Text -> KeyVal
UnsafeKeyVal
      (Maybe EdgeArgs -> Text -> NESeq Text -> KeyVal)
-> Decoder (Maybe EdgeArgs)
-> Decoder (Text -> NESeq Text -> KeyVal)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder (Maybe EdgeArgs)
decodeEdges
      Decoder (Text -> NESeq Text -> KeyVal)
-> Decoder Text -> Decoder (NESeq Text -> KeyVal)
forall a b. Decoder (a -> b) -> Decoder a -> Decoder b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Decoder Text
decodeKey
      Decoder (NESeq Text -> KeyVal)
-> Decoder (NESeq Text) -> Decoder KeyVal
forall a b. Decoder (a -> b) -> Decoder a -> Decoder b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Decoder (NESeq Text)
decodeVal

-- | Smart constructor for 'KeyVal'. Given @UnsafeKeyVal key vals@, all
-- conditions must be satisfied for success:
--
-- * @key@ is non-empty.
-- * @vals@ is non-empty.
-- * all @v_i@ in @vals@ are non-empty.
mkKeyVal :: Maybe EdgeArgs -> Text -> List Text -> Maybe KeyVal
mkKeyVal :: Maybe EdgeArgs -> Text -> [Text] -> Maybe KeyVal
mkKeyVal Maybe EdgeArgs
_ Text
"" [Text]
_ = Maybe KeyVal
forall a. Maybe a
Nothing
mkKeyVal Maybe EdgeArgs
_ Text
_ [] = Maybe KeyVal
forall a. Maybe a
Nothing
mkKeyVal Maybe EdgeArgs
es Text
k [Text]
vals = Maybe EdgeArgs -> Text -> NESeq Text -> KeyVal
UnsafeKeyVal Maybe EdgeArgs
es Text
k (NESeq Text -> KeyVal) -> Maybe (NESeq Text) -> Maybe KeyVal
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq Text -> Maybe (NESeq Text)
forall a. Seq a -> Maybe (NESeq a)
NESeq.nonEmptySeq ([Text] -> Seq Text
forall a. [a] -> Seq a
Seq.fromList [Text]
vals)

{- HLINT ignore unsafeKeyVal "Redundant bracket" -}

-- | Variant of 'UnsafeKeyVal' that throws an error on failures.
unsafeKeyVal :: (HasCallStack) => Maybe EdgeArgs -> Text -> List Text -> KeyVal
unsafeKeyVal :: HasCallStack => Maybe EdgeArgs -> Text -> [Text] -> KeyVal
unsafeKeyVal Maybe EdgeArgs
_ Text
"" [Text]
_ = String -> KeyVal
forall a. HasCallStack => String -> a
error String
"[Shrun.Configuration.Toml.Legend.unsafeKeyVal]: empty key"
unsafeKeyVal Maybe EdgeArgs
es Text
k [Text]
vals = case Maybe EdgeArgs -> Text -> [Text] -> Maybe KeyVal
mkKeyVal Maybe EdgeArgs
es Text
k [Text]
vals of
  Just KeyVal
kv -> KeyVal
kv
  Maybe KeyVal
Nothing -> String -> KeyVal
forall a. HasCallStack => String -> a
error String
"[Shrun.Configuration.Toml.Legend.unsafeKeyVal]: empty val"

decodeEdges :: Decoder (Maybe EdgeArgs)
decodeEdges :: Decoder (Maybe EdgeArgs)
decodeEdges = Decoder EdgeArgs -> Text -> Decoder (Maybe EdgeArgs)
forall a. Decoder a -> Text -> Decoder (Maybe a)
getFieldOptWith Decoder EdgeArgs
d Text
"edges"
  where
    d :: Decoder EdgeArgs
d = do
      Text
txt <- Decoder Text
forall a. DecodeTOML a => Decoder a
tomlDecoder
      case Text -> Either String EdgeArgs
parseEdges Text
txt of
        Left String
err -> String -> Decoder EdgeArgs
forall a. String -> Decoder a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
err
        Right EdgeArgs
x -> EdgeArgs -> Decoder EdgeArgs
forall a. a -> Decoder a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure EdgeArgs
x

decodeKey :: Decoder Text
decodeKey :: Decoder Text
decodeKey = Decoder Text -> Text -> Decoder Text
forall a. Decoder a -> Text -> Decoder a
getFieldWith Decoder Text
decodeNonEmptyText Text
"key"

decodeVal :: Decoder (NESeq Text)
decodeVal :: Decoder (NESeq Text)
decodeVal = Decoder (NESeq Text) -> Text -> Decoder (NESeq Text)
forall a. Decoder a -> Text -> Decoder a
getFieldWith (Decoder (NESeq Text)
decodeArray Decoder (NESeq Text)
-> Decoder (NESeq Text) -> Decoder (NESeq Text)
forall a. Decoder a -> Decoder a -> Decoder a
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> (Text -> NESeq Text) -> Decoder Text -> Decoder (NESeq Text)
forall a b. (a -> b) -> Decoder a -> Decoder b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> NESeq Text
forall a. a -> NESeq a
NESeq.singleton Decoder Text
decodeNonEmptyText) Text
"val"

decodeArray :: Decoder (NESeq Text)
decodeArray :: Decoder (NESeq Text)
decodeArray =
  Decoder (NonEmpty Text)
forall a. DecodeTOML a => Decoder a
tomlDecoder
    Decoder (NonEmpty Text)
-> (NonEmpty Text -> Decoder (NESeq Text)) -> Decoder (NESeq Text)
forall a b. Decoder a -> (a -> Decoder b) -> Decoder b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= ( (Text -> Maybe Text) -> NonEmpty Text -> Maybe (NonEmpty Text)
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
traverse Text -> Maybe Text
testNE (NonEmpty Text -> Maybe (NonEmpty Text))
-> (Maybe (NonEmpty Text) -> Decoder (NESeq Text))
-> NonEmpty Text
-> Decoder (NESeq Text)
forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> \case
            Just NonEmpty Text
xs -> NESeq Text -> Decoder (NESeq Text)
forall a. a -> Decoder a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (NESeq Text -> Decoder (NESeq Text))
-> NESeq Text -> Decoder (NESeq Text)
forall a b. (a -> b) -> a -> b
$ NonEmpty Text -> NESeq Text
forall a. NonEmpty a -> NESeq a
NESeq.fromList NonEmpty Text
xs
            Maybe (NonEmpty Text)
Nothing -> String -> Decoder (NESeq Text)
forall a. String -> Decoder a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"Unexpected empty val"
        )

decodeNonEmptyText :: Decoder Text
decodeNonEmptyText :: Decoder Text
decodeNonEmptyText =
  Decoder Text
forall a. DecodeTOML a => Decoder a
tomlDecoder Decoder Text -> (Text -> Decoder Text) -> Decoder Text
forall a b. Decoder a -> (a -> Decoder b) -> Decoder b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Text
"" -> String -> Decoder Text
forall a. String -> Decoder a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"Unexpected empty text"
    Text
other -> Text -> Decoder Text
forall a. a -> Decoder a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Text
other

testNE :: Text -> Maybe Text
testNE :: Text -> Maybe Text
testNE Text
"" = Maybe Text
forall a. Maybe a
Nothing
testNE Text
t = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t