ModifierInfo.hs

{-# LANGUAGE TemplateHaskell #-}

{- | Backend-aware folding of @[Modifier]@ annotations into a typed
'ModifierInfo' record.

A 'ModifierInfo' is the input each per-format deriver consumes. It
has been resolved against a single 'Backend' so the deriver does
not need to think about per-backend overrides itself.

== Resolution strategy

Modifiers are folded in two passes:

1. /Global pass/ — every modifier that is not 'modifierIsBackendScoped'
   is folded in. Conflicts within the global pass raise a
   'ModifierError' (e.g. two distinct global renames).
2. /Backend pass/ — modifiers wrapped in 'ModForBackends' /
   'ModBackendOnly' / 'ModBackendDisable' that target the active
   'Backend' are then folded in /on top of/ the global result. This
   pass shadows global directives without raising a conflict, which
   is the whole point of per-backend overrides.
-}
module Wireform.Derive.ModifierInfo (
  -- * Folded representation
  ModifierInfo (..),
  RenameSpec (..),
  emptyModifierInfo,

  -- * Resolution
  foldModifiers,
  reifyModifierInfoFor,
  reifyModifierInfo,

  -- * Errors
  ModifierError (..),

  -- * Wire-key rendering
  renderRenameKey,
  renderWireKey,

  -- * Helpers
  defaultRenameForBackend,
) where

import Control.Exception (Exception)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Text (Text)
import Data.Text qualified as T
import Language.Haskell.TH (Exp, Name, Q, varE)
import Language.Haskell.TH.Syntax (Lift (lift), Quasi, qReifyAnnotations)
import Language.Haskell.TH.Syntax qualified as TH
import Wireform.Derive.Backend
import Wireform.Derive.Modifier
import Wireform.Derive.NameStyle


-- ---------------------------------------------------------------------------
-- Folded ModifierInfo
-- ---------------------------------------------------------------------------

{- | A field's resolved rename spec.

* 'RenameSpecLiteral' — a fully-baked 'Text' (from 'RenameTo'). Used
  verbatim as the wire key.
* 'RenameSpecStyle' — a 'NameStyle' to apply to the field's
  selector base name at render time (so 'Idiomatic' can be resolved
  against the deriver's active backend).
* 'RenameSpecApply' — a @Text -> Text@ function to call at /runtime/
  on the selector base name.
-}
data RenameSpec
  = RenameSpecLiteral !Text
  | RenameSpecStyle !NameStyle
  | RenameSpecApply !Name
  deriving (Eq, Show)


{- | A fully resolved view of the modifiers attached to a single
'Name', filtered for one active 'Backend'.
-}
data ModifierInfo = ModifierInfo
  { miBackend :: !Backend
  -- ^ The backend this 'ModifierInfo' was resolved for.
  , miRename :: !(Maybe RenameSpec)
  {- ^ The wire key, if explicitly customised. When 'Nothing' the
  deriver should fall back to its default policy (typically
  'defaultRenameForBackend').
  -}
  , miCoerce :: !(Maybe Name)
  , miFlatten :: !Bool
  , miSkip :: !Bool
  , miDefaults :: !(Maybe Name)
  , miTag :: !(Maybe Int)
  , miRequired :: !(Maybe Bool)
  {- ^ 'Just True' = required; 'Just False' = optional; 'Nothing' =
  format default.
  -}
  , miWireOverride :: !(Maybe WireOverride)
  , miMapKey :: !(Maybe MapKeyScalar)
  -- ^ Proto map key scalar (proto deriver only).
  , miOneof :: !(Maybe Text)
  {- ^ Name of the proto @oneof@ this field belongs to (proto
  deriver only).
  -}
  , miCustom :: !(Map Text [Modifier])
  {- ^ All 'ModCustom' payloads grouped by tag. Backends can scan
  their own tag and ignore the rest.
  -}
  }
  deriving (Eq, Show)


-- | The empty 'ModifierInfo' for a given backend.
emptyModifierInfo :: Backend -> ModifierInfo
emptyModifierInfo b =
  ModifierInfo
    { miBackend = b
    , miRename = Nothing
    , miCoerce = Nothing
    , miFlatten = False
    , miSkip = False
    , miDefaults = Nothing
    , miTag = Nothing
    , miRequired = Nothing
    , miWireOverride = Nothing
    , miMapKey = Nothing
    , miOneof = Nothing
    , miCustom = Map.empty
    }


-- ---------------------------------------------------------------------------
-- Errors
-- ---------------------------------------------------------------------------

-- | Conflicts surfaced during 'foldModifiers'.
data ModifierError
  = ConflictRename !RenameSpec !RenameSpec
  | ConflictCoerce !Name !Name
  | ConflictDefaults !Name !Name
  | ConflictTag !Int !Int
  | ConflictRequired !Bool !Bool
  | ConflictWireOverride !WireOverride !WireOverride
  | ConflictMapKey !MapKeyScalar !MapKeyScalar
  | ConflictOneof !Text !Text
  | -- | Both 'flatten' and 'skip' set on the same name.
    ConflictFlattenSkip
  | InvalidRenameFnArity !Name !Int
  deriving (Eq, Show)


instance Exception ModifierError


-- ---------------------------------------------------------------------------
-- foldModifiers
-- ---------------------------------------------------------------------------

{- | Resolve a list of modifiers against a backend. Conflicts within
the global pass yield 'Left'; per-backend overrides cleanly shadow
global directives.
-}
foldModifiers :: Backend -> [Modifier] -> Either ModifierError ModifierInfo
foldModifiers b ms = do
  let (globals, scoped) = partitionScope ms
  globalInfo <- foldList b (emptyModifierInfo b) globals
  -- Per-backend pass: do not raise on conflict; just shadow.
  let active = expandScoped b scoped
  pure (foldShadow active globalInfo)


-- ---------------------------------------------------------------------------
-- reifyModifierInfo / reifyModifierInfoFor
-- ---------------------------------------------------------------------------

{- | Reify all 'Modifier' annotations attached to a 'Name', resolved
for the given 'Backend'. Failure short-circuits the splice with
'fail'.
-}
reifyModifierInfoFor :: Quasi m => Backend -> Name -> m ModifierInfo
reifyModifierInfoFor b n = do
  (ms :: [Modifier]) <- qReifyAnnotations (TH.AnnLookupName n)
  case foldModifiers b ms of
    Left err ->
      let msg =
            "Wireform.Derive.ModifierInfo: invalid modifier "
              ++ "annotations on "
              ++ show n
              ++ ": "
              ++ show err
      in TH.qReport True msg >> fail msg
    Right mi -> pure mi


{- | Convenience: reify modifiers for every 'Backend' the deriver may
consult, returning a 'Map'. Useful when a single deriver wants to
emit instances for several formats from one annotation pass.
-}
reifyModifierInfo
  :: Quasi m
  => [Backend]
  -> Name
  -> m (Map Backend ModifierInfo)
reifyModifierInfo backends n = do
  pairs <- mapM (\b -> (b,) <$> reifyModifierInfoFor b n) backends
  pure (Map.fromList pairs)


-- ---------------------------------------------------------------------------
-- Wire-key rendering
-- ---------------------------------------------------------------------------

{- | Splice a 'RenameSpec' into a Haskell expression of type 'Text'.

'RenameSpecLiteral' bakes a string literal. 'RenameSpecStyle'
resolves any 'Idiomatic' inside the style against the supplied
'Backend' and bakes the post-style 'Text' as a literal — zero
runtime cost. 'RenameSpecApply' splices a runtime function call
against the selector base name.
-}
renderRenameKey :: Backend -> RenameSpec -> Text -> Q Exp
renderRenameKey b spec selBase = case spec of
  RenameSpecLiteral t -> lift t
  RenameSpecStyle s -> lift (applyStyle (resolveIdiomatic b s) selBase)
  RenameSpecApply fn -> [|$(varE fn) (T.pack $(lift (T.unpack selBase)))|]


{- | High-level wire-key renderer. If 'miRename' is set, defers to
'renderRenameKey'; otherwise applies the backend's idiomatic style
(see 'idiomaticFor' / 'defaultRenameForBackend') to the selector
base name and bakes the result in as a literal.
-}
renderWireKey :: ModifierInfo -> Text -> Q Exp
renderWireKey mi selBase = case miRename mi of
  Just spec -> renderRenameKey (miBackend mi) spec selBase
  Nothing -> lift (defaultRenameForBackend (miBackend mi) selBase)


{- | The default wire key for a backend when no 'rename' modifier was
supplied: applies the backend's idiomatic style to the selector
base name.
-}
defaultRenameForBackend :: Backend -> Text -> Text
defaultRenameForBackend b = applyStyle (resolveIdiomatic b (idiomaticFor b))


-- ---------------------------------------------------------------------------
-- Internals: scope partitioning
-- ---------------------------------------------------------------------------

{- | Split modifiers into global (apply to every backend) vs.
backend-scoped.
-}
partitionScope :: [Modifier] -> ([Modifier], [Modifier])
partitionScope = foldr step ([], [])
  where
    step m (g, s)
      | modifierIsBackendScoped m = (g, m : s)
      | otherwise = (m : g, s)


{- | Expand backend-scoped wrappers into a flat list of modifiers
that apply to the active backend.
-}
expandScoped :: Backend -> [Modifier] -> [Modifier]
expandScoped b = concatMap unwrap
  where
    unwrap (ModForBackends bs ms)
      | b `elem` bs = concatMap unwrap ms
      | otherwise = []
    unwrap (ModBackendOnly bs m)
      | b `elem` bs = unwrap m
      | otherwise = []
    unwrap (ModBackendDisable bs)
      | b `elem` bs = [ModSkip]
      | otherwise = []
    -- Nested non-scoped modifier — should not occur post-partition,
    -- but if it does, treat it as global for this backend.
    unwrap m = [m]


-- ---------------------------------------------------------------------------
-- Internals: folding
-- ---------------------------------------------------------------------------

-- | Strict left fold raising on conflict.
foldList
  :: Backend
  -> ModifierInfo
  -> [Modifier]
  -> Either ModifierError ModifierInfo
foldList _ acc [] = pure acc
foldList b acc (m : ms) = do
  acc' <- mergeOne acc m
  foldList b acc' ms


{- | Strict left fold that silently shadows existing fields. Used for
per-backend overrides.
-}
foldShadow :: [Modifier] -> ModifierInfo -> ModifierInfo
foldShadow ms acc0 = foldr (flip shadowOne) acc0 (reverse ms)


{- | Merge a single modifier into a 'ModifierInfo', raising on
conflict.
-}
mergeOne :: ModifierInfo -> Modifier -> Either ModifierError ModifierInfo
mergeOne mi = \case
  ModRename r ->
    let new = renameSpec r
    in case miRename mi of
         Just old | old /= new -> Left (ConflictRename old new)
         _ -> pure mi {miRename = Just new}
  ModCoerce n ->
    case miCoerce mi of
      Just old | old /= n -> Left (ConflictCoerce old n)
      _ -> pure mi {miCoerce = Just n}
  ModFlatten
    | miSkip mi -> Left ConflictFlattenSkip
    | otherwise -> pure mi {miFlatten = True}
  ModSkip
    | miFlatten mi -> Left ConflictFlattenSkip
    | otherwise -> pure mi {miSkip = True}
  ModDefaults n ->
    case miDefaults mi of
      Just old | old /= n -> Left (ConflictDefaults old n)
      _ -> pure mi {miDefaults = Just n}
  ModTag t ->
    case miTag mi of
      Just old | old /= t -> Left (ConflictTag old t)
      _ -> pure mi {miTag = Just t}
  ModRequired ->
    case miRequired mi of
      Just False -> Left (ConflictRequired False True)
      _ -> pure mi {miRequired = Just True}
  ModOptional ->
    case miRequired mi of
      Just True -> Left (ConflictRequired True False)
      _ -> pure mi {miRequired = Just False}
  ModWireOverride wo ->
    case miWireOverride mi of
      Just old | old /= wo -> Left (ConflictWireOverride old wo)
      _ -> pure mi {miWireOverride = Just wo}
  ModMapKey k ->
    case miMapKey mi of
      Just old | old /= k -> Left (ConflictMapKey old k)
      _ -> pure mi {miMapKey = Just k}
  ModOneof o ->
    case miOneof mi of
      Just old | old /= o -> Left (ConflictOneof old o)
      _ -> pure mi {miOneof = Just o}
  m@(ModCustom tagName _) ->
    pure mi {miCustom = Map.insertWith (++) tagName [m] (miCustom mi)}
  -- Backend-scoped wrappers should not appear in the global pass; if
  -- they do (e.g. through nesting), shadow rather than raise.
  ModForBackends _ _ -> pure mi
  ModBackendOnly _ _ -> pure mi
  ModBackendDisable _ -> pure mi


{- | Like 'mergeOne' but unconditionally overwrites; used for
per-backend overrides.
-}
shadowOne :: ModifierInfo -> Modifier -> ModifierInfo
shadowOne mi = \case
  ModRename r -> mi {miRename = Just (renameSpec r)}
  ModCoerce n -> mi {miCoerce = Just n}
  ModFlatten -> mi {miFlatten = True, miSkip = False}
  ModSkip -> mi {miSkip = True, miFlatten = False}
  ModDefaults n -> mi {miDefaults = Just n}
  ModTag t -> mi {miTag = Just t}
  ModRequired -> mi {miRequired = Just True}
  ModOptional -> mi {miRequired = Just False}
  ModWireOverride w -> mi {miWireOverride = Just w}
  ModMapKey k -> mi {miMapKey = Just k}
  ModOneof o -> mi {miOneof = Just o}
  m@(ModCustom tagName _) ->
    mi {miCustom = Map.insertWith (++) tagName [m] (miCustom mi)}
  ModForBackends _ _ -> mi
  ModBackendOnly _ _ -> mi
  ModBackendDisable _ -> mi


{- | Convert a 'Rename' modifier into a 'RenameSpec'. 'RenameStyle'
entries keep their 'NameStyle' verbatim so per-backend resolution
of 'Idiomatic' (and application against the selector base name)
can happen at render time in 'renderRenameKey'.
-}
renameSpec :: Rename -> RenameSpec
renameSpec = \case
  RenameTo t -> RenameSpecLiteral t
  RenameStyle s -> RenameSpecStyle s
  RenameFn n -> RenameSpecApply n