{-# LANGUAGE UndecidableInstances #-}

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

import Data.HashMap.Strict (HashMap)
import Data.Sequence qualified as Seq
import Data.Sequence.NonEmpty qualified as NESeq
import Shrun.Prelude

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

-- | 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 -> 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 :: Text -> NESeq Text -> KeyVal
pattern $mMkKeyVal :: forall {r}.
KeyVal -> (Text -> NESeq Text -> r) -> ((# #) -> r) -> r
MkKeyVal k v <- UnsafeKeyVal k v

{-# COMPLETE MkKeyVal #-}

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 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 Text
_ NESeq Text
v) -> a
NESeq Text
v)
  {-# INLINE labelOptic #-}

instance DecodeTOML KeyVal where
  tomlDecoder :: Decoder KeyVal
tomlDecoder =
    Text -> NESeq Text -> KeyVal
UnsafeKeyVal
      (Text -> NESeq Text -> KeyVal)
-> Decoder Text -> Decoder (NESeq Text -> KeyVal)
forall (f :: Type -> Type) a b. Functor 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 :: Text -> List Text -> Maybe KeyVal
mkKeyVal :: Text -> List Text -> Maybe KeyVal
mkKeyVal Text
"" List Text
_ = Maybe KeyVal
forall a. Maybe a
Nothing
mkKeyVal Text
_ [] = Maybe KeyVal
forall a. Maybe a
Nothing
mkKeyVal Text
k List Text
vals = Text -> NESeq Text -> KeyVal
UnsafeKeyVal 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 (List Text -> Seq Text
forall a. [a] -> Seq a
Seq.fromList List Text
vals)

{- HLINT ignore unsafeKeyVal "Redundant bracket" -}

-- | Variant of 'UnsafeKeyVal' that throws an error on failures.
unsafeKeyVal :: (HasCallStack) => Text -> List Text -> KeyVal
unsafeKeyVal :: HasCallStack => Text -> List Text -> KeyVal
unsafeKeyVal Text
"" List Text
_ = String -> KeyVal
forall a. HasCallStack => String -> a
error String
"[Shrun.Configuration.Toml.Legend.unsafeKeyVal]: empty key"
unsafeKeyVal Text
k List Text
vals = case Text -> List Text -> Maybe KeyVal
mkKeyVal Text
k List 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"

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 a b c. (a -> b) -> (b -> c) -> 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