-- SPDX-FileCopyrightText: 2026 Alexandra de Wit
--
-- SPDX-License-Identifier: MIT
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

{- | A table-driven codec for the small named-enum vocabularies the system speaks: the
ecosystem key, the log format and level, and the telemetry switch.
A 'WireVocab' instance carries one @(value, name)@ table plus the human noun for the
set. 'lookupWire', 'parseWire' and 'renderWire' all read that table, so a parse, a
render, and the accepted-set message cannot drift apart.

The vocabulary keys on the type, so each type speaks exactly one vocabulary.
-}
module Ecluse.Core.Wire (
    WireVocab (..),
    lookupWire,
    parseWire,
    renderWire,
) where

import Data.Text qualified as T

{- | The wire vocabulary of a named-enum type. The @(value, name)@ table is the single source of
truth for the codec.
-}
class WireVocab a where
    {- | The human noun for the vocabulary, e.g. @"log format"@. Names the
    accepted set in 'parseWire's failure message.
    -}
    wireKind :: Text

    {- | Every value paired with its canonical wire name, in the order the accepted-set
    message names them. It must list every inhabitant, because 'renderWire' reads from it.
    -}
    wireTable :: NonEmpty (a, Text)

    {- | Further spellings 'lookupWire' accepts. An alias never reaches the accepted-set
    message, and 'renderWire' never emits one. Empty by default.
    -}
    wireAliases :: [(a, Text)]
    wireAliases = []

{- | The value a wire name denotes, through 'wireTable' and then 'wireAliases'.
'Nothing' for a name in neither.
-}
lookupWire :: forall a. (WireVocab a) => Text -> Maybe a
lookupWire :: forall a. WireVocab a => Text -> Maybe a
lookupWire Text
raw = (a, Text) -> a
forall a b. (a, b) -> a
fst ((a, Text) -> a) -> Maybe (a, Text) -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((a, Text) -> Bool) -> [(a, Text)] -> Maybe (a, Text)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Text
raw Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
==) (Text -> Bool) -> ((a, Text) -> Text) -> (a, Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Text) -> Text
forall a b. (a, b) -> b
snd) (NonEmpty (a, Text) -> [(a, Text)]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (forall a. WireVocab a => NonEmpty (a, Text)
wireTable @a) [(a, Text)] -> [(a, Text)] -> [(a, Text)]
forall a. Semigroup a => a -> a -> a
<> forall a. WireVocab a => [(a, Text)]
wireAliases @a)

{- | Parse a wire name, or report the accepted set on an unrecognised input. The message is
@unknown \\<kind\\> "\\<raw\\>" (expected one of: \\<names\\>)@, with the names in table order.
-}
parseWire :: forall a. (WireVocab a) => Text -> Either Text a
parseWire :: forall a. WireVocab a => Text -> Either Text a
parseWire Text
raw = Text -> Maybe a -> Either Text a
forall l r. l -> Maybe r -> Either l r
maybeToRight Text
unknown (Text -> Maybe a
forall a. WireVocab a => Text -> Maybe a
lookupWire Text
raw)
  where
    unknown :: Text
unknown =
        Text
"unknown "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> forall a. WireVocab a => Text
wireKind @a
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" \""
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
raw
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" (expected one of: "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " (NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (((a, Text) -> Text) -> NonEmpty (a, Text) -> NonEmpty Text
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, Text) -> Text
forall a b. (a, b) -> b
snd (forall a. WireVocab a => NonEmpty (a, Text)
wireTable @a)))
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

{- | The canonical wire name of a value, read out of the 'wireTable'. It is total, so the
class contract that the table lists every inhabitant is what keeps it correct.
-}
renderWire :: forall a. (WireVocab a, Eq a) => a -> Text
renderWire :: forall a. (WireVocab a, Eq a) => a -> Text
renderWire a
value = case forall a. WireVocab a => NonEmpty (a, Text)
wireTable @a of
    (a
v0, Text
n0) :| [(a, Text)]
rest
        | a
value a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
v0 -> Text
n0
        | Bool
otherwise -> Text -> ((a, Text) -> Text) -> Maybe (a, Text) -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
n0 (a, Text) -> Text
forall a b. (a, b) -> b
snd (((a, Text) -> Bool) -> [(a, Text)] -> Maybe (a, Text)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((a
value a -> a -> Bool
forall a. Eq a => a -> a -> Bool
==) (a -> Bool) -> ((a, Text) -> a) -> (a, Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Text) -> a
forall a b. (a, b) -> a
fst) [(a, Text)]
rest)