Extension.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- | Typed, per-backend modifier extensions.
--
-- This module is the answer to the question: \"how does a brand-new
-- backend define its own annotation vocabulary without modifying the
-- core 'Modifier' ADT?\"
--
-- The core ADT exposes one open slot — 'Wireform.Derive.Modifier.ModCustom' —
-- a @('Text', 'ByteString')@ pair where the 'Text' identifies the
-- vocabulary and the 'ByteString' is an opaque payload. Backends were
-- always free to use it directly, but the ergonomics were poor: every
-- backend had to invent its own serialization story.
--
-- The 'BackendModifier' typeclass standardises that story:
--
-- 1. The backend declares its modifier type with derived 'Show' /
--    'Read' instances and provides a stable 'backendModifierTag'.
-- 2. Users embed the typed value into an annotation via 'extension'.
-- 3. The backend's TH deriver pulls the typed value back out via
--    'lookupExtension' or 'lookupExtensions'.
--
-- Serialization uses @show@\/@read@ so we incur no extra package
-- dependencies. The payload only ever lives in @.hi@ files at
-- compile time, so the verbosity is a non-issue.
--
-- == Example: an Iceberg-only modifier
--
-- @
-- module Iceberg.Derive.Modifiers where
--
-- import Wireform.Derive.Extension
-- import Wireform.Derive.Modifier (Modifier)
--
-- data IcebergFieldOpt
--   = PartitionColumn
--   | OptimisticTransform !Text
--   deriving stock (Eq, Show, Read, Typeable)
--
-- instance BackendModifier IcebergFieldOpt where
--   backendModifierTag _ = "wireform-iceberg.field-opt"
--
-- partition :: Modifier
-- partition = extension PartitionColumn
-- @
--
-- and the deriver does:
--
-- @
-- mi <- reifyModifierInfoFor backendIceberg fieldName
-- case lookupExtension @IcebergFieldOpt mi of
--   Just PartitionColumn        -> ...
--   Just (OptimisticTransform t)-> ...
--   Nothing                     -> defaultBehaviour
-- @
module Wireform.Derive.Extension
  ( -- * Typed payloads
    BackendModifier (..)

    -- * Embedding
  , extension

    -- * Reading back
  , lookupExtension
  , lookupExtensions
  , hasExtension
  ) where

import qualified Data.Map.Strict as Map
import Data.Maybe (mapMaybe)
import Data.Proxy (Proxy (..))
import Data.Text (Text)
import Data.Typeable (Typeable)
import Text.Read (readMaybe)

import Wireform.Derive.Modifier (Modifier (..), customModifier)
import Wireform.Derive.ModifierInfo (ModifierInfo (..))

-- | Types that may be embedded into a 'Modifier' as a backend-specific
-- extension payload.
--
-- The 'Show' representation is what gets persisted into the @.hi@
-- file via the underlying @ANN@ pragma; the 'Read' instance reverses
-- it at splice time. 'Typeable' is required so derivers can assert
-- the expected vocabulary on extraction.
--
-- The 'backendModifierTag' is a globally-unique key for the
-- extension. Convention: @\"wireform-\<backend\>.\<concept\>\"@ so
-- two backends that happen to use the same concept name (e.g.
-- @\"partition\"@) do not collide.
class (Eq a, Show a, Read a, Typeable a) => BackendModifier a where
  backendModifierTag :: Proxy a -> Text

-- | Lift a typed value into a 'Modifier'. The result can be attached
-- via an @ANN@ pragma like any other modifier.
--
-- @
-- {-\# ANN myField (extension PartitionColumn) \#-}
-- @
extension :: forall a. BackendModifier a => a -> Modifier
extension a =
  customModifier
    (backendModifierTag (Proxy @a))
    (show a)

-- | Read back the first 'BackendModifier' of the requested type
-- attached to a name. Returns 'Nothing' if no annotation tagged for
-- this type was present, or if the payload failed to parse.
--
-- The latter case (parse failure) most often indicates that the
-- backend's modifier vocabulary changed in an incompatible way; in
-- that case derivers may want to call 'lookupExtensions' instead and
-- decide their own policy.
lookupExtension
  :: forall a. BackendModifier a
  => ModifierInfo
  -> Maybe a
lookupExtension mi =
  case lookupExtensions @a mi of
    (a : _) -> Just a
    []      -> Nothing

-- | Like 'lookupExtension' but returns every successfully-decoded
-- value of the requested type. Order matches the order in which @ANN@
-- pragmas were processed.
lookupExtensions
  :: forall a. BackendModifier a
  => ModifierInfo
  -> [a]
lookupExtensions mi =
  let key = backendModifierTag (Proxy @a)
  in case Map.lookup key (miCustom mi) of
       Nothing -> []
       Just ms -> mapMaybe decodeOne (reverse ms)
  where
    -- 'miCustom' uses 'Map.insertWith (++)' which prepends new
    -- modifiers to the head; 'reverse' here puts them back in
    -- declaration order so per-call iteration matches user intent.
    decodeOne :: Modifier -> Maybe a
    decodeOne (ModCustom _ s) = readMaybe s
    decodeOne _               = Nothing

-- | True iff at least one 'BackendModifier' of the requested type is
-- attached to the name.
hasExtension
  :: forall a. BackendModifier a
  => ModifierInfo
  -> Bool
hasExtension mi =
  let key = backendModifierTag (Proxy @a)
  in case Map.lookup key (miCustom mi) of
       Nothing -> False
       Just _  -> True