packages feed

wireform-derive (empty) → 0.1.0.0

raw patch · 22 files changed

+3106/−0 lines, 22 filesdep +aesondep +basedep +bytestring

Dependencies added: aeson, base, bytestring, containers, deepseq, hashable, hedgehog, mtl, tasty, tasty-hedgehog, tasty-hunit, template-haskell, text, th-abstraction, transformers, wireform-derive

Files

+ CHANGELOG.md view
@@ -0,0 +1,30 @@+# Changelog for wireform-derive++## 0.1.0.0 -- 2026-05-16++Initial public release of the cross-format deriver core.++### Highlights++* `Wireform.Derive` -- TH driver and re-export surface.+* `Wireform.Derive.Modifier` -- shared annotation vocabulary+  (`Modifier`): `rename` / `renameStyle` / `renameWith` /+  `renameIdiomatic`, `tag N`, `skip`, `defaults`, `required` /+  `optional`, `coerced`, `flatten`, `wireOverride`, `mapKey`,+  `oneof`, `extension`.+* `Wireform.Derive.ModifierInfo` -- resolved modifier shape+  consumed by per-format derivers.  `ConflictX` errors surface+  modifier conflicts cleanly.+* `Wireform.Derive.NameStyle` -- name conversion helpers+  (`SnakeCase`, `CamelCase`, `KebabCase`, `Idiomatic`, …).+* `Wireform.Derive.Backend` -- backend tags+  (`backendJSON` / `backendProto` / `backendCBOR` / …) used by+  the per-backend overrides.+* `Wireform.Derive.Extension` -- `BackendModifier` typeclass for+  typed per-backend payloads (e.g. `XmlFieldOpt`,+  `HtmlFieldOpt`, `Asn1Tag`).+* `Wireform.Derive.TypeInfo` -- TH reification helpers for the+  per-format derivers.+* `Wireform.Derive.Aeson` -- canonical worked-example deriver+  (`deriveJSON`) that targets Aeson; per-format derivers in+  sibling packages mirror the same shape.
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright 2026 Ian Duncan++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1.  Redistributions of source code must retain the above copyright notice,+    this list of conditions and the following disclaimer.++2.  Redistributions in binary form must reproduce the above copyright notice,+    this list of conditions and the following disclaimer in the documentation+    and/or other materials provided with the distribution.++3.  Neither the name of the copyright holder nor the names of its contributors+    may be used to endorse or promote products derived from this software+    without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,107 @@+# wireform-derive++[![BSD-3-Clause](https://img.shields.io/badge/license-BSD--3--Clause-blue.svg)](https://opensource.org/licenses/BSD-3-Clause)+++> [!CAUTION]+> wireform is in heavy development and has not been published to Hackage yet. APIs may change.++Annotation-driven Template Haskell deriver core for the+[`wireform`][wireform] family.  One `{-# ANN ... #-}` vocabulary+drives instance generation for every supported wire format -- JSON,+protobuf, CBOR, MessagePack, Thrift, BSON, Ion, EDN, TOML, Bencode,+NDJSON, CSV, XML, HTML, ASN.1, FlatBuffers, Cap'n Proto, Avro, Bond,+Arrow, Parquet, ORC, Iceberg.++[wireform]: https://github.com/iand675/wireform-++## How it fits together++* **This package** ships the cross-cutting vocabulary+  (`Wireform.Derive.Modifier`) and TH reflection helpers+  (`Wireform.Derive.TypeInfo` / `Wireform.Derive.NameStyle` /+  `Wireform.Derive.Backend` / `Wireform.Derive.Extension`).+* **Per-format packages** (`wireform-proto`, `wireform-cbor`,+  `wireform-msgpack`, …) each ship a `<Format>.Derive` module that+  consumes the same vocabulary.  Adding a new format mostly means+  cloning the nearest existing `<Format>.Derive` and adapting the+  value-mapping calls.+* `Wireform.Derive.Aeson` (in this package) is the canonical+  worked-example deriver and the only one that lives outside a+  format-specific package.++## Vocabulary at a glance++```haskell+data Person = Person+  { personFullName :: !Text+  , personAge      :: !Word32+  , personBalance  :: !Int64+  , personSecret   :: !Text+  } deriving stock (Show, Eq, Generic)++{-# ANN type Person ("Person" :: String) #-}++-- Wire tags / field numbers, used by tag-based formats (proto,+-- Thrift, Bond, Iceberg).+{-# ANN personFullName (tag 1) #-}+{-# ANN personAge      (tag 2) #-}+{-# ANN personBalance  (tag 3) #-}+{-# ANN personSecret   (tag 4) #-}++-- snake_case by default everywhere.+{-# ANN personFullName (renameStyle SnakeCase) #-}+{-# ANN personAge      (renameStyle SnakeCase) #-}+{-# ANN personBalance  (renameStyle SnakeCase) #-}+{-# ANN personSecret   (renameStyle SnakeCase) #-}++-- JSON-only override: `fullName` instead of `full_name`.+{-# ANN personFullName (forBackend backendJSON (rename "fullName")) #-}++-- JSON-only `skip`: never serialise `personSecret` to JSON.+{-# ANN personSecret   (forBackend backendJSON skip) #-}+```++Each per-format deriver then runs from a separate TH splice:++```haskell+import qualified Proto.Derive    as DProto+import qualified CBOR.Derive     as DCBOR+import qualified MsgPack.Derive  as DMP+import qualified Wireform.Derive.Aeson as DAeson++DProto.deriveProto ''Person+DCBOR.deriveCBOR   ''Person+DMP.deriveMsgPack  ''Person+DAeson.deriveJSON  ''Person+```++Result: `personFullName` becomes `full_name` on every binary wire+but `fullName` in JSON, and `personSecret` is omitted from JSON.++## `BackendModifier` extensions++Backends that need their own typed payloads (e.g. XML attribute vs.+element, ASN.1 explicit / implicit tagging, HTML attr vs. child)+opt in via the `BackendModifier` typeclass:++```haskell+class (Eq a, Show a, Read a, Typeable a) => BackendModifier a where+  backendModifierTag :: Proxy a -> Text+```++Each backend declares its own ADT under a unique tag namespace+(e.g. `wireform-xml.field-opt`, `wireform-asn1.field-opt`).+Annotations attach via `extension`, and per-backend deriver code+reads them via `lookupExtension` / `lookupExtensions` /+`hasExtension`.++## Inspirations++* riz0id's [`serde-th`](https://github.com/riz0id/serde-th)+  for the per-field annotation idea.+* `aeson-th` for the proven TH-driven JSON pattern.++## License++BSD-3-Clause.
+ src/Wireform/Derive.hs view
@@ -0,0 +1,56 @@+-- | Annotation-driven Template Haskell deriver core, shared across+-- every wireform format package.+--+-- This module re-exports the public surface so that downstream+-- deriver packages (@wireform-proto@, @wireform-cbor@,+-- @wireform-msgpack@, @wireform-thrift@, and the 18 newer per-format+-- derivers) can depend on a single import:+--+-- @+-- import Wireform.Derive+-- @+--+-- The Aeson deriver is bundled here as 'Wireform.Derive.Aeson' rather+-- than living in a separate package; it doubles as the canonical+-- worked example for adding a new backend on top of this core.+--+-- == Usage+--+-- 1. Annotate types and fields with 'Modifier's via @ANN@ pragmas.+-- 2. In a deriver splice, call 'reifyTypeInfo' for the data type and+--    'reifyModifierInfoFor' / 'reifyModifierInfo' for each affected+--    'Name' to obtain a backend-resolved 'ModifierInfo'.+-- 3. Use 'renderRenameKey' or 'renderWireKey' to splice the+--    appropriate 'Text' (or runtime expression) for each field's wire+--    key.+--+-- See "Wireform.Derive.Aeson" for a complete worked example.+module Wireform.Derive+  ( -- * Backends+    module Wireform.Derive.Backend++    -- * Name styles+  , module Wireform.Derive.NameStyle++    -- * Modifiers+  , module Wireform.Derive.Modifier++    -- * Type reflection+  , module Wireform.Derive.TypeInfo++    -- * Resolution+  , module Wireform.Derive.ModifierInfo++    -- * Backend extension vocabulary+    --+    -- | Per-backend modifiers without modifying the core ADT. See+    -- 'Wireform.Derive.Extension' for the rationale.+  , module Wireform.Derive.Extension+  ) where++import Wireform.Derive.Backend+import Wireform.Derive.Extension+import Wireform.Derive.Modifier+import Wireform.Derive.ModifierInfo+import Wireform.Derive.NameStyle+import Wireform.Derive.TypeInfo
+ src/Wireform/Derive/Aeson.hs view
@@ -0,0 +1,332 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Annotation-driven Aeson 'ToJSON' / 'FromJSON' deriver.+--+-- Adapted from riz0id's @aeson-th@ but reimplemented on top of the+-- 'Wireform.Derive' core so a single set of @ANN@ pragmas can drive+-- every wireform-supported format simultaneously. Riz0id's original+-- left sum-of-products unfinished; this deriver implements them as+-- aeson's @TaggedObject@ shape (the proto3-JSON-friendly default).+--+-- The deriver covers four type shapes:+--+-- * 'TypeShapeNewtype' — the inner field's instance is reused.+-- * 'TypeShapeRecord'  — encoded as @{ "k1": v1, ... }@.+-- * 'TypeShapeEnum'    — encoded as a JSON string of the constructor+--   name (with rename modifiers applied).+-- * 'TypeShapeSum'     — encoded as @{ "tag": "Ctor", "contents": ... }@.+--   When a constructor has zero fields, @contents@ is 'Aeson.Null';+--   one field, the field's JSON; multiple fields, a JSON array.+--+-- == Quick start+--+-- @+-- data Person = Person+--   { personName :: !Text+--   , personAge  :: !Int+--   } deriving (Eq, Show)+--+-- {-\# ANN type Person   (rename "person")           \#-}+-- {-\# ANN personName    (rename "name")             \#-}+-- {-\# ANN personAge     (renameStyle SnakeCase)     \#-}+--+-- 'deriveJSON' ''Person+-- @+module Wireform.Derive.Aeson+  ( deriveJSON+  , deriveToJSON+  , deriveFromJSON+  ) where++import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.:?), (.=))+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Key as Aeson.Key+import Data.Coerce (coerce)+import Data.Foldable (foldlM)+import qualified Data.Text as T+import Language.Haskell.TH++import Wireform.Derive.Backend+import Wireform.Derive.ModifierInfo+import Wireform.Derive.TypeInfo++-- ---------------------------------------------------------------------------+-- Public entry points+-- ---------------------------------------------------------------------------++-- | Derive both 'ToJSON' and 'FromJSON' for the given type.+deriveJSON :: Name -> Q [Dec]+deriveJSON nm = (++) <$> deriveToJSON nm <*> deriveFromJSON nm++-- | Derive only 'ToJSON'.+deriveToJSON :: Name -> Q [Dec]+deriveToJSON nm = do+  ti <- reifyTypeInfo nm+  body <- toJSONBody ti+  let typ = applyTypeArgs (ConT (typeInfoName ti)) (typeInfoVarTypes ti)+      decl = InstanceD Nothing []+              (AppT (ConT ''ToJSON) typ)+              [FunD 'toJSON [Clause [] (NormalB body) []]]+  pure [decl]++-- | Derive only 'FromJSON'.+deriveFromJSON :: Name -> Q [Dec]+deriveFromJSON nm = do+  ti <- reifyTypeInfo nm+  body <- fromJSONBody ti+  let typ = applyTypeArgs (ConT (typeInfoName ti)) (typeInfoVarTypes ti)+      decl = InstanceD Nothing []+              (AppT (ConT ''FromJSON) typ)+              [FunD 'parseJSON [Clause [] (NormalB body) []]]+  pure [decl]++-- ---------------------------------------------------------------------------+-- ToJSON dispatch+-- ---------------------------------------------------------------------------++toJSONBody :: TypeInfo -> Q Exp+toJSONBody ti = case typeInfoShape ti of+  TypeShapeNewtype c   -> toJSONNewtype c+  TypeShapeRecord  c   -> toJSONRecord  c+  TypeShapeEnum    cs  -> toJSONEnum    cs+  TypeShapeSum     cs  -> toJSONSum     cs++toJSONNewtype :: ConInfo -> Q Exp+toJSONNewtype c = case conInfoFields c of+  [FieldInfo (Just sel) _] -> do+    x <- newName "x"+    lamE [varP x] [| toJSON ($(varE sel) $(varE x)) |]+  [FieldInfo Nothing _] -> do+    x <- newName "x"+    lamE [conP (conInfoName c) [varP x]] [| toJSON $(varE x) |]+  _ -> fail "Wireform.Derive.Aeson: newtype must have exactly one field"++toJSONRecord :: ConInfo -> Q Exp+toJSONRecord c = do+  x <- newName "x"+  pairsExp <- recordToJSONPairs (varE x) c+  lamE [varP x] [| Aeson.object $(pure pairsExp) |]++recordToJSONPairs :: Q Exp -> ConInfo -> Q Exp+recordToJSONPairs varExp c = do+  pairExpss <- mapM (toJSONField varExp) (conInfoFields c)+  pure (ListE (concat pairExpss))++toJSONField :: Q Exp -> FieldInfo -> Q [Exp]+toJSONField varExp (FieldInfo mSel _) = do+  selName <- requireSelector mSel+  mi <- reifyModifierInfoFor backendJSON selName+  if miSkip mi+    then pure []+    else do+      let selBase = T.pack (nameBase selName)+      keyExp <- renderWireKey mi selBase+      let getter = appE (varE selName) varExp+          encoded = case miCoerce mi of+            Nothing -> [| toJSON $getter |]+            Just _  -> [| toJSON (coerce $getter) |]+      pair <- [| (Aeson.Key.fromText $(pure keyExp) .= ($encoded :: Aeson.Value)) |]+      pure [pair]++-- | Enum: encode as a JSON string. Each constructor's wire key is+-- baked at splice time.+toJSONEnum :: [ConInfo] -> Q Exp+toJSONEnum cs = do+  v <- newName "v"+  matches <- mapM enumToJSONMatch cs+  body <- caseE (varE v) (map pure matches)+  lamE [varP v] (pure body)++enumToJSONMatch :: ConInfo -> Q Match+enumToJSONMatch c = do+  mi <- reifyModifierInfoFor backendJSON (conInfoName c)+  keyExp <- renderWireKey mi (T.pack (nameBase (conInfoName c)))+  body <- [| toJSON ($(pure keyExp) :: T.Text) |]+  pure (Match (ConP (conInfoName c) [] []) (NormalB body) [])++-- | Sum: tagged-object encoding with @tag@ + @contents@ fields. The+-- @contents@ payload is 'Aeson.Null' for nullary constructors, the+-- single field for unary constructors, and a JSON array for n-ary+-- constructors.+toJSONSum :: [ConInfo] -> Q Exp+toJSONSum cs = do+  v <- newName "v"+  matches <- mapM sumCtorToJSON cs+  body <- caseE (varE v) (map pure matches)+  lamE [varP v] (pure body)++sumCtorToJSON :: ConInfo -> Q Match+sumCtorToJSON c = do+  mi <- reifyModifierInfoFor backendJSON (conInfoName c)+  keyExp <- renderWireKey mi (T.pack (nameBase (conInfoName c)))+  fieldNames <- mapM (\_ -> newName "f") (conInfoFields c)+  let pat = ConP (conInfoName c) [] (map VarP fieldNames)+  contentsE <- case fieldNames of+    []   -> [| Aeson.Null |]+    [n]  -> [| toJSON $(varE n) |]+    ns   -> [| toJSON+                 ($(pure (ListE (map (AppE (VarE 'toJSON) . VarE) ns)))+                    :: [Aeson.Value]) |]+  body <- [| Aeson.object+              [ Aeson.Key.fromText (T.pack "tag")      .= ($(pure keyExp)   :: T.Text)+              , Aeson.Key.fromText (T.pack "contents") .= ($(pure contentsE) :: Aeson.Value)+              ] |]+  pure (Match pat (NormalB body) [])++-- ---------------------------------------------------------------------------+-- FromJSON dispatch+-- ---------------------------------------------------------------------------++fromJSONBody :: TypeInfo -> Q Exp+fromJSONBody ti = case typeInfoShape ti of+  TypeShapeNewtype c   -> fromJSONNewtype c+  TypeShapeRecord  c   -> fromJSONRecord (nameBase (typeInfoName ti)) c+  TypeShapeEnum    cs  -> fromJSONEnum cs+  TypeShapeSum     cs  -> fromJSONSum  cs++fromJSONNewtype :: ConInfo -> Q Exp+fromJSONNewtype c = case conInfoFields c of+  [FieldInfo _ _] -> [| fmap $(conE (conInfoName c)) . parseJSON |]+  _               -> fail "Wireform.Derive.Aeson: newtype must have exactly one field"++fromJSONRecord :: String -> ConInfo -> Q Exp+fromJSONRecord typeName c = do+  obj <- newName "o"+  parserExp <- recordParser obj c+  [| Aeson.withObject typeName (\ $(varP obj) -> $(pure parserExp)) |]++recordParser :: Name -> ConInfo -> Q Exp+recordParser obj c = do+  let conName = conInfoName c+      fields  = conInfoFields c+  case fields of+    []        -> [| pure $(conE conName) |]+    (f0 : fs) -> do+      e0 <- fieldParser obj f0+      hd <- [| $(conE conName) <$> $(pure e0) |]+      foldlM+        (\acc f -> do+            ef <- fieldParser obj f+            [| $(pure acc) <*> $(pure ef) |])+        hd+        fs++fieldParser :: Name -> FieldInfo -> Q Exp+fieldParser obj (FieldInfo mSel _) = do+  selName <- requireSelector mSel+  mi <- reifyModifierInfoFor backendJSON selName+  if miSkip mi+    then case miDefaults mi of+      Just defNm -> [| pure $(varE defNm) |]+      Nothing    -> [| pure (error "Wireform.Derive.Aeson: missing 'defaults' for skipped field") |]+    else do+      let selBase = T.pack (nameBase selName)+      keyExp <- renderWireKey mi selBase+      let isOptional = miRequired mi == Just False+      base <-+        if isOptional+          then [| $(varE obj) .:? Aeson.Key.fromText $(pure keyExp) |]+          else [| $(varE obj) .:  Aeson.Key.fromText $(pure keyExp) |]+      case miCoerce mi of+        Nothing -> pure base+        Just _  -> [| fmap coerce $(pure base) |]++-- | Enum: dispatch on the JSON string against each constructor's+-- rendered key. Built as a `MultiWayIf` so that runtime-rendered keys+-- (from 'renameWith') participate naturally.+fromJSONEnum :: [ConInfo] -> Q Exp+fromJSONEnum cs = do+  s <- newName "s"+  branches <- mapM (enumDispatch s) cs+  let fallback =+        ( NormalG (ConE 'True)+        , AppE (VarE 'fail)+            (InfixE+              (Just (LitE (StringL "Wireform.Derive.Aeson: unknown enum value ")))+              (VarE '(++))+              (Just (AppE (VarE 'show) (VarE s))))+        )+  let multi = MultiIfE (branches ++ [fallback])+  [| Aeson.withText "enum" (\ $(varP s) -> $(pure multi)) |]++enumDispatch :: Name -> ConInfo -> Q (Guard, Exp)+enumDispatch sVar c = do+  mi <- reifyModifierInfoFor backendJSON (conInfoName c)+  keyExp <- renderWireKey mi (T.pack (nameBase (conInfoName c)))+  let guardExp = InfixE (Just (VarE sVar)) (VarE '(==)) (Just keyExp)+      bodyExp  = AppE (VarE 'pure) (ConE (conInfoName c))+  pure (NormalG guardExp, bodyExp)++-- | Sum: read @tag@ + @contents@ from the object, then dispatch via+-- a `MultiWayIf` on the rendered tag key for each constructor.+fromJSONSum :: [ConInfo] -> Q Exp+fromJSONSum cs = do+  obj    <- newName "o"+  tagVar <- newName "tag"+  cVar   <- newName "c"+  branches <- mapM (sumDispatch tagVar cVar) cs+  let fallback =+        ( NormalG (ConE 'True)+        , AppE (VarE 'fail)+            (InfixE+              (Just (LitE (StringL "Wireform.Derive.Aeson: unknown sum tag ")))+              (VarE '(++))+              (Just (AppE (VarE 'show) (VarE tagVar))))+        )+      multi = MultiIfE (branches ++ [fallback])+  [| Aeson.withObject "sum" (\ $(varP obj) -> do+        ($(varP tagVar) :: T.Text) <-+            $(varE obj) .: Aeson.Key.fromText (T.pack "tag")+        ($(varP cVar)   :: Aeson.Value) <-+            $(varE obj) .: Aeson.Key.fromText (T.pack "contents")+        $(pure multi)) |]++sumDispatch :: Name -> Name -> ConInfo -> Q (Guard, Exp)+sumDispatch tagVar cVar c = do+  mi <- reifyModifierInfoFor backendJSON (conInfoName c)+  keyExp <- renderWireKey mi (T.pack (nameBase (conInfoName c)))+  let guardExp = InfixE (Just (VarE tagVar)) (VarE '(==)) (Just keyExp)+  bodyExp <- case conInfoFields c of+    []      -> [| pure $(conE (conInfoName c)) |]+    [_one]  -> [| fmap $(conE (conInfoName c)) (parseJSON $(varE cVar)) |]+    many    -> sumNAry cVar (conInfoName c) (length many)+  pure (NormalG guardExp, bodyExp)++-- | Build a parser for an n-ary sum constructor: parse @contents@ as+-- a JSON array, then apply each element through 'parseJSON' and+-- combine via @ConE c \<$> parse e0 \<*> parse e1 \<*> ...@.+sumNAry :: Name -> Name -> Int -> Q Exp+sumNAry cVar conName arity = do+  arr <- newName "arr"+  let parseI :: Int -> Q Exp+      parseI i = [| parseJSON ($(varE arr) !! $(litE (integerL (fromIntegral i)))) |]+  hd <- do+    e0 <- parseI 0+    [| $(conE conName) <$> $(pure e0) |]+  tail' <- foldlM+    (\acc i -> do+        ei <- parseI i+        [| $(pure acc) <*> $(pure ei) |])+    hd+    [1 .. arity - 1]+  let conNameStr = nameBase conName+  [| do+       ($(varP arr) :: [Aeson.Value]) <- parseJSON $(varE cVar)+       if length $(varE arr) /= $(litE (integerL (fromIntegral arity)))+         then fail ("Wireform.Derive.Aeson: " ++ conNameStr+                    ++ " expected "+                    ++ show ($(litE (integerL (fromIntegral arity))) :: Int)+                    ++ " contents, got " ++ show (length $(varE arr)))+         else $(pure tail') |]++-- ---------------------------------------------------------------------------+-- Helpers+-- ---------------------------------------------------------------------------++requireSelector :: Maybe Name -> Q Name+requireSelector (Just n) = pure n+requireSelector Nothing  =+  fail "Wireform.Derive.Aeson: cannot derive JSON for non-record positional field"++applyTypeArgs :: Type -> [Type] -> Type+applyTypeArgs = foldl AppT
+ src/Wireform/Derive/Backend.hs view
@@ -0,0 +1,195 @@+-- | Identifier for a serialization backend.+--+-- A 'Backend' is a textual tag attached to per-backend modifier overrides+-- (e.g. @forBackend backendProto (rename "n")@) and consulted by each+-- per-format deriver to decide which modifiers apply.+--+-- New backends can be defined by downstream packages: just construct a+-- 'Backend' with a fresh identifier. The set of \"standard\" backends+-- defined here is open-ended and exists only as a convenience so that+-- common cases compose cleanly.+module Wireform.Derive.Backend+  ( Backend (..)+    -- * Standard backends+  , backendProto+  , backendCBOR+  , backendMsgPack+  , backendThrift+  , backendJSON+  , backendEDN+  , backendTOML+  , backendYAML+  , backendXML+  , backendHTML+  , backendCSV+  , backendNDJSON+  , backendBinary+  , backendTextFormat++    -- * Schema-driven backends+  , backendASN1+  , backendAvro+  , backendBond+  , backendFlatBuffers+  , backendCapnProto++    -- * Document / object stores+  , backendBSON+  , backendBencode+  , backendION++    -- * Cross-language object serialization+  , backendFory++    -- * Columnar / tabular+  , backendArrow+  , backendParquet+  , backendOrc+  , backendIceberg+  ) where++import Control.DeepSeq (NFData)+import Data.Data (Data)+import Data.Hashable (Hashable)+import Data.String (IsString)+import Data.Text (Text)+import GHC.Generics (Generic)++-- | Open identifier for a serialization backend.+--+-- 'Backend' has an 'IsString' instance, so backends can be written+-- inline as string literals, e.g. @forBackend "proto" (rename "n")@.+-- Prefer the named constants below where they exist so that typos are+-- caught at compile time.+newtype Backend = Backend { unBackend :: Text }+  deriving stock (Eq, Ord, Show, Data, Generic)+  deriving newtype (IsString, Hashable, NFData)++-- | Protocol Buffers wire encoding.+backendProto :: Backend+backendProto = Backend "proto"++-- | RFC 8949 CBOR.+backendCBOR :: Backend+backendCBOR = Backend "cbor"++-- | MessagePack.+backendMsgPack :: Backend+backendMsgPack = Backend "msgpack"++-- | Apache Thrift binary protocol.+backendThrift :: Backend+backendThrift = Backend "thrift"++-- | JSON (used by both Aeson-style and Proto3 JSON mappings;+-- Proto-JSON-specific overrides should additionally tag with+-- 'backendProto').+backendJSON :: Backend+backendJSON = Backend "json"++-- | Extensible Data Notation (Clojure / EDN).+backendEDN :: Backend+backendEDN = Backend "edn"++-- | TOML.+backendTOML :: Backend+backendTOML = Backend "toml"++-- | YAML.+backendYAML :: Backend+backendYAML = Backend "yaml"++-- | XML.+backendXML :: Backend+backendXML = Backend "xml"++-- | CSV / TSV header rows.+backendCSV :: Backend+backendCSV = Backend "csv"++-- | HTML serialization (sub-vocabulary of XML; element/attribute split).+backendHTML :: Backend+backendHTML = Backend "html"++-- | Newline-delimited JSON. One record per line.+backendNDJSON :: Backend+backendNDJSON = Backend "ndjson"++-- | Catch-all for hand-rolled binary formats that do not fit one of the+-- standard backends above.+backendBinary :: Backend+backendBinary = Backend "binary"++-- | Protobuf text format (@google.protobuf.TextFormat@ / @pbtxt@).+backendTextFormat :: Backend+backendTextFormat = Backend "textformat"++-- ---------------------------------------------------------------------------+-- Schema-driven binary formats+-- ---------------------------------------------------------------------------++-- | ASN.1 BER / DER / PER family.+backendASN1 :: Backend+backendASN1 = Backend "asn1"++-- | Apache Avro.+backendAvro :: Backend+backendAvro = Backend "avro"++-- | Microsoft Bond.+backendBond :: Backend+backendBond = Backend "bond"++-- | FlatBuffers.+backendFlatBuffers :: Backend+backendFlatBuffers = Backend "flatbuffers"++-- | Cap\'n Proto.+backendCapnProto :: Backend+backendCapnProto = Backend "capnproto"++-- ---------------------------------------------------------------------------+-- Document / object stores+-- ---------------------------------------------------------------------------++-- | BSON (MongoDB binary JSON).+backendBSON :: Backend+backendBSON = Backend "bson"++-- | BitTorrent's Bencode.+backendBencode :: Backend+backendBencode = Backend "bencode"++-- | Amazon ION (rich-typed JSON superset).+backendION :: Backend+backendION = Backend "ion"++-- ---------------------------------------------------------------------------+-- Cross-language object serialization+-- ---------------------------------------------------------------------------++-- | Apache Fory (formerly Fury) xlang serialization. Field names+-- are converted to @snake_case@ before being written as the+-- spec\'s meta-string field name.+backendFory :: Backend+backendFory = Backend "fory"++-- ---------------------------------------------------------------------------+-- Columnar / tabular+-- ---------------------------------------------------------------------------++-- | Apache Arrow in-memory columnar layout.+backendArrow :: Backend+backendArrow = Backend "arrow"++-- | Apache Parquet.+backendParquet :: Backend+backendParquet = Backend "parquet"++-- | Apache ORC.+backendOrc :: Backend+backendOrc = Backend "orc"++-- | Apache Iceberg table format.+backendIceberg :: Backend+backendIceberg = Backend "iceberg"
+ src/Wireform/Derive/Extension.hs view
@@ -0,0 +1,155 @@+{-# 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
+ src/Wireform/Derive/Modifier.hs view
@@ -0,0 +1,386 @@+{- | Annotation vocabulary for customising wireform-driven instance+generation.++A 'Modifier' is a single customisation directive (\"rename this+field\", \"flatten this nested record\", \"this field is optional in+Thrift\", ...). Multiple modifiers compose as a 'Modifiers' value.++Modifiers are attached to types and fields using GHC @ANN@ pragmas:++@+data Person = Person+  { personName :: !Text   -- ^ wire key: \"name\"+  , personAge  :: !Int    -- ^ wire key: \"age\"+  } deriving stock Generic++{\-\# ANN type Person (rename "person") \#-\}+{\-\# ANN personName  (rename "name") \#-\}+{\-\# ANN personAge   (renameStyle SnakeCase) \#-\}+@++Per-format derivers (@deriveProto@, @deriveCBOR@, @deriveAeson@, ...)+read these annotations via 'Wireform.Derive.ModifierInfo.reifyModifierInfoFor'+and shape the generated code accordingly.+-}+module Wireform.Derive.Modifier (+  -- * Modifiers+  Modifier (..),+  Modifiers (..),+  noModifiers,++  -- * Renames+  Rename (..),+  rename,+  renameStyle,+  renameWith,+  renameIdiomatic,++  -- * Wire-format overrides+  WireOverride (..),++  -- * Map keys (proto-flavoured)+  MapKeyScalar (..),++  -- * Smart constructors (general)+  coerced,+  flatten,+  skip,+  defaults,+  tag,+  required,+  optional,+  wireOverride,+  customModifier,+  mapKey,+  oneof,++  -- * Per-backend targeting+  forBackend,+  forBackends,+  disableFor,+  onlyFor,++  -- * Inspection+  modifierBackends,+  modifierIsBackendScoped,+) where++import Data.Data (Data)+import Data.Text (Text)+import GHC.Generics (Generic)+import Language.Haskell.TH.Syntax (Name)+import Wireform.Derive.Backend+import Wireform.Derive.NameStyle+++-- ---------------------------------------------------------------------------+-- Rename+-- ---------------------------------------------------------------------------++-- | How to compute a wire key from a Haskell field's selector base name.+data Rename+  = -- | Use this exact 'Text' as the wire key.+    RenameTo !Text+  | -- | Apply a 'NameStyle' transformation. Evaluated entirely at+    -- splice time, so the result is baked into the generated code as+    -- a literal 'Text'.+    RenameStyle !NameStyle+  | -- | Apply the named @Text -> Text@ function at runtime. Use only+    -- when 'NameStyle' cannot express the desired transformation.+    RenameFn !Name+  deriving stock (Eq, Ord, Show, Data, Generic)+++-- ---------------------------------------------------------------------------+-- WireOverride+-- ---------------------------------------------------------------------------++-- | Force a non-default wire encoding for a numeric or string field.+data WireOverride+  = -- | Use ZigZag encoding for signed integers (proto's @sint32@ /+    -- @sint64@).+    WireZigZag+  | -- | Use a fixed-width little-endian encoding (proto's @fixed32@+    -- / @fixed64@ / @sfixed32@ / @sfixed64@).+    WireFixed+  | -- | Pack a repeated scalar field (proto3 default for scalars).+    WirePacked+  | -- | Encode this field as a UTF-8 'Text' regardless of the inferred+    -- representation.+    WireString+  | -- | Encode this field as raw bytes regardless of the inferred+    -- representation.+    WireBytes+  deriving stock (Eq, Ord, Show, Data, Generic)+++-- ---------------------------------------------------------------------------+-- MapKeyScalar+-- ---------------------------------------------------------------------------++{- | Scalar types that protobuf permits as map keys (proto2 §maps,+proto3 §maps). Excludes @float@, @double@, @bytes@, message and+enum types.++Lives in @wireform-derive@ rather than @wireform-proto@ so that+annotations can reference proto map-key types without forcing+non-proto packages to depend on proto. The proto deriver projects+this onto its own @Proto.IDL.AST.ScalarType@.+-}+data MapKeyScalar+  = MapKeyInt32+  | MapKeyInt64+  | MapKeyUInt32+  | MapKeyUInt64+  | MapKeySInt32+  | MapKeySInt64+  | MapKeyFixed32+  | MapKeyFixed64+  | MapKeySFixed32+  | MapKeySFixed64+  | MapKeyBool+  | MapKeyString+  deriving stock (Eq, Ord, Show, Data, Generic, Enum, Bounded)+++-- ---------------------------------------------------------------------------+-- Modifier+-- ---------------------------------------------------------------------------++{- | A single annotation directive. Each format deriver consults+modifiers it understands and silently ignores the rest, so a single+annotation can simultaneously inform several backends.+-}+data Modifier+  = -- | Rename a field on the wire.+    ModRename !Rename+  | -- | Encode / decode the field via the named @newtype@-style+    -- coercion target.+    ModCoerce !Name+  | -- | Inline the contents of this nested record into its parent's+    -- field set, rather than nesting it as a sub-message.+    ModFlatten+  | -- | Omit this field from the wire encoding entirely (decoders+    -- supply 'mempty' / @def@).+    ModSkip+  | -- | Use the named function as the field's default when decoding+    -- a missing value.+    ModDefaults !Name+  | -- | Manually fix this field's numeric tag / id (proto field+    -- number, Thrift field id).+    ModTag !Int+  | -- | Mark a field required (Thrift / proto2 semantics).+    ModRequired+  | -- | Mark a field optional.+    ModOptional+  | -- | Override the field's wire encoding (see 'WireOverride').+    ModWireOverride !WireOverride+  | -- | Apply the inner modifiers /only/ for the listed backends.+    ModForBackends ![Backend] ![Modifier]+  | -- | Apply this single modifier /only/ for the listed backends.+    -- Equivalent to @ModForBackends bs [m]@; provided for cheaper+    -- pretty-printing and tighter @ANN@ payloads in common cases.+    ModBackendOnly ![Backend] !Modifier+  | -- | Skip this name entirely for the listed backends. Equivalent to+    -- @ModForBackends bs [ModSkip]@; provided as its own constructor+    -- so per-format derivers can short-circuit cheaply.+    ModBackendDisable ![Backend]+  | -- | Backend-specific opaque payload. Tagged by an arbitrary+    -- 'Text' identifier so backends can recognise their own; the+    -- payload itself is a 'String' rather than a 'ByteString'+    -- because GHC's 'ANN' machinery serialises the modifier via+    -- @Data.Data@, which works for any algebraic type but fails on+    -- the sealed 'ByteString' instance.+    ModCustom !Text !String+  | -- | This @HashMap@ / @Map@ field is encoded as a proto3 @map@.+    -- The 'MapKeyScalar' picks the wire encoding for the key half.+    -- Value type is inferred from the field's Haskell type.+    --+    -- Only consulted by the proto deriver; other backends ignore it.+    ModMapKey !MapKeyScalar+  | -- | Group this constructor (in a sum) or this field (in a+    -- record) into the named proto @oneof@. All fields sharing the+    -- same group name encode under one @oneof@ block.+    --+    -- Only consulted by the proto deriver; other backends ignore it.+    ModOneof !Text+  deriving stock (Eq, Ord, Show, Data, Generic)+++-- ---------------------------------------------------------------------------+-- Modifiers (composition)+-- ---------------------------------------------------------------------------++{- | A composed bundle of modifiers. Newtype around @[Modifier]@ with a+right-biased 'Semigroup' (later writes shadow earlier ones, matching+the order in which @ANN@ pragmas are reified).+-}+newtype Modifiers = Modifiers {getModifiers :: [Modifier]}+  deriving stock (Eq, Ord, Show, Data, Generic)+++instance Semigroup Modifiers where+  Modifiers xs <> Modifiers ys = Modifiers (xs <> ys)+++instance Monoid Modifiers where+  mempty = Modifiers []+++-- | Empty modifier bundle.+noModifiers :: Modifiers+noModifiers = mempty+++-- ---------------------------------------------------------------------------+-- Smart constructors: renames+-- ---------------------------------------------------------------------------++-- | Rename a field to a fixed string.+rename :: Text -> Modifier+rename = ModRename . RenameTo+++{- | Apply a 'NameStyle' transformation. The deriver evaluates this at+splice time.+-}+renameStyle :: NameStyle -> Modifier+renameStyle = ModRename . RenameStyle+++{- | Apply the named @Text -> Text@ function at runtime. Pass the+function's name with TH's @\'@ syntax, e.g. @renameWith \'myRenamer@.+-}+renameWith :: Name -> Modifier+renameWith = ModRename . RenameFn+++{- | Use the active backend's idiomatic naming convention. Equivalent to+@renameStyle Idiomatic@; provided as a smart constructor for+discoverability.+-}+renameIdiomatic :: Modifier+renameIdiomatic = renameStyle Idiomatic+++-- ---------------------------------------------------------------------------+-- Smart constructors: general+-- ---------------------------------------------------------------------------++-- | See 'ModCoerce'.+coerced :: Name -> Modifier+coerced = ModCoerce+++-- | See 'ModFlatten'.+flatten :: Modifier+flatten = ModFlatten+++-- | See 'ModSkip'.+skip :: Modifier+skip = ModSkip+++-- | See 'ModDefaults'.+defaults :: Name -> Modifier+defaults = ModDefaults+++-- | See 'ModTag'.+tag :: Int -> Modifier+tag = ModTag+++-- | See 'ModRequired'.+required :: Modifier+required = ModRequired+++-- | See 'ModOptional'.+optional :: Modifier+optional = ModOptional+++-- | See 'ModWireOverride'.+wireOverride :: WireOverride -> Modifier+wireOverride = ModWireOverride+++{- | Embed an opaque backend-specific payload. The 'Text' tag should be+a fully-qualified, namespaced identifier (e.g.+@"wireform-proto.json-name"@) so different backends do not clash on+the same tag.++The payload is typed as 'String' rather than 'ByteString' because+GHC's 'ANN' machinery serialises modifiers via @Data.Data@, and+'ByteString' has a sealed 'Data' instance that fails the round+trip. For typed payloads, prefer+'Wireform.Derive.Extension.extension'.+-}+customModifier :: Text -> String -> Modifier+customModifier = ModCustom+++{- | Mark a @HashMap@ / @Map@ field as a proto @map<K,V>@ with the+supplied key encoding. See 'ModMapKey'.+-}+mapKey :: MapKeyScalar -> Modifier+mapKey = ModMapKey+++-- | Group this name into the named proto @oneof@. See 'ModOneof'.+oneof :: Text -> Modifier+oneof = ModOneof+++-- ---------------------------------------------------------------------------+-- Smart constructors: per-backend targeting+-- ---------------------------------------------------------------------------++{- | Restrict a single modifier to one backend.++@forBackend backendProto (rename "name")@+-}+forBackend :: Backend -> Modifier -> Modifier+forBackend b = ModBackendOnly [b]+++{- | Restrict a list of modifiers to a list of backends.++@forBackends [backendProto, backendJSON] [rename "name", tag 7]@+-}+forBackends :: [Backend] -> [Modifier] -> Modifier+forBackends = ModForBackends+++-- | Restrict a single modifier to several backends.+onlyFor :: [Backend] -> Modifier -> Modifier+onlyFor = ModBackendOnly+++-- | Skip this name entirely for the listed backends.+disableFor :: [Backend] -> Modifier+disableFor = ModBackendDisable+++-- ---------------------------------------------------------------------------+-- Inspection+-- ---------------------------------------------------------------------------++{- | The set of backends a modifier targets, or 'Nothing' for a global+modifier (one that applies to every backend).+-}+modifierBackends :: Modifier -> Maybe [Backend]+modifierBackends = \case+  ModForBackends bs _ -> Just bs+  ModBackendOnly bs _ -> Just bs+  ModBackendDisable bs -> Just bs+  _ -> Nothing+++-- | True iff the modifier is restricted to a specific set of backends.+modifierIsBackendScoped :: Modifier -> Bool+modifierIsBackendScoped m = case modifierBackends m of+  Just _ -> True+  Nothing -> False
+ src/Wireform/Derive/ModifierInfo.hs view
@@ -0,0 +1,365 @@+{-# 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 qualified Data.Map.Strict as Map+import Data.Map.Strict (Map)+import Data.Text (Text)+import qualified Data.Text as T+import Language.Haskell.TH (Exp, Name, Q, varE)+import Language.Haskell.TH.Syntax (Lift (lift), Quasi, qReifyAnnotations)+import qualified Language.Haskell.TH.Syntax 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+  | ConflictFlattenSkip+    -- ^ Both 'flatten' and 'skip' set on the same name.+  | 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
+ src/Wireform/Derive/NameStyle.hs view
@@ -0,0 +1,295 @@+-- | Rich DSL for transforming Haskell field selector names into+-- on-the-wire field names.+--+-- 'NameStyle' is intentionally a pure ADT with a 'Data' instance so that+-- it can survive splice-time annotation reflection: a 'NameStyle' value+-- attached via @ANN@ can be reified, fully evaluated at compile time,+-- and inlined into the generated encode/decode code as a literal 'Text'.+--+-- A handful of constructors (notably 'Idiomatic') refer to the active+-- backend rather than to a fixed transformation. These are resolved by+-- 'resolveIdiomatic' before 'applyStyle' is run.+module Wireform.Derive.NameStyle+  ( -- * The style DSL+    NameStyle (..)+  , andThen+    -- * Application+  , applyStyle+    -- * Idiomatic resolution+  , idiomaticFor+  , resolveIdiomatic+    -- * Building blocks (re-exported for testing)+  , toSnakeCase+  , toUpperSnake+  , toKebabCase+  , toUpperKebab+  , toCamelCase+  , toPascalCase+  ) where++import Control.DeepSeq (NFData)+import Data.Char (isLower, isUpper, toUpper)+import Data.Data (Data)+import Data.Hashable (Hashable)+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Generics (Generic)+import Language.Haskell.TH.Syntax (Lift)++import Wireform.Derive.Backend++-- | A composable rename strategy. 'NameStyle' is a closed ADT so that+-- per-format derivers can interpret it at splice time and bake the+-- result into generated wire-key 'Text' literals (zero runtime cost).+data NameStyle+  = -- | @snake_case@. Boundaries inferred from camelCase / PascalCase+    -- humps: @"personName"@ becomes @"person_name"@.+    SnakeCase+  | -- | @SCREAMING_SNAKE_CASE@.+    UpperSnake+  | -- | @kebab-case@.+    KebabCase+  | -- | @SCREAMING-KEBAB-CASE@.+    UpperKebab+  | -- | @lowerCamelCase@. The first character is lowercased; subsequent+    -- humps preserved.+    CamelCase+  | -- | @UpperCamelCase@ / @PascalCase@.+    PascalCase+  | -- | All lowercase.+    LowerCase+  | -- | All uppercase.+    UpperCase+  | -- | Strip a literal prefix if present; otherwise leave the input+    -- unchanged.+    StripPrefix !Text+  | -- | Strip a literal suffix if present; otherwise unchanged.+    StripSuffix !Text+  | -- | Strip a prefix case-insensitively.+    StripPrefixCI !Text+  | -- | Strip a suffix case-insensitively.+    StripSuffixCI !Text+  | -- | Drop @n@ characters from the start of the input.+    DropChars !Int+  | -- | Take only the first @n@ characters of the input.+    TakeChars !Int+  | -- | Replace every occurrence of the first 'Text' with the second.+    Replace !Text !Text+  | -- | Replace only the first occurrence.+    ReplaceFirst !Text !Text+  | -- | Sequential composition: @Compose a b@ first applies @a@, then+    -- @b@.+    Compose !NameStyle !NameStyle+  | -- | Identity transformation.+    NoStyle+  | -- | Apply the active backend's idiomatic naming convention. This+    -- constructor is resolved by 'resolveIdiomatic' before+    -- 'applyStyle' is called.+    Idiomatic+  deriving stock (Eq, Ord, Show, Data, Generic, Lift)+  deriving anyclass (NFData, Hashable)++-- | Left-to-right composition. @a `andThen` b@ first applies @a@, then+-- @b@.+andThen :: NameStyle -> NameStyle -> NameStyle+andThen = Compose+infixl 1 `andThen`++-- | Substitute every 'Idiomatic' marker with the concrete style for+-- the given backend.+resolveIdiomatic :: Backend -> NameStyle -> NameStyle+resolveIdiomatic b = go+  where+    go Idiomatic        = idiomaticFor b+    go (Compose x y)    = Compose (go x) (go y)+    go s                = s++-- | The conventional rename style for a given backend.+--+-- Defaults follow the dominant on-the-wire convention for each format:+--+-- * 'backendJSON' / 'backendProto' → 'CamelCase' (proto3's @json_name@+--   default is @lowerCamelCase@; common JS / TS APIs use the same).+-- * 'backendEDN' / 'backendYAML' → 'KebabCase'.+-- * 'backendTOML' → 'SnakeCase'.+-- * 'backendXML' → 'PascalCase'.+-- * 'backendCBOR' / 'backendMsgPack' / 'backendThrift' / 'backendBinary' /+--   'backendCSV' / 'backendTextFormat' → 'NoStyle' (selector base used+--   verbatim).+--+-- Downstream backends not listed here fall through to 'NoStyle'.+idiomaticFor :: Backend -> NameStyle+idiomaticFor b+  | b == backendJSON        = CamelCase+  | b == backendNDJSON      = CamelCase+  | b == backendProto       = CamelCase+  | b == backendBSON        = CamelCase+  | b == backendION         = CamelCase+  | b == backendEDN         = KebabCase+  | b == backendYAML        = KebabCase+  | b == backendHTML        = KebabCase+  | b == backendTOML        = SnakeCase+  | b == backendAvro        = SnakeCase+  | b == backendBond        = SnakeCase+  | b == backendArrow       = SnakeCase+  | b == backendParquet     = SnakeCase+  | b == backendOrc         = SnakeCase+  | b == backendIceberg     = SnakeCase+  | b == backendXML         = PascalCase+  | b == backendCBOR        = NoStyle+  | b == backendMsgPack     = NoStyle+  | b == backendThrift      = NoStyle+  | b == backendBinary      = NoStyle+  | b == backendCSV         = NoStyle+  | b == backendTextFormat  = NoStyle+  | b == backendASN1        = NoStyle  -- ASN.1 names are positional+  | b == backendBencode     = NoStyle  -- byte-string keys, verbatim+  | b == backendFlatBuffers = SnakeCase+  | b == backendCapnProto   = CamelCase+  | b == backendFory        = SnakeCase+  | otherwise               = NoStyle++-- | Apply a style. 'Idiomatic' constructors that have not been+-- resolved by 'resolveIdiomatic' degrade to 'NoStyle' rather than+-- raise.+applyStyle :: NameStyle -> Text -> Text+applyStyle = go+  where+    go SnakeCase          = toSnakeCase+    go UpperSnake         = T.toUpper . toSnakeCase+    go KebabCase          = toKebabCase+    go UpperKebab         = T.toUpper . toKebabCase+    go CamelCase          = toCamelCase+    go PascalCase         = toPascalCase+    go LowerCase          = T.toLower+    go UpperCase          = T.toUpper+    go (StripPrefix p)    = stripPrefixCS p+    go (StripSuffix s)    = stripSuffixCS s+    go (StripPrefixCI p)  = stripPrefixCI p+    go (StripSuffixCI s)  = stripSuffixCI s+    go (DropChars n)      = T.drop n+    go (TakeChars n)      = T.take n+    go (Replace o n)      = T.replace o n+    go (ReplaceFirst o n) = replaceFirst o n+    go (Compose a b)      = applyStyle b . applyStyle a+    go NoStyle            = id+    go Idiomatic          = id++-- ---------------------------------------------------------------------------+-- Hump-aware splitting+-- ---------------------------------------------------------------------------++-- | Split an identifier into lowercase \"words\" on:+--+-- * existing @_@ / @-@ / spaces, and+-- * camelCase / PascalCase humps (so @PersonName@ → @["person", "name"]@,+--   and @HTTPRequest@ → @["http", "request"]@).+--+-- Used by every snake / kebab / camel transformation.+splitWords :: Text -> [Text]+splitWords =+  filter (not . T.null)+    . map T.toLower+    . concatMap (map T.pack . splitCamelStr . T.unpack)+    . T.split isPunct+  where+    isPunct c = c == '_' || c == '-' || c == ' '++-- | Insert word boundaries at every @lower → upper@ transition and at+-- every @upper-run → (Upper, lower)@ transition. E.g.+-- @"HTTPRequest"@ → @["HTTP", "Request"]@.+splitCamelStr :: String -> [String]+splitCamelStr [] = []+splitCamelStr (c0 : cs0) = go [c0] cs0+  where+    -- @go acc xs@ accumulates the current word in reverse in @acc@.+    go :: String -> String -> [String]+    go acc []                                          = [reverse acc]+    go acc@(prev : _) (x : xs)+      | isLower prev && isUpper x                      = reverse acc : go [x] xs+      | isUpper x, isAcronymRun acc, peekLower xs      =+          -- We are inside an upper-run and the *next* char after @x@+          -- starts a lowercase tail. Close the acronym at @acc@; @x@+          -- begins the new word.+          reverse acc : go [x] xs+      | otherwise                                      = go (x : acc) xs+    go [] _ = error "splitCamelStr: impossible empty acc"++    isAcronymRun :: String -> Bool+    isAcronymRun s = length s >= 1 && all isUpper s++    peekLower :: String -> Bool+    peekLower (y : _) = isLower y+    peekLower []      = False++-- | Lowercase, underscore-separated.+toSnakeCase :: Text -> Text+toSnakeCase = T.intercalate "_" . splitWords++-- | Uppercase, underscore-separated.+toUpperSnake :: Text -> Text+toUpperSnake = T.toUpper . toSnakeCase++-- | Lowercase, hyphen-separated.+toKebabCase :: Text -> Text+toKebabCase = T.intercalate "-" . splitWords++-- | Uppercase, hyphen-separated.+toUpperKebab :: Text -> Text+toUpperKebab = T.toUpper . toKebabCase++-- | @lowerCamelCase@.+toCamelCase :: Text -> Text+toCamelCase t = case splitWords t of+  []     -> T.empty+  (w:ws) -> T.concat (w : map capitalise ws)++-- | @UpperCamelCase@ / @PascalCase@.+toPascalCase :: Text -> Text+toPascalCase = T.concat . map capitalise . splitWords++capitalise :: Text -> Text+capitalise t = case T.uncons t of+  Nothing      -> t+  Just (c, cs) -> T.cons (toUpper c) cs++-- ---------------------------------------------------------------------------+-- Affix stripping+-- ---------------------------------------------------------------------------++stripPrefixCS :: Text -> Text -> Text+stripPrefixCS p t = case T.stripPrefix p t of+  Just rest -> rest+  Nothing   -> t++stripSuffixCS :: Text -> Text -> Text+stripSuffixCS s t = case T.stripSuffix s t of+  Just rest -> rest+  Nothing   -> t++stripPrefixCI :: Text -> Text -> Text+stripPrefixCI p t+  | T.length t >= T.length p+  , T.toLower (T.take (T.length p) t) == T.toLower p+    = T.drop (T.length p) t+  | otherwise = t++stripSuffixCI :: Text -> Text -> Text+stripSuffixCI s t+  | T.length t >= T.length s+  , T.toLower (T.takeEnd (T.length s) t) == T.toLower s+    = T.dropEnd (T.length s) t+  | otherwise = t++-- ---------------------------------------------------------------------------+-- Misc helpers+-- ---------------------------------------------------------------------------++replaceFirst :: Text -> Text -> Text -> Text+replaceFirst needle replacement haystack+  | T.null needle = haystack+  | otherwise = case T.breakOn needle haystack of+      (before, after) ->+        case T.stripPrefix needle after of+          Just rest -> before <> replacement <> rest+          Nothing   -> haystack
+ src/Wireform/Derive/TypeInfo.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE TemplateHaskell #-}++-- | A simplified, format-agnostic view over a Haskell @data@ /+-- @newtype@ declaration suitable for code generation.+--+-- Adapted from riz0id's @serde-th@ but kept thinner: we cover the four+-- shapes ('TypeShapeNewtype', 'TypeShapeRecord', 'TypeShapeEnum',+-- 'TypeShapeSum') that wireform's per-format derivers actually act on,+-- and defer to @th-abstraction@ for the heavy lifting.+module Wireform.Derive.TypeInfo+  ( TypeInfo (..)+  , TypeShape (..)+  , ConInfo (..)+  , FieldInfo (..)+  , reifyTypeInfo++    -- * Convenience+  , typeInfoConstructors+  , isRecordShape+  , isEnumShape+  , isNewtypeShape+  ) where++import Language.Haskell.TH (Cxt, Name, Q, Type, nameBase, reportError)+import Language.Haskell.TH.Datatype+  ( ConstructorInfo (..)+  , ConstructorVariant (..)+  , DatatypeInfo (..)+  , DatatypeVariant (..)+  , reifyDatatype+  )++-- | Reified summary of a data declaration.+data TypeInfo = TypeInfo+  { typeInfoName     :: !Name+    -- ^ Type-constructor name (e.g. @\'\'Person@).+  , typeInfoContext  :: !Cxt+    -- ^ Datatype context (rare; non-empty only for the legacy+    -- @data Eq a => T a@ syntax).+  , typeInfoVarTypes :: ![Type]+    -- ^ The instantiated type variables, one entry per free variable+    -- in declaration order. Suitable for splicing into @instance@+    -- heads.+  , typeInfoShape    :: !TypeShape+  } deriving (Show)++-- | High-level shape of a data declaration. The four shapes carry+-- enough information for the per-format derivers in this package; types+-- that do not fit cleanly (GADTs, existentials, type families) are+-- rejected at 'reifyTypeInfo' time.+data TypeShape+  = -- | A @newtype@. Always exactly one constructor with one field.+    TypeShapeNewtype !ConInfo+  | -- | A @data@ with exactly one record constructor.+    TypeShapeRecord !ConInfo+  | -- | A @data@ in which every constructor is nullary (a C-style+    -- enum). Encodes especially compactly across most formats.+    TypeShapeEnum ![ConInfo]+  | -- | A @data@ with a mix of constructors, some carrying fields,+    -- some not.+    TypeShapeSum ![ConInfo]+  deriving (Show)++-- | A single constructor as seen by the derivers.+data ConInfo = ConInfo+  { conInfoName    :: !Name+  , conInfoIsRecord :: !Bool+  , conInfoFields  :: ![FieldInfo]+  } deriving (Show)++-- | A single field.+data FieldInfo = FieldInfo+  { fieldInfoName :: !(Maybe Name)+    -- ^ The record selector, if any. Positional constructors leave+    -- this as 'Nothing'; per-format derivers index by position in+    -- 'conInfoFields' in that case.+  , fieldInfoType :: !Type+  } deriving (Show)++-- | Reify a 'TypeInfo' from a type-constructor 'Name'. Reports a+-- splice-time error and aborts if the input does not refer to a+-- @data@ or @newtype@ supported by this package.+reifyTypeInfo :: Name -> Q TypeInfo+reifyTypeInfo typeName = do+  dti <- reifyDatatype typeName+  shape <- shapeOf dti+  pure TypeInfo+    { typeInfoName     = datatypeName dti+    , typeInfoContext  = datatypeContext dti+    , typeInfoVarTypes = datatypeInstTypes dti+    , typeInfoShape    = shape+    }+  where+    shapeOf :: DatatypeInfo -> Q TypeShape+    shapeOf dti = case datatypeVariant dti of+      Newtype -> case datatypeCons dti of+        [c] -> pure (TypeShapeNewtype (toConInfo c))+        _   -> reifyError dti "newtype must have exactly one constructor"+      Datatype  -> classifyData dti+      DataInstance      -> reifyError dti "data instances are not supported"+      NewtypeInstance   -> reifyError dti "newtype instances are not supported"+      TypeData          -> reifyError dti "type data declarations are not supported"++    classifyData :: DatatypeInfo -> Q TypeShape+    classifyData dti = case datatypeCons dti of+      []  -> reifyError dti "type has no constructors"+      [c] | constructorVariant c == NormalConstructor && null (constructorFields c)+            -> pure (TypeShapeEnum [toConInfo c])+          | RecordConstructor _ <- constructorVariant c+            -> pure (TypeShapeRecord (toConInfo c))+          | otherwise+            -> pure (TypeShapeSum [toConInfo c])+      cs+        | all isNullary cs+            -> pure (TypeShapeEnum (map toConInfo cs))+        | otherwise+            -> pure (TypeShapeSum (map toConInfo cs))++    isNullary :: ConstructorInfo -> Bool+    isNullary c =+         constructorVariant c == NormalConstructor+      && null (constructorFields c)++    reifyError :: DatatypeInfo -> String -> Q a+    reifyError dti msg = do+      reportError $+        "Wireform.Derive.TypeInfo.reifyTypeInfo: "+          ++ nameBase (datatypeName dti)+          ++ ": " ++ msg+      fail msg++-- | Convert a th-abstraction 'ConstructorInfo' into our smaller+-- 'ConInfo' representation.+toConInfo :: ConstructorInfo -> ConInfo+toConInfo c = case constructorVariant c of+  RecordConstructor fieldNames ->+    ConInfo+      { conInfoName    = constructorName c+      , conInfoIsRecord = True+      , conInfoFields  =+          zipWith (FieldInfo . Just) fieldNames (constructorFields c)+      }+  _ ->+    ConInfo+      { conInfoName    = constructorName c+      , conInfoIsRecord = False+      , conInfoFields  =+          map (FieldInfo Nothing) (constructorFields c)+      }++-- | All constructors in a 'TypeInfo', flattened across every shape.+typeInfoConstructors :: TypeInfo -> [ConInfo]+typeInfoConstructors ti = case typeInfoShape ti of+  TypeShapeNewtype c -> [c]+  TypeShapeRecord  c -> [c]+  TypeShapeEnum    cs -> cs+  TypeShapeSum     cs -> cs++isRecordShape :: TypeShape -> Bool+isRecordShape = \case+  TypeShapeRecord _ -> True+  _                 -> False++isEnumShape :: TypeShape -> Bool+isEnumShape = \case+  TypeShapeEnum _ -> True+  _               -> False++isNewtypeShape :: TypeShape -> Bool+isNewtypeShape = \case+  TypeShapeNewtype _ -> True+  _                  -> False
+ test/Main.hs view
@@ -0,0 +1,21 @@+module Main (main) where++import Test.Tasty (TestTree, defaultMain, testGroup)++import qualified Test.Derive.Aeson+import qualified Test.Derive.Extension+import qualified Test.Derive.Fixtures+import qualified Test.Derive.Modifier+import qualified Test.Derive.NameStyle++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "wireform-derive"+  [ Test.Derive.NameStyle.tests+  , Test.Derive.Modifier.tests+  , Test.Derive.Extension.tests+  , Test.Derive.Fixtures.tests+  , Test.Derive.Aeson.tests+  ]
+ test/Test/Derive/Aeson.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Derive.Aeson (tests) where++import qualified Data.Aeson as A+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KM+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, testCase, (@?=))++import Test.Derive.Aeson.Instances ()+import Test.Derive.Aeson.Types++tests :: TestTree+tests = testGroup "Aeson deriver"+  [ recordTests+  , newtypeTests+  , enumTests+  , sumTests+  ]++-- ---------------------------------------------------------------------------+-- Record+-- ---------------------------------------------------------------------------++recordTests :: TestTree+recordTests = testGroup "record"+  [ testCase "encode applies rename / renameStyle" $ do+      let a = Address "1 Main"  "Springfield" "12345" "secret"+      let v = A.toJSON a+      case v of+        A.Object o -> do+          assertEqual "street key (literal rename)"+            (Just (A.String "1 Main"))+            (KM.lookup (Key.fromText "street") o)+          assertEqual "city key (snake rename)"+            (Just (A.String "Springfield"))+            (KM.lookup (Key.fromText "addr_city") o)+          assertEqual "zip key (strip-prefix + snake)"+            (Just (A.String "12345"))+            (KM.lookup (Key.fromText "zip") o)+          assertBool "internal key skipped under JSON"+            (not (KM.member (Key.fromText "addrInternal") o))+        _ -> fail "expected JSON object"++  , testCase "decode round-trips (skipped field filled by defaults)" $ do+      let a = Address "1 Main" "Springfield" "12345" "secret"+      case A.fromJSON (A.toJSON a) of+        A.Success a' -> do+          assertEqual "street" (addrStreet a) (addrStreet a')+          assertEqual "city"   (addrCity a)   (addrCity a')+          assertEqual "zip"    (addrZip a)    (addrZip a')+          assertEqual "internal -> defaultAddrInternal"+            defaultAddrInternal+            (addrInternal a')+        A.Error e -> fail ("decode failed: " ++ e)+  ]++-- ---------------------------------------------------------------------------+-- Newtype+-- ---------------------------------------------------------------------------++newtypeTests :: TestTree+newtypeTests = testGroup "newtype"+  [ testCase "encode passes through" $+      A.toJSON (UserId 42) @?= A.Number 42++  , testCase "round-trip" $ do+      case A.fromJSON (A.toJSON (UserId 7)) of+        A.Success (UserId n) -> n @?= 7+        A.Error e -> fail e+  ]++-- ---------------------------------------------------------------------------+-- Enum+-- ---------------------------------------------------------------------------++enumTests :: TestTree+enumTests = testGroup "enum"+  [ testCase "encode literal-renamed constructor"+      (A.toJSON Red @?= A.String "red")+  , testCase "encode style-renamed constructor (DarkBlue -> dark-blue)"+      (A.toJSON DarkBlue @?= A.String "dark-blue")+  , testCase "round-trip Red" $+      A.fromJSON (A.String "red")     @?= A.Success Red+  , testCase "round-trip Green" $+      A.fromJSON (A.String "green")   @?= A.Success Green+  , testCase "round-trip DarkBlue" $+      A.fromJSON (A.String "dark-blue") @?= A.Success DarkBlue+  , testCase "unknown value fails" $ do+      case A.fromJSON (A.String "purple") :: A.Result Color of+        A.Error _ -> pure ()+        A.Success c -> fail ("unexpected " ++ show c)+  ]++-- ---------------------------------------------------------------------------+-- Sum+-- ---------------------------------------------------------------------------++sumTests :: TestTree+sumTests = testGroup "sum"+  [ testCase "Point  -> tag/contents (null payload)" $+      A.toJSON Point @?= A.object+        [ Key.fromText "tag"      A..= A.String "point"+        , Key.fromText "contents" A..= A.Null+        ]++  , testCase "Circle -> tag/contents (single payload)" $+      A.toJSON (Circle 1.5) @?= A.object+        [ Key.fromText "tag"      A..= A.String "circle"+        , Key.fromText "contents" A..= A.Number 1.5+        ]++  , testCase "Rect (renameStyle SnakeCase) -> tag = \"rect\", array contents" $ do+      let v = A.toJSON (Rect 2 3)+      case v of+        A.Object o -> do+          KM.lookup (Key.fromText "tag") o+            @?= Just (A.String "rect")+          KM.lookup (Key.fromText "contents") o+            @?= Just (A.toJSON ([A.Number 2, A.Number 3] :: [A.Value]))+        _ -> fail "expected JSON object"++  , testCase "round-trip Point"     $ rt Point+  , testCase "round-trip Circle"    $ rt (Circle 2.5)+  , testCase "round-trip Rect"      $ rt (Rect 4 5)+  , testCase "unknown tag fails" $ do+      let bad = A.object+            [ Key.fromText "tag"      A..= A.String "triangle"+            , Key.fromText "contents" A..= A.Null+            ]+      case A.fromJSON bad :: A.Result Shape of+        A.Error _ -> pure ()+        A.Success s -> fail ("unexpected " ++ show s)+  ]+  where+    rt :: Shape -> IO ()+    rt s = case A.fromJSON (A.toJSON s) of+      A.Success s' -> s' @?= s+      A.Error e    -> fail ("round-trip failed: " ++ e)
+ test/Test/Derive/Aeson/Instances.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}++-- | TH splice site for the Aeson deriver. Lives in its own module so+-- that the @ANN@ pragmas in "Test.Derive.Aeson.Types" are visible to+-- 'reifyAnnotations' (TH stage restriction).+module Test.Derive.Aeson.Instances () where++import Wireform.Derive.Aeson++import Test.Derive.Aeson.Types++deriveJSON ''Address+deriveJSON ''UserId+deriveJSON ''Color+deriveJSON ''Shape
+ test/Test/Derive/Aeson/Types.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Annotated types exercised by the Aeson deriver round-trip tests.+module Test.Derive.Aeson.Types+  ( -- * Record+    Address (..)+  , defaultAddrInternal+    -- * Newtype+  , UserId (..)+    -- * Enum+  , Color (..)+    -- * Sum+  , Shape (..)+  ) where++import Data.Text (Text)++import Wireform.Derive.Backend+import Wireform.Derive.Modifier+import Wireform.Derive.NameStyle++-- | Default value supplied by the deriver for the skipped field.+defaultAddrInternal :: Text+defaultAddrInternal = "<missing>"++-- ---------------------------------------------------------------------------+-- Record (with rename + renameStyle + per-backend overrides)+-- ---------------------------------------------------------------------------++data Address = Address+  { addrStreet :: !Text+  , addrCity   :: !Text+  , addrZip    :: !Text+  , addrInternal :: !Text+  } deriving (Eq, Show)++{-# ANN addrStreet (rename "street") #-}+{-# ANN addrCity   (renameStyle SnakeCase) #-}+{-# ANN addrZip    (renameStyle (StripPrefix "addr" `andThen` SnakeCase)) #-}+-- | Internal field skipped from JSON entirely (no defaults required —+-- the round-trip test seeds the value directly).+{-# ANN addrInternal (forBackend backendJSON skip) #-}+{-# ANN addrInternal (forBackend backendJSON (defaults 'defaultAddrInternal)) #-}++-- ---------------------------------------------------------------------------+-- Newtype+-- ---------------------------------------------------------------------------++newtype UserId = UserId { unUserId :: Int }+  deriving (Eq, Show)++-- ---------------------------------------------------------------------------+-- Enum (renamed constructors)+-- ---------------------------------------------------------------------------++data Color = Red | Green | DarkBlue+  deriving (Eq, Show)++{-# ANN Red       (rename "red") #-}+{-# ANN Green     (rename "green") #-}+{-# ANN DarkBlue  (renameStyle KebabCase) #-}++-- ---------------------------------------------------------------------------+-- Sum-of-products+-- ---------------------------------------------------------------------------++data Shape+  = Point+  | Circle !Double+  | Rect !Double !Double+  deriving (Eq, Show)++{-# ANN Point  (rename "point") #-}+{-# ANN Circle (rename "circle") #-}+{-# ANN Rect   (renameStyle SnakeCase) #-}
+ test/Test/Derive/Extension.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++-- | Round-trip tests for 'Wireform.Derive.Extension'. Two distinct+-- backend-defined modifier types coexist on the same 'Name' and are+-- recovered with full type fidelity.+module Test.Derive.Extension (tests) where++import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as T+import Data.Typeable (Typeable)+import GHC.Generics (Generic)++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++import Wireform.Derive.Backend (backendIceberg)+import Wireform.Derive.Extension+  ( BackendModifier (..)+  , extension+  , hasExtension+  , lookupExtension+  , lookupExtensions+  )+import Wireform.Derive.Modifier (Modifier)+import Wireform.Derive.ModifierInfo+  ( ModifierInfo (..)+  , emptyModifierInfo+  , foldModifiers+  )++-- ---------------------------------------------------------------------------+-- Two pretend backend extension vocabularies+-- ---------------------------------------------------------------------------++data IcebergFieldOpt+  = PartitionColumn+  | OptimisticTransform !Text+  deriving stock (Eq, Show, Read, Typeable, Generic)++instance BackendModifier IcebergFieldOpt where+  backendModifierTag _ = "wireform-iceberg.field-opt"++data XmlFieldOpt+  = AsAttribute+  | AsElement+  | NamespacedTo !Text+  deriving stock (Eq, Show, Read, Typeable, Generic)++instance BackendModifier XmlFieldOpt where+  backendModifierTag _ = "wireform-xml.field-opt"++-- ---------------------------------------------------------------------------+-- Tests+-- ---------------------------------------------------------------------------++tests :: TestTree+tests = testGroup "Wireform.Derive.Extension"+  [ testCase "round-trip a single typed extension" $ do+      let m = extension PartitionColumn+      let mi = applyMods [m]+      lookupExtension @IcebergFieldOpt mi @?= Just PartitionColumn+      hasExtension    @IcebergFieldOpt mi @?= True++  , testCase "round-trip an extension with a Text payload" $ do+      let m = extension (OptimisticTransform (T.pack "year"))+      let mi = applyMods [m]+      lookupExtension @IcebergFieldOpt mi @?= Just (OptimisticTransform (T.pack "year"))++  , testCase "two extensions of the same type are stacked" $ do+      let ms =+            [ extension PartitionColumn+            , extension (OptimisticTransform (T.pack "month"))+            ]+      let mi = applyMods ms+      lookupExtensions @IcebergFieldOpt mi @?=+        [ PartitionColumn+        , OptimisticTransform (T.pack "month")+        ]++  , testCase "two extensions of distinct types coexist" $ do+      let ms = [ extension PartitionColumn+               , extension AsAttribute+               , extension (NamespacedTo (T.pack "ns0"))+               ]+      let mi = applyMods ms+      lookupExtension @IcebergFieldOpt mi @?= Just PartitionColumn+      lookupExtensions @XmlFieldOpt   mi @?=+        [AsAttribute, NamespacedTo (T.pack "ns0")]++  , testCase "absent extension is Nothing" $ do+      let mi = emptyModifierInfo backendIceberg+      lookupExtension @IcebergFieldOpt mi @?= Nothing+      hasExtension    @IcebergFieldOpt mi @?= False++  , testCase "miCustom keys match the BackendModifier tag" $ do+      let mi = applyMods [extension PartitionColumn, extension AsAttribute]+      Map.keys (miCustom mi) @?=+        [ "wireform-iceberg.field-opt"+        , "wireform-xml.field-opt"+        ]+  ]++-- | Fold the given modifiers as if they were attached to a name, so+-- the test mirrors what 'reifyModifierInfoFor' would produce.+applyMods :: [Modifier] -> ModifierInfo+applyMods ms = case foldModifiers backendIceberg ms of+  Right mi -> mi+  Left err -> error ("test fixture: foldModifiers raised " <> show err)
+ test/Test/Derive/Fixtures.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Derive.Fixtures (tests) where++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++import qualified Test.Derive.Fixtures.Reified as R++tests :: TestTree+tests = testGroup "ANN round-trip"+  [ testGroup "wire keys (literal renames)"+      [ testCase "personName JSON  -> \"name\""+          (R.personNameKeyJSON @?= "name")+      , testCase "personName CBOR  -> \"name\""+          (R.personNameKeyCBOR @?= "name")+      ]++  , testGroup "wire keys (renameStyle)"+      [ testCase "personAge JSON  -> \"person_age\" (literal from SnakeCase)"+          (R.personAgeKeyJSON @?= "person_age")+      , testCase "personAge Proto -> \"person_age\" (same; backend rename only on JSON-style)"+          (R.personAgeKeyProto @?= "person_age")+      ]++  , testGroup "wire keys (renameWith — runtime call)"+      [ testCase "personSSN JSON  -> \"_personssn\" (lowercase + underscore prefix)"+          (R.personSSNKeyJSON @?= "_personssn")+      , testCase "personSSN CBOR  -> \"_personssn\""+          (R.personSSNKeyCBOR @?= "_personssn")+      ]++  , testGroup "per-backend overrides"+      [ testCase "personSSN skipped in JSON (via disableFor)"+          (R.personSSNSkipJSON @?= True)+      , testCase "personSSN NOT skipped in CBOR"+          (R.personSSNSkipCBOR @?= False)+      , testCase "personAge tag visible only under proto"+          (R.personAgeTagProto @?= Just 7)+      , testCase "personAge has no tag under JSON"+          (R.personAgeTagJSON @?= Nothing)+      ]+  ]
+ test/Test/Derive/Fixtures/Reified.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Splices that exercise the public deriver API against the+-- annotated types in "Test.Derive.Fixtures.Types".+--+-- Rather than try to embed entire 'ModifierInfo' values (which would+-- require @Lift@ instances we deliberately do not provide), we splice+-- only the values per-format derivers actually consume:+--+-- * the wire-key 'Text' returned by 'renderWireKey'+-- * 'Bool's that summarise key flags after resolution.+module Test.Derive.Fixtures.Reified+  ( -- * Wire keys+    personNameKeyJSON+  , personNameKeyCBOR+  , personAgeKeyJSON+  , personAgeKeyProto+  , personSSNKeyJSON+  , personSSNKeyCBOR++    -- * Resolved flags+  , personSSNSkipJSON+  , personSSNSkipCBOR+  , personAgeTagProto+  , personAgeTagJSON+  ) where++import Data.Text (Text)+import Language.Haskell.TH.Syntax (lift)++import Wireform.Derive.Backend+import Wireform.Derive.ModifierInfo++import qualified Test.Derive.Fixtures.Types as F++-- ---------------------------------------------------------------------------+-- Wire keys+-- ---------------------------------------------------------------------------++personNameKeyJSON :: Text+personNameKeyJSON = $(do+  mi <- reifyModifierInfoFor backendJSON 'F.personName+  renderWireKey mi "personName")++personNameKeyCBOR :: Text+personNameKeyCBOR = $(do+  mi <- reifyModifierInfoFor backendCBOR 'F.personName+  renderWireKey mi "personName")++personAgeKeyJSON :: Text+personAgeKeyJSON = $(do+  mi <- reifyModifierInfoFor backendJSON 'F.personAge+  renderWireKey mi "personAge")++personAgeKeyProto :: Text+personAgeKeyProto = $(do+  mi <- reifyModifierInfoFor backendProto 'F.personAge+  renderWireKey mi "personAge")++personSSNKeyJSON :: Text+personSSNKeyJSON = $(do+  mi <- reifyModifierInfoFor backendJSON 'F.personSSN+  renderWireKey mi "personSSN")++personSSNKeyCBOR :: Text+personSSNKeyCBOR = $(do+  mi <- reifyModifierInfoFor backendCBOR 'F.personSSN+  renderWireKey mi "personSSN")++-- ---------------------------------------------------------------------------+-- Flags+-- ---------------------------------------------------------------------------++personSSNSkipJSON :: Bool+personSSNSkipJSON = $(do+  mi <- reifyModifierInfoFor backendJSON 'F.personSSN+  lift (miSkip mi))++personSSNSkipCBOR :: Bool+personSSNSkipCBOR = $(do+  mi <- reifyModifierInfoFor backendCBOR 'F.personSSN+  lift (miSkip mi))++personAgeTagProto :: Maybe Int+personAgeTagProto = $(do+  mi <- reifyModifierInfoFor backendProto 'F.personAge+  lift (miTag mi))++personAgeTagJSON :: Maybe Int+personAgeTagJSON = $(do+  mi <- reifyModifierInfoFor backendJSON 'F.personAge+  lift (miTag mi))
+ test/Test/Derive/Fixtures/Types.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Annotated data types used to verify that 'ANN' pragmas survive+-- the TH reflection round-trip.+--+-- This module deliberately performs no splices: 'ANN' pragmas are+-- only visible to 'reifyAnnotations' /after/ the declaring module has+-- been compiled, so the splice that reifies them lives in+-- "Test.Derive.Fixtures.Reified".+module Test.Derive.Fixtures.Types+  ( Person (..)+  , personNameRenamer+  ) where++import Data.Text (Text)+import qualified Data.Text as T++import Wireform.Derive.Backend+import Wireform.Derive.Modifier+import Wireform.Derive.NameStyle++-- | Test-only @Text -> Text@ function used by 'renameWith'.+personNameRenamer :: Text -> Text+personNameRenamer = T.cons '_' . T.toLower++data Person = Person+  { personName :: !Text+  , personAge  :: !Int+  , personSSN  :: !Text+  } deriving (Eq, Show)++-- | Type-level rename: identity (kept here for completeness).+{-# ANN type Person (rename "person") #-}++-- | Field-level customisations used by the round-trip tests.+{-# ANN personName (rename "name") #-}+{-# ANN personAge  (renameStyle SnakeCase) #-}+{-# ANN personSSN  (renameWith 'personNameRenamer) #-}++-- | Per-backend overrides: in JSON, 'personSSN' should be skipped;+-- in CBOR it should still be encoded.+{-# ANN personSSN (disableFor [backendJSON]) #-}++-- | Demonstrate that several modifiers compose on a single name.+{-# ANN personAge (forBackend backendProto (tag 7)) #-}
+ test/Test/Derive/Modifier.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Derive.Modifier (tests) where++import qualified Data.Map.Strict as Map+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, testCase, (@?=))++import Wireform.Derive.Backend+import Wireform.Derive.Modifier+import Wireform.Derive.ModifierInfo+import Wireform.Derive.NameStyle++tests :: TestTree+tests = testGroup "Modifier"+  [ testGroup "foldModifiers — happy path"+      [ testCase "empty input gives empty info" $+          foldModifiers backendJSON [] @?= Right (emptyModifierInfo backendJSON)++      , testCase "single rename" $+          fmap miRename (foldModifiers backendJSON [rename "name"])+            @?= Right (Just (RenameSpecLiteral "name"))++      , testCase "duplicate identical rename is no conflict" $+          fmap miRename (foldModifiers backendJSON+            [rename "name", rename "name"])+            @?= Right (Just (RenameSpecLiteral "name"))++      , testCase "skip flag" $+          fmap miSkip (foldModifiers backendJSON [skip])+            @?= Right True++      , testCase "tag set" $+          fmap miTag (foldModifiers backendJSON [tag 7])+            @?= Right (Just 7)++      , testCase "required + only set once" $+          fmap miRequired (foldModifiers backendJSON [required])+            @?= Right (Just True)++      , testCase "optional + only set once" $+          fmap miRequired (foldModifiers backendJSON [optional])+            @?= Right (Just False)+      ]++  , testGroup "foldModifiers — conflicts"+      [ testCase "two distinct renames conflict" $ do+          let r = foldModifiers backendJSON+                    [rename "a", rename "b"]+          case r of+            Left ConflictRename {} -> pure ()+            other -> fail ("expected ConflictRename, got " ++ show other)++      , testCase "two distinct tags conflict" $ do+          let r = foldModifiers backendJSON [tag 1, tag 2]+          case r of+            Left ConflictTag {} -> pure ()+            other -> fail ("expected ConflictTag, got " ++ show other)++      , testCase "required + optional conflict" $ do+          let r = foldModifiers backendJSON [required, optional]+          case r of+            Left ConflictRequired {} -> pure ()+            other -> fail ("expected ConflictRequired, got " ++ show other)++      , testCase "flatten + skip conflict" $ do+          let r = foldModifiers backendJSON [flatten, skip]+          case r of+            Left ConflictFlattenSkip -> pure ()+            other -> fail ("expected ConflictFlattenSkip, got " ++ show other)+      ]++  , testGroup "per-backend overrides"+      [ testCase "backend-only modifier applies for active backend" $+          fmap miRename+              (foldModifiers backendProto+                  [forBackend backendProto (rename "n")])+            @?= Right (Just (RenameSpecLiteral "n"))++      , testCase "backend-only modifier ignored for other backend" $+          fmap miRename+              (foldModifiers backendJSON+                  [forBackend backendProto (rename "n")])+            @?= Right Nothing++      , testCase "per-backend rename shadows global, no conflict" $+          fmap miRename+              (foldModifiers backendProto+                  [ rename "global"+                  , forBackend backendProto (rename "scoped")+                  ])+            @?= Right (Just (RenameSpecLiteral "scoped"))++      , testCase "per-backend rename does not shadow on other backend" $+          fmap miRename+              (foldModifiers backendJSON+                  [ rename "global"+                  , forBackend backendProto (rename "scoped")+                  ])+            @?= Right (Just (RenameSpecLiteral "global"))++      , testCase "disableFor on active backend marks skip" $+          fmap miSkip+              (foldModifiers backendCBOR+                  [ disableFor [backendCBOR, backendMsgPack] ])+            @?= Right True++      , testCase "disableFor on other backend has no effect" $+          fmap miSkip+              (foldModifiers backendJSON+                  [ disableFor [backendCBOR, backendMsgPack] ])+            @?= Right False++      , testCase "forBackends groups multiple modifiers" $ do+          let mi = foldModifiers backendProto+                     [ forBackends [backendProto] [rename "p", tag 9] ]+          fmap miRename mi @?= Right (Just (RenameSpecLiteral "p"))+          fmap miTag    mi @?= Right (Just 9)++      , testCase "forBackends does nothing for unlisted backend" $+          fmap miRename+              (foldModifiers backendJSON+                  [ forBackends [backendProto] [rename "p"] ])+            @?= Right Nothing+      ]++  , testGroup "RenameSpec variants"+      [ testCase "rename literal" $+          fmap miRename (foldModifiers backendJSON [rename "n"])+            @?= Right (Just (RenameSpecLiteral "n"))++      , testCase "renameStyle preserved" $+          fmap miRename (foldModifiers backendJSON+              [renameStyle (StripPrefix "person")])+            @?= Right (Just (RenameSpecStyle (StripPrefix "person")))+      ]++  , testGroup "default rename keys"+      [ testCase "JSON default is camel"+          (defaultRenameForBackend backendJSON "person_name" @?= "personName")+      , testCase "EDN default is kebab"+          (defaultRenameForBackend backendEDN "personName"   @?= "person-name")+      , testCase "CBOR default is verbatim"+          (defaultRenameForBackend backendCBOR "personName"  @?= "personName")+      ]++  , testGroup "ModCustom accumulation"+      [ testCase "two custom payloads with same tag accumulate" $ do+          let mi = foldModifiers backendCBOR+                     [ customModifier "ext.foo" "x"+                     , customModifier "ext.foo" "y"+                     ]+          case mi of+            Right info -> do+              let xs = Map.findWithDefault [] "ext.foo" (miCustom info)+              assertEqual "accumulated count" 2 (length xs)+            Left e -> fail ("unexpected " ++ show e)++      , testCase "custom payloads with different tags don't conflict" $ do+          let mi = foldModifiers backendCBOR+                     [ customModifier "ext.foo" "x"+                     , customModifier "ext.bar" "y"+                     ]+          case mi of+            Right info -> do+              assertBool "foo present" (Map.member "ext.foo" (miCustom info))+              assertBool "bar present" (Map.member "ext.bar" (miCustom info))+            Left e -> fail ("unexpected " ++ show e)+      ]+  ]
+ test/Test/Derive/NameStyle.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Derive.NameStyle (tests) where++import qualified Data.Char as Char+import qualified Data.Text as T+import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))+import Test.Tasty.Hedgehog (testProperty)++import Wireform.Derive.NameStyle++tests :: TestTree+tests = testGroup "NameStyle"+  [ testGroup "applyStyle / golden"+      [ testCase "snake personName"+          (applyStyle SnakeCase "personName"  @?= "person_name")+      , testCase "snake HTTPRequest"+          (applyStyle SnakeCase "HTTPRequest" @?= "http_request")+      , testCase "snake httpRequest"+          (applyStyle SnakeCase "httpRequest" @?= "http_request")+      , testCase "snake-of-snake personName"+          (applyStyle SnakeCase "person_name" @?= "person_name")+      , testCase "kebab personName"+          (applyStyle KebabCase "personName"  @?= "person-name")+      , testCase "kebab HTTPRequest"+          (applyStyle KebabCase "HTTPRequest" @?= "http-request")+      , testCase "camel of snake"+          (applyStyle CamelCase  "person_name" @?= "personName")+      , testCase "camel idempotent"+          (applyStyle CamelCase  "personName"  @?= "personName")+      , testCase "pascal of snake"+          (applyStyle PascalCase "person_name" @?= "PersonName")+      , testCase "pascal idempotent"+          (applyStyle PascalCase "PersonName"  @?= "PersonName")+      , testCase "upper snake"+          (applyStyle UpperSnake "personName"  @?= "PERSON_NAME")+      , testCase "upper kebab"+          (applyStyle UpperKebab "personName"  @?= "PERSON-NAME")+      , testCase "strip prefix present"+          (applyStyle (StripPrefix "person") "personName" @?= "Name")+      , testCase "strip prefix absent"+          (applyStyle (StripPrefix "other") "personName" @?= "personName")+      , testCase "strip prefix CI"+          (applyStyle (StripPrefixCI "PERSON") "personName" @?= "Name")+      , testCase "strip suffix present"+          (applyStyle (StripSuffix "Name") "personName" @?= "person")+      , testCase "compose strip + snake"+          (applyStyle+              (StripPrefix "person" `andThen` SnakeCase)+              "personHttpRequest"+              @?= "http_request")+      , testCase "replace"+          (applyStyle (Replace "Name" "Label") "personName" @?= "personLabel")+      , testCase "drop / take"+          (applyStyle (DropChars 6 `andThen` TakeChars 2) "personName" @?= "Na")+      , testCase "Idiomatic falls through to NoStyle without resolution"+          (applyStyle Idiomatic "personName" @?= "personName")+      ]++  , testGroup "Idiomatic resolution"+      [ testCase "JSON resolves to CamelCase"+          (applyStyle (resolveIdiomatic "json" Idiomatic) "person_name"+             @?= "personName")+      , testCase "EDN resolves to KebabCase"+          (applyStyle (resolveIdiomatic "edn" Idiomatic) "personName"+             @?= "person-name")+      , testCase "Proto resolves to CamelCase"+          (applyStyle (resolveIdiomatic "proto" Idiomatic) "person_name"+             @?= "personName")+      , testCase "TOML resolves to SnakeCase"+          (applyStyle (resolveIdiomatic "toml" Idiomatic) "personName"+             @?= "person_name")+      , testCase "YAML resolves to KebabCase"+          (applyStyle (resolveIdiomatic "yaml" Idiomatic) "personName"+             @?= "person-name")+      , testCase "XML resolves to PascalCase"+          (applyStyle (resolveIdiomatic "xml" Idiomatic) "person_name"+             @?= "PersonName")+      , testCase "CBOR resolves to NoStyle (verbatim)"+          (applyStyle (resolveIdiomatic "cbor" Idiomatic) "personName"+             @?= "personName")+      , testCase "compose preserves outer style"+          (applyStyle (resolveIdiomatic "edn"+              (StripPrefix "person" `andThen` Idiomatic))+              "personHttpRequest"+              @?= "http-request")+      ]++  , testGroup "properties"+      [ testProperty "NoStyle is identity" $ property $ do+          t <- forAll genIdent+          applyStyle NoStyle t === t++      , testProperty "Compose NoStyle a == a" $ property $ do+          t <- forAll genIdent+          applyStyle (Compose NoStyle SnakeCase) t === applyStyle SnakeCase t++      , testProperty "snake then camel preserves alpha" $ property $ do+          t <- forAll genCamelIdent+          let snaked = applyStyle SnakeCase t+              roundTripped = applyStyle CamelCase snaked+          T.toLower roundTripped === T.toLower t++      , testProperty "snake produces lowercase output" $ property $ do+          t <- forAll genIdent+          let s = applyStyle SnakeCase t+          assert (T.all (\c -> not (Char.isUpper c)) s)++      , testProperty "kebab produces lowercase output" $ property $ do+          t <- forAll genIdent+          let s = applyStyle KebabCase t+          assert (T.all (\c -> not (Char.isUpper c)) s)++      , testProperty "applyStyle is total (never bottom)" $ property $ do+          t <- forAll genIdent+          let len = T.length (applyStyle SnakeCase t)+          assert (len >= 0)+      ]+  ]++-- ---------------------------------------------------------------------------+-- Generators+-- ---------------------------------------------------------------------------++-- Identifier-like text: letters, digits, underscores; non-empty.+genIdent :: MonadGen m => m T.Text+genIdent = T.pack <$> Gen.list (Range.linear 1 20)+  (Gen.frequency+    [ (5, Gen.alpha)+    , (1, Gen.element ['_'])+    , (1, Gen.digit)+    ])++-- camelCase identifier: starts lower, no underscores, alphanumeric only.+genCamelIdent :: MonadGen m => m T.Text+genCamelIdent = do+  first <- Gen.lower+  rest  <- Gen.list (Range.linear 0 12) Gen.alphaNum+  pure (T.pack (first : rest))
+ wireform-derive.cabal view
@@ -0,0 +1,125 @@+cabal-version: 3.0+name: wireform-derive+version: 0.1.0.0+synopsis: Annotation-driven Template Haskell deriver core for wireform+description:+  Shared @Modifier@ annotation vocabulary and Template Haskell+  reflection machinery used by per-format @wireform-*@ deriver+  packages (@wireform-proto@, @wireform-cbor@, @wireform-msgpack@,+  @wireform-thrift@, @wireform-avro@, @wireform-bson@, …).+  .+  A single @{-\# ANN ... \#-}@ pragma on a Haskell record drives+  instance generation for every wire format the user opts into.+  The vocabulary lives in @Wireform.Derive.Modifier@:+  .+  * @rename@, @renameStyle@, @renameWith@, @renameIdiomatic@ --+    wire-key text overrides.+  * @tag N@ -- explicit field number / Thrift field ID / Bond ID /+    Iceberg field ID.+  * @skip@, @defaults@, @required@, @optional@, @coerced@,+    @flatten@, @wireOverride@ -- standard knobs.+  * @forBackend@ / @forBackends@ / @disableFor@ -- per-backend+    overrides that shadow globals without conflicting.+  * @mapKey@, @oneof@ -- format-specific shape hints.+  * @extension@ -- typed per-backend payloads via the+    @BackendModifier@ typeclass.+  .+  See the umbrella @wireform@ package for the full multi-format+  story.  Inspired by riz0id's @serde-th@ and Aeson's @aeson-th@.++homepage: https://github.com/iand675/wireform-+bug-reports: https://github.com/iand675/wireform-/issues+license: BSD-3-Clause+license-file: LICENSE+author: Ian Duncan+maintainer: ian@iankduncan.com+copyright: 2026 Ian Duncan+category: Data, Codec, Serialization+build-type: Simple+tested-with: GHC == 9.6.4, GHC == 9.8.4+extra-doc-files:+  CHANGELOG.md+  README.md++source-repository head+  type:     git+  location: https://github.com/iand675/wireform-++common defaults+  ghc-options:+    -Wall+    -Wcompat+    -Widentities+    -Wincomplete-record-updates+    -Wincomplete-uni-patterns+    -Wpartial-fields+    -Wredundant-constraints+    -O2+  default-language: GHC2021+  default-extensions:+    StrictData+    DerivingStrategies+    DeriveGeneric+    DeriveAnyClass+    DeriveDataTypeable+    DeriveLift+    OverloadedStrings+    LambdaCase+    ScopedTypeVariables+    TupleSections+    MultiWayIf+    RecordWildCards+    NamedFieldPuns++library+  import: defaults+  hs-source-dirs: src+  exposed-modules:+    Wireform.Derive+    Wireform.Derive.Backend+    Wireform.Derive.NameStyle+    Wireform.Derive.Modifier+    Wireform.Derive.TypeInfo+    Wireform.Derive.ModifierInfo+    Wireform.Derive.Extension+    Wireform.Derive.Aeson+  build-depends:+    base >= 4.16 && < 5,+    bytestring >= 0.11 && < 0.13,+    containers >= 0.6 && < 0.9,+    text >= 2.0 && < 2.2,+    template-haskell >= 2.18 && < 2.24,+    th-abstraction >= 0.5 && < 0.8,+    mtl >= 2.2 && < 2.4,+    transformers >= 0.5 && < 0.7,+    deepseq >= 1.4 && < 1.6,+    hashable >= 1.3 && < 1.6,+    aeson >= 2.1 && < 2.3++test-suite wireform-derive-test+  import: defaults+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs: test+  other-modules:+    Test.Derive.NameStyle+    Test.Derive.Modifier+    Test.Derive.Extension+    Test.Derive.Fixtures+    Test.Derive.Fixtures.Types+    Test.Derive.Fixtures.Reified+    Test.Derive.Aeson+    Test.Derive.Aeson.Types+    Test.Derive.Aeson.Instances+  build-depends:+    base,+    wireform-derive,+    bytestring,+    containers,+    text,+    aeson,+    template-haskell,+    hedgehog >= 1.0 && < 1.8,+    tasty >= 1.4 && < 1.6,+    tasty-hedgehog >= 1.0 && < 1.8,+    tasty-hunit >= 0.10 && < 0.11