diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 `.Derive` module that + consumes the same vocabulary. Adding a new format mostly means + cloning the nearest existing `.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. diff --git a/src/Wireform/Derive.hs b/src/Wireform/Derive.hs new file mode 100644 --- /dev/null +++ b/src/Wireform/Derive.hs @@ -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 diff --git a/src/Wireform/Derive/Aeson.hs b/src/Wireform/Derive/Aeson.hs new file mode 100644 --- /dev/null +++ b/src/Wireform/Derive/Aeson.hs @@ -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 diff --git a/src/Wireform/Derive/Backend.hs b/src/Wireform/Derive/Backend.hs new file mode 100644 --- /dev/null +++ b/src/Wireform/Derive/Backend.hs @@ -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" diff --git a/src/Wireform/Derive/Extension.hs b/src/Wireform/Derive/Extension.hs new file mode 100644 --- /dev/null +++ b/src/Wireform/Derive/Extension.hs @@ -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-\.\\"@ 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 diff --git a/src/Wireform/Derive/Modifier.hs b/src/Wireform/Derive/Modifier.hs new file mode 100644 --- /dev/null +++ b/src/Wireform/Derive/Modifier.hs @@ -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@ 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 diff --git a/src/Wireform/Derive/ModifierInfo.hs b/src/Wireform/Derive/ModifierInfo.hs new file mode 100644 --- /dev/null +++ b/src/Wireform/Derive/ModifierInfo.hs @@ -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 diff --git a/src/Wireform/Derive/NameStyle.hs b/src/Wireform/Derive/NameStyle.hs new file mode 100644 --- /dev/null +++ b/src/Wireform/Derive/NameStyle.hs @@ -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 diff --git a/src/Wireform/Derive/TypeInfo.hs b/src/Wireform/Derive/TypeInfo.hs new file mode 100644 --- /dev/null +++ b/src/Wireform/Derive/TypeInfo.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 + ] diff --git a/test/Test/Derive/Aeson.hs b/test/Test/Derive/Aeson.hs new file mode 100644 --- /dev/null +++ b/test/Test/Derive/Aeson.hs @@ -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) diff --git a/test/Test/Derive/Aeson/Instances.hs b/test/Test/Derive/Aeson/Instances.hs new file mode 100644 --- /dev/null +++ b/test/Test/Derive/Aeson/Instances.hs @@ -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 diff --git a/test/Test/Derive/Aeson/Types.hs b/test/Test/Derive/Aeson/Types.hs new file mode 100644 --- /dev/null +++ b/test/Test/Derive/Aeson/Types.hs @@ -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 = "" + +-- --------------------------------------------------------------------------- +-- 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) #-} diff --git a/test/Test/Derive/Extension.hs b/test/Test/Derive/Extension.hs new file mode 100644 --- /dev/null +++ b/test/Test/Derive/Extension.hs @@ -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) diff --git a/test/Test/Derive/Fixtures.hs b/test/Test/Derive/Fixtures.hs new file mode 100644 --- /dev/null +++ b/test/Test/Derive/Fixtures.hs @@ -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) + ] + ] diff --git a/test/Test/Derive/Fixtures/Reified.hs b/test/Test/Derive/Fixtures/Reified.hs new file mode 100644 --- /dev/null +++ b/test/Test/Derive/Fixtures/Reified.hs @@ -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)) diff --git a/test/Test/Derive/Fixtures/Types.hs b/test/Test/Derive/Fixtures/Types.hs new file mode 100644 --- /dev/null +++ b/test/Test/Derive/Fixtures/Types.hs @@ -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)) #-} diff --git a/test/Test/Derive/Modifier.hs b/test/Test/Derive/Modifier.hs new file mode 100644 --- /dev/null +++ b/test/Test/Derive/Modifier.hs @@ -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) + ] + ] diff --git a/test/Test/Derive/NameStyle.hs b/test/Test/Derive/NameStyle.hs new file mode 100644 --- /dev/null +++ b/test/Test/Derive/NameStyle.hs @@ -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)) diff --git a/wireform-derive.cabal b/wireform-derive.cabal new file mode 100644 --- /dev/null +++ b/wireform-derive.cabal @@ -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