wireform-derive 0.1.0.0 → 0.2.0.0
raw patch · 20 files changed
+1808/−1430 lines, 20 filesdep +sydtestdep +sydtest-hedgehogdep −tastydep −tasty-hedgehogdep −tasty-hunitdep ~template-haskellPVP ok
version bump matches the API change (PVP)
Dependencies added: sydtest, sydtest-hedgehog
Dependencies removed: tasty, tasty-hedgehog, tasty-hunit
Dependency ranges changed: template-haskell
API changes (from Hackage documentation)
Files
- CHANGELOG.md +2/−2
- src/Wireform/Derive.hs +49/−44
- src/Wireform/Derive/Aeson.hs +197/−136
- src/Wireform/Derive/Backend.hs +94/−60
- src/Wireform/Derive/Extension.hs +115/−102
- src/Wireform/Derive/Modifier.hs +61/−45
- src/Wireform/Derive/ModifierInfo.hs +223/−193
- src/Wireform/Derive/NameStyle.hs +176/−138
- src/Wireform/Derive/TypeInfo.hs +116/−91
- test/Main.hs +18/−15
- test/Test/Derive/Aeson.hs +112/−108
- test/Test/Derive/Aeson/Instances.hs +6/−5
- test/Test/Derive/Aeson/Types.hs +52/−26
- test/Test/Derive/Extension.hs +71/−68
- test/Test/Derive/Fixtures.hs +48/−36
- test/Test/Derive/Fixtures/Reified.hs +85/−56
- test/Test/Derive/Fixtures/Types.hs +33/−21
- test/Test/Derive/Modifier.hs +183/−159
- test/Test/Derive/NameStyle.hs +163/−120
- wireform-derive.cabal +4/−5
CHANGELOG.md view
@@ -1,8 +1,8 @@ # Changelog for wireform-derive -## 0.1.0.0 -- 2026-05-16+## 0.2.0.0 -- 2026-07-16 -Initial public release of the cross-format deriver core.+Breaking release from 0.1.0.0. ### Highlights
src/Wireform/Derive.hs view
@@ -1,56 +1,61 @@--- | 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+{- | Annotation-driven Template Haskell deriver core, shared across+every wireform format package. - -- * Name styles- , module Wireform.Derive.NameStyle+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: - -- * Modifiers- , module Wireform.Derive.Modifier+@+import Wireform.Derive+@ - -- * Type reflection- , module Wireform.Derive.TypeInfo+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. - -- * Resolution- , module Wireform.Derive.ModifierInfo+== Usage - -- * Backend extension vocabulary- --- -- | Per-backend modifiers without modifying the core ADT. See- -- 'Wireform.Derive.Extension' for the rationale.- , module Wireform.Derive.Extension- ) where+1. Annotate types and fields with 'Modifier's via @ANN@ pragmas.+2. In a deriver splice, call 'reifyTypeInfo' for the data type and+ 'reifyModifierInfoFor' / 'reifyModifierInfo' for each affected+ 'Name' to obtain a backend-resolved 'ModifierInfo'.+3. Use 'renderRenameKey' or 'renderWireKey' to splice the+ appropriate 'Text' (or runtime expression) for each field's wire+ key. +See "Wireform.Derive.Aeson" for a complete worked example.+-}+module Wireform.Derive (+ -- * Backends+ module Wireform.Derive.Backend,++ -- * Name styles+ module Wireform.Derive.NameStyle,++ -- * Modifiers+ module Wireform.Derive.Modifier,++ -- * Type reflection+ module Wireform.Derive.TypeInfo,++ -- * Resolution+ module Wireform.Derive.ModifierInfo,++ -- * Backend extension vocabulary++ --++ {- | Per-backend modifiers without modifying the core ADT. See+ 'Wireform.Derive.Extension' for the rationale.+ -}+ module Wireform.Derive.Extension,+) where+ import Wireform.Derive.Backend import Wireform.Derive.Extension import Wireform.Derive.Modifier import Wireform.Derive.ModifierInfo import Wireform.Derive.NameStyle import Wireform.Derive.TypeInfo+
src/Wireform/Derive/Aeson.hs view
@@ -1,55 +1,56 @@ {-# 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+{- | 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.Aeson qualified as Aeson+import Data.Aeson.Key qualified as Aeson.Key import Data.Coerce (coerce) import Data.Foldable (foldlM)-import qualified Data.Text as T+import Data.Text qualified as T import Language.Haskell.TH- import Wireform.Derive.Backend import Wireform.Derive.ModifierInfo import Wireform.Derive.TypeInfo + -- --------------------------------------------------------------------------- -- Public entry points -- ---------------------------------------------------------------------------@@ -58,60 +59,73 @@ 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) []]]+ 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) []]]+ 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+ 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)) |]+ lamE [varP x] [|toJSON ($(varE sel) $(varE x))|] [FieldInfo Nothing _] -> do x <- newName "x"- lamE [conP (conInfoName c) [varP x]] [| toJSON $(varE 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) |]+ 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@@ -123,13 +137,15 @@ 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)) |]+ 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.++{- | 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"@@ -137,17 +153,20 @@ 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) |]+ 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.++{- | 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"@@ -155,6 +174,7 @@ body <- caseE (varE v) (map pure matches) lamE [varP v] (pure body) + sumCtorToJSON :: ConInfo -> Q Match sumCtorToJSON c = do mi <- reifyModifierInfoFor backendJSON (conInfoName c)@@ -162,171 +182,212 @@ 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)- ] |]+ [] -> [|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+ 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"+ [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)) |]+ [|Aeson.withObject typeName (\ $(varP obj) -> $(pure parserExp))|] + recordParser :: Name -> ConInfo -> Q Exp recordParser obj c = do let conName = conInfoName c- fields = conInfoFields c+ fields = conInfoFields c case fields of- [] -> [| pure $(conE conName) |]+ [] -> [|pure $(conE conName)|] (f0 : fs) -> do e0 <- fieldParser obj f0- hd <- [| $(conE conName) <$> $(pure e0) |]+ hd <- [|$(conE conName) <$> $(pure e0)|] foldlM- (\acc f -> do+ ( \acc f -> do ef <- fieldParser obj f- [| $(pure acc) <*> $(pure ef) |])+ [|$(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") |]+ 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) |]+ 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) |]+ 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.++{- | 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))))+ , 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)) |]+ [|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))+ 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.++{- | 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"+ obj <- newName "o" tagVar <- newName "tag"- cVar <- newName "c"+ 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))))+ , 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) <-+ [|+ Aeson.withObject+ "sum"+ ( \ $(varP obj) -> do+ ($(varP tagVar) :: T.Text) <- $(varE obj) .: Aeson.Key.fromText (T.pack "tag")- ($(varP cVar) :: Aeson.Value) <-+ ($(varP cVar) :: Aeson.Value) <- $(varE obj) .: Aeson.Key.fromText (T.pack "contents")- $(pure multi)) |]+ $(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 $(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 \<*> ...@.++{- | 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)))) |]+ 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]+ [|$(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') |]+ [|+ 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 =+requireSelector Nothing = fail "Wireform.Derive.Aeson: cannot derive JSON for non-record positional field"+ applyTypeArgs :: Type -> [Type] -> Type applyTypeArgs = foldl AppT
src/Wireform/Derive/Backend.hs view
@@ -1,53 +1,55 @@--- | 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+{- | Identifier for a serialization backend. - -- * Schema-driven backends- , backendASN1- , backendAvro- , backendBond- , backendFlatBuffers- , backendCapnProto+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. - -- * Document / object stores- , backendBSON- , backendBencode- , backendION+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 (..), - -- * Cross-language object serialization- , backendFory+ -- * Standard backends+ backendProto,+ backendCBOR,+ backendMsgPack,+ backendThrift,+ backendJSON,+ backendEDN,+ backendTOML,+ backendYAML,+ backendXML,+ backendHTML,+ backendCSV,+ backendNDJSON,+ backendBinary,+ backendTextFormat, - -- * Columnar / tabular- , backendArrow- , backendParquet- , backendOrc- , backendIceberg- ) where+ -- * 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)@@ -55,75 +57,94 @@ 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 }++{- | 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').++{- | 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.++{- | 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 -- ---------------------------------------------------------------------------@@ -132,22 +153,27 @@ 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 -- ---------------------------------------------------------------------------@@ -156,24 +182,29 @@ 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.+{- | 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 -- ---------------------------------------------------------------------------@@ -182,13 +213,16 @@ 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
src/Wireform/Derive/Extension.hs view
@@ -2,131 +2,141 @@ {-# 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 (..)+{- | Typed, per-backend modifier extensions. - -- * Embedding- , extension+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?\" - -- * Reading back- , lookupExtension- , lookupExtensions- , hasExtension- ) where+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. -import qualified Data.Map.Strict as Map+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 Data.Map.Strict qualified as Map import Data.Maybe (mapMaybe) import Data.Proxy (Proxy (..)) import Data.Text (Text) import Data.Typeable (Typeable) import Text.Read (readMaybe)- import Wireform.Derive.Modifier (Modifier (..), customModifier) import Wireform.Derive.ModifierInfo (ModifierInfo (..)) --- | Types that may be embedded into a 'Modifier' as a backend-specific--- extension payload.------ The 'Show' representation is what gets persisted into the @.hi@--- file via the underlying @ANN@ pragma; the 'Read' instance reverses--- it at splice time. 'Typeable' is required so derivers can assert--- the expected vocabulary on extraction.------ The 'backendModifierTag' is a globally-unique key for the--- extension. Convention: @\"wireform-\<backend\>.\<concept\>\"@ so--- two backends that happen to use the same concept name (e.g.--- @\"partition\"@) do not collide.++{- | Types that may be embedded into a 'Modifier' as a backend-specific+extension payload.++The 'Show' representation is what gets persisted into the @.hi@+file via the underlying @ANN@ pragma; the 'Read' instance reverses+it at splice time. 'Typeable' is required so derivers can assert+the expected vocabulary on extraction.++The 'backendModifierTag' is a globally-unique key for the+extension. Convention: @\"wireform-\<backend\>.\<concept\>\"@ so+two backends that happen to use the same concept name (e.g.+@\"partition\"@) do not collide.+-} class (Eq a, Show a, Read a, Typeable a) => BackendModifier a where backendModifierTag :: Proxy a -> Text --- | Lift a typed value into a 'Modifier'. The result can be attached--- via an @ANN@ pragma like any other modifier.------ @--- {-\# ANN myField (extension PartitionColumn) \#-}--- @++{- | 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.++{- | 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+ :: forall a+ . BackendModifier a => ModifierInfo -> Maybe a lookupExtension mi = case lookupExtensions @a mi of (a : _) -> Just a- [] -> Nothing+ [] -> Nothing --- | Like 'lookupExtension' but returns every successfully-decoded--- value of the requested type. Order matches the order in which @ANN@--- pragmas were processed.++{- | 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+ :: forall a+ . BackendModifier a => ModifierInfo -> [a] lookupExtensions mi =@@ -140,16 +150,19 @@ -- declaration order so per-call iteration matches user intent. decodeOne :: Modifier -> Maybe a decodeOne (ModCustom _ s) = readMaybe s- decodeOne _ = Nothing+ decodeOne _ = Nothing --- | True iff at least one 'BackendModifier' of the requested type is--- attached to the name.++{- | True iff at least one 'BackendModifier' of the requested type is+attached to the name.+-} hasExtension- :: forall a. BackendModifier a+ :: 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+ Just _ -> True
src/Wireform/Derive/Modifier.hs view
@@ -81,12 +81,14 @@ 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'.+ | {- | 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.+ | {- | 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) @@ -97,19 +99,23 @@ -- | Force a non-default wire encoding for a numeric or string field. data WireOverride- = -- | Use ZigZag encoding for signed integers (proto's @sint32@ /- -- @sint64@).+ = {- | Use ZigZag encoding for signed integers (proto's @sint32@ /+ @sint64@).+ -} WireZigZag- | -- | Use a fixed-width little-endian encoding (proto's @fixed32@- -- / @fixed64@ / @sfixed32@ / @sfixed64@).+ | {- | 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.+ | {- | 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.+ | {- | Encode this field as raw bytes regardless of the inferred+ representation.+ -} WireBytes deriving stock (Eq, Ord, Show, Data, Generic) @@ -154,20 +160,25 @@ data Modifier = -- | Rename a field on the wire. ModRename !Rename- | -- | Encode / decode the field via the named @newtype@-style- -- coercion target.+ | {- | 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.+ | {- | 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@).+ | {- | 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.+ | {- | 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).+ | {- | Manually fix this field's numeric tag / id (proto field+ number, Thrift field id).+ -} ModTag !Int | -- | Mark a field required (Thrift / proto2 semantics). ModRequired@@ -177,32 +188,37 @@ 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.+ | {- | 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.+ | {- | 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.+ | {- | 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.+ | {- | 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.+ | {- | 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)
src/Wireform/Derive/ModifierInfo.hs view
@@ -1,151 +1,166 @@ {-# 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+{- | Backend-aware folding of @[Modifier]@ annotations into a typed+'ModifierInfo' record. - -- * Resolution- , foldModifiers- , reifyModifierInfoFor- , reifyModifierInfo+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. - -- * Errors- , ModifierError (..)+== Resolution strategy - -- * Wire-key rendering- , renderRenameKey- , renderWireKey+Modifiers are folded in two passes: - -- * Helpers- , defaultRenameForBackend- ) where+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.Map.Strict qualified as Map import Data.Text (Text)-import qualified Data.Text as T+import Data.Text qualified 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 Language.Haskell.TH.Syntax qualified as TH import Wireform.Derive.Backend import Wireform.Derive.Modifier import Wireform.Derive.NameStyle + -- --------------------------------------------------------------------------- -- Folded ModifierInfo -- --------------------------------------------------------------------------- --- | A field's resolved rename spec.------ * 'RenameSpecLiteral' — a fully-baked 'Text' (from 'RenameTo'). Used--- verbatim as the wire key.--- * 'RenameSpecStyle' — a 'NameStyle' to apply to the field's--- selector base name at render time (so 'Idiomatic' can be resolved--- against the deriver's active backend).--- * 'RenameSpecApply' — a @Text -> Text@ function to call at /runtime/--- on the selector base name.+{- | 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+ | RenameSpecStyle !NameStyle+ | RenameSpecApply !Name deriving (Eq, Show) --- | A fully resolved view of the modifiers attached to a single--- 'Name', filtered for one active 'Backend'.++{- | 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)+ { 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- }+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+ = 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.+ | ConflictMapKey !MapKeyScalar !MapKeyScalar+ | ConflictOneof !Text !Text+ | -- | Both 'flatten' and 'skip' set on the same name.+ ConflictFlattenSkip | InvalidRenameFnArity !Name !Int deriving (Eq, Show) + instance Exception ModifierError + -- --------------------------------------------------------------------------- -- foldModifiers -- --------------------------------------------------------------------------- --- | Resolve a list of modifiers against a backend. Conflicts within--- the global pass yield 'Left'; per-backend overrides cleanly shadow--- global directives.+{- | 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@@ -154,26 +169,34 @@ 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'.+{- | 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+ 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.++{- | 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]@@ -183,69 +206,80 @@ 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.+{- | 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))) |]+ 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.++{- | 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)+ 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.++{- | 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.+{- | 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)+ | otherwise = (m : g, s) --- | Expand backend-scoped wrappers into a flat list of modifiers--- that apply to the active backend.++{- | 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 = []+ | otherwise = [] unwrap (ModBackendOnly bs m) | b `elem` bs = unwrap m- | otherwise = []+ | otherwise = [] unwrap (ModBackendDisable bs) | b `elem` bs = [ModSkip]- | otherwise = []+ | 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 -- ---------------------------------------------------------------------------@@ -256,110 +290,106 @@ -> ModifierInfo -> [Modifier] -> Either ModifierError ModifierInfo-foldList _ acc [] = pure acc-foldList b acc (m:ms) = do+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.++{- | 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.++{- | 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 }-+ _ -> pure mi {miRename = Just new} ModCoerce n -> case miCoerce mi of Just old | old /= n -> Left (ConflictCoerce old n)- _ -> pure mi { miCoerce = Just n }-+ _ -> pure mi {miCoerce = Just n} ModFlatten | miSkip mi -> Left ConflictFlattenSkip- | otherwise -> pure mi { miFlatten = True }-+ | otherwise -> pure mi {miFlatten = True} ModSkip | miFlatten mi -> Left ConflictFlattenSkip- | otherwise -> pure mi { miSkip = True }-+ | otherwise -> pure mi {miSkip = True} ModDefaults n -> case miDefaults mi of Just old | old /= n -> Left (ConflictDefaults old n)- _ -> pure mi { miDefaults = Just 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 }-+ _ -> pure mi {miTag = Just t} ModRequired -> case miRequired mi of Just False -> Left (ConflictRequired False True)- _ -> pure mi { miRequired = Just True }-+ _ -> pure mi {miRequired = Just True} ModOptional -> case miRequired mi of Just True -> Left (ConflictRequired True False)- _ -> pure mi { miRequired = Just 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 }-+ _ -> pure mi {miWireOverride = Just wo} ModMapKey k -> case miMapKey mi of Just old | old /= k -> Left (ConflictMapKey old k)- _ -> pure mi { miMapKey = Just 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 }-+ _ -> pure mi {miOneof = Just o} m@(ModCustom tagName _) ->- pure mi { miCustom = Map.insertWith (++) tagName [m] (miCustom mi) }-+ 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+ ModForBackends _ _ -> pure mi+ ModBackendOnly _ _ -> pure mi+ ModBackendDisable _ -> pure mi --- | Like 'mergeOne' but unconditionally overwrites; used for--- per-backend overrides.++{- | 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 }+ 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+ 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'.++{- | 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+ RenameTo t -> RenameSpecLiteral t RenameStyle s -> RenameSpecStyle s- RenameFn n -> RenameSpecApply n+ RenameFn n -> RenameSpecApply n
src/Wireform/Derive/NameStyle.hs view
@@ -1,49 +1,55 @@--- | 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+{- | 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 Data.Text qualified 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).++{- | 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"@.+ = {- | @snake_case@. Boundaries inferred from camelCase / PascalCase+ humps: @"personName"@ becomes @"person_name"@.+ -} SnakeCase | -- | @SCREAMING_SNAKE_CASE@. UpperSnake@@ -51,8 +57,9 @@ KebabCase | -- | @SCREAMING-KEBAB-CASE@. UpperKebab- | -- | @lowerCamelCase@. The first character is lowercased; subsequent- -- humps preserved.+ | {- | @lowerCamelCase@. The first character is lowercased; subsequent+ humps preserved.+ -} CamelCase | -- | @UpperCamelCase@ / @PascalCase@. PascalCase@@ -60,8 +67,9 @@ LowerCase | -- | All uppercase. UpperCase- | -- | Strip a literal prefix if present; otherwise leave the input- -- unchanged.+ | {- | Strip a literal prefix if present; otherwise leave the input+ unchanged.+ -} StripPrefix !Text | -- | Strip a literal suffix if present; otherwise unchanged. StripSuffix !Text@@ -77,115 +85,129 @@ Replace !Text !Text | -- | Replace only the first occurrence. ReplaceFirst !Text !Text- | -- | Sequential composition: @Compose a b@ first applies @a@, then- -- @b@.+ | {- | 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.+ | {- | 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@.++{- | 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.++{- | 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+ 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'.++{- | 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 == 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+ | 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.++{- | 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 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+ 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.+{- | 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)@@ -195,24 +217,28 @@ 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"]@.++{- | 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 [] = [reverse acc] go acc@(prev : _) (x : xs)- | isLower prev && isUpper x = reverse acc : go [x] xs- | isUpper x, isAcronymRun acc, peekLower 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+ | otherwise = go (x : acc) xs go [] _ = error "splitCamelStr: impossible empty acc" isAcronymRun :: String -> Bool@@ -220,39 +246,47 @@ peekLower :: String -> Bool peekLower (y : _) = isLower y- peekLower [] = False+ 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)+ [] -> 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+ Nothing -> t Just (c, cs) -> T.cons (toUpper c) cs + -- --------------------------------------------------------------------------- -- Affix stripping -- ---------------------------------------------------------------------------@@ -260,27 +294,31 @@ stripPrefixCS :: Text -> Text -> Text stripPrefixCS p t = case T.stripPrefix p t of Just rest -> rest- Nothing -> t+ Nothing -> t + stripSuffixCS :: Text -> Text -> Text stripSuffixCS s t = case T.stripSuffix s t of Just rest -> rest- Nothing -> t+ 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+ , 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+ , T.toLower (T.takeEnd (T.length s) t) == T.toLower s =+ T.dropEnd (T.length s) t | otherwise = t + -- --------------------------------------------------------------------------- -- Misc helpers -- ---------------------------------------------------------------------------@@ -292,4 +330,4 @@ (before, after) -> case T.stripPrefix needle after of Just rest -> before <> replacement <> rest- Nothing -> haystack+ Nothing -> haystack
src/Wireform/Derive/TypeInfo.hs view
@@ -1,172 +1,197 @@ {-# 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+{- | A simplified, format-agnostic view over a Haskell @data@ /+@newtype@ declaration suitable for code generation. - -- * Convenience- , typeInfoConstructors- , isRecordShape- , isEnumShape- , isNewtypeShape- ) where+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- )+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).+ { 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)+ {- ^ 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.++{- | 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.+ | {- | 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.+ | {- | 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+ { conInfoName :: !Name , conInfoIsRecord :: !Bool- , conInfoFields :: ![FieldInfo]- } deriving (Show)+ , 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.+ {- ^ 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)+ }+ 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.++{- | 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- }+ 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"+ _ -> 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])+ [] -> 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))+ | 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)+ constructorVariant c == NormalConstructor+ && null (constructorFields c) reifyError :: DatatypeInfo -> String -> Q a reifyError dti msg = do reportError $ "Wireform.Derive.TypeInfo.reifyTypeInfo: " ++ nameBase (datatypeName dti)- ++ ": " ++ msg+ ++ ": "+ ++ msg fail msg --- | Convert a th-abstraction 'ConstructorInfo' into our smaller--- 'ConInfo' representation.++{- | 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+ { conInfoName = constructorName c , conInfoIsRecord = True- , conInfoFields =+ , conInfoFields = zipWith (FieldInfo . Just) fieldNames (constructorFields c) } _ -> ConInfo- { conInfoName = constructorName c+ { conInfoName = constructorName c , conInfoIsRecord = False- , conInfoFields =+ , 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+ TypeShapeRecord c -> [c]+ TypeShapeEnum cs -> cs+ TypeShapeSum cs -> cs + isRecordShape :: TypeShape -> Bool isRecordShape = \case TypeShapeRecord _ -> True- _ -> False+ _ -> False + isEnumShape :: TypeShape -> Bool isEnumShape = \case TypeShapeEnum _ -> True- _ -> False+ _ -> False + isNewtypeShape :: TypeShape -> Bool isNewtypeShape = \case TypeShapeNewtype _ -> True- _ -> False+ _ -> False
test/Main.hs view
@@ -1,21 +1,24 @@ module Main (main) where -import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Derive.Aeson qualified+import Test.Derive.Extension qualified+import Test.Derive.Fixtures qualified+import Test.Derive.Modifier qualified+import Test.Derive.NameStyle qualified+import Test.Syd -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+main = sydTest 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- ]++tests :: Spec+tests =+ describe "wireform-derive" $+ sequence_+ [ Test.Derive.NameStyle.tests+ , Test.Derive.Modifier.tests+ , Test.Derive.Extension.tests+ , Test.Derive.Fixtures.tests+ , Test.Derive.Aeson.tests+ ]
test/Test/Derive/Aeson.hs view
@@ -2,139 +2,143 @@ 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 Data.Aeson qualified as A+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KM import Test.Derive.Aeson.Instances () import Test.Derive.Aeson.Types+import Test.Syd -tests :: TestTree-tests = testGroup "Aeson deriver"- [ recordTests- , newtypeTests- , enumTests- , sumTests- ] +tests :: Spec+tests =+ describe "Aeson deriver" $+ sequence_+ [ 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"+recordTests :: Spec+recordTests =+ describe "record" $+ sequence_+ [ it "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+ KM.lookup (Key.fromText "street") o `shouldBe` Just (A.String "1 Main")+ KM.lookup (Key.fromText "addr_city") o `shouldBe` Just (A.String "Springfield")+ KM.lookup (Key.fromText "zip") o `shouldBe` Just (A.String "12345")+ (not (KM.member (Key.fromText "addrInternal") o)) `shouldBe` True+ _ -> expectationFailure "expected JSON object"+ , it "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+ addrStreet a' `shouldBe` addrStreet a+ addrCity a' `shouldBe` addrCity a+ addrZip a' `shouldBe` addrZip a+ addrInternal a' `shouldBe` defaultAddrInternal+ A.Error e -> expectationFailure ("decode failed: " ++ e)+ ] - , 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+newtypeTests :: Spec+newtypeTests =+ describe "newtype" $+ sequence_+ [ it "encode passes through" $+ A.toJSON (UserId 42) `shouldBe` A.Number 42+ , it "round-trip" $ do+ case A.fromJSON (A.toJSON (UserId 7)) of+ A.Success (UserId n) -> n `shouldBe` 7+ A.Error e -> expectationFailure e+ ] - , 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)- ]+enumTests :: Spec+enumTests =+ describe "enum" $+ sequence_+ [ it+ "encode literal-renamed constructor"+ (A.toJSON Red `shouldBe` A.String "red")+ , it+ "encode style-renamed constructor (DarkBlue -> dark-blue)"+ (A.toJSON DarkBlue `shouldBe` A.String "dark-blue")+ , it "round-trip Red" $+ A.fromJSON (A.String "red") `shouldBe` A.Success Red+ , it "round-trip Green" $+ A.fromJSON (A.String "green") `shouldBe` A.Success Green+ , it "round-trip DarkBlue" $+ A.fromJSON (A.String "dark-blue") `shouldBe` A.Success DarkBlue+ , it "unknown value fails" $ do+ case A.fromJSON (A.String "purple") :: A.Result Color of+ A.Error _ -> pure ()+ A.Success c -> expectationFailure ("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)- ]+sumTests :: Spec+sumTests =+ describe "sum" $+ sequence_+ [ it "Point -> tag/contents (null payload)" $+ A.toJSON Point+ `shouldBe` A.object+ [ Key.fromText "tag" A..= A.String "point"+ , Key.fromText "contents" A..= A.Null+ ]+ , it "Circle -> tag/contents (single payload)" $+ A.toJSON (Circle 1.5)+ `shouldBe` A.object+ [ Key.fromText "tag" A..= A.String "circle"+ , Key.fromText "contents" A..= A.Number 1.5+ ]+ , it "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+ `shouldBe` Just (A.String "rect")+ KM.lookup (Key.fromText "contents") o+ `shouldBe` Just (A.toJSON ([A.Number 2, A.Number 3] :: [A.Value]))+ _ -> expectationFailure "expected JSON object"+ , it "round-trip Point" $ rt Point+ , it "round-trip Circle" $ rt (Circle 2.5)+ , it "round-trip Rect" $ rt (Rect 4 5)+ , it "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 -> expectationFailure ("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)+ A.Success s' -> s' `shouldBe` s+ A.Error e -> expectationFailure ("round-trip failed: " ++ e)
test/Test/Derive/Aeson/Instances.hs view
@@ -1,14 +1,15 @@-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-} --- | 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).+{- | 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 Test.Derive.Aeson.Types import Wireform.Derive.Aeson -import Test.Derive.Aeson.Types deriveJSON ''Address deriveJSON ''UserId
test/Test/Derive/Aeson/Types.hs view
@@ -1,55 +1,70 @@-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-} -- | 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+module Test.Derive.Aeson.Types (+ -- * Record+ Address (..),+ defaultAddrInternal, -import Data.Text (Text)+ -- * Newtype+ UserId (..), + -- * Enum+ Color (..),++ -- * Sum+ Shape (..),+) where++import Data.Text (Text) import Wireform.Derive.Backend import Wireform.Derive.Modifier import Wireform.Derive.NameStyle + -- | Default value supplied by the deriver for the skipped field. defaultAddrInternal :: Text defaultAddrInternal = "<missing>" + -- --------------------------------------------------------------------------- -- Record (with rename + renameStyle + per-backend overrides) -- --------------------------------------------------------------------------- data Address = Address { addrStreet :: !Text- , addrCity :: !Text- , addrZip :: !Text+ , addrCity :: !Text+ , addrZip :: !Text , addrInternal :: !Text- } deriving (Eq, Show)+ }+ 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 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 }+newtype UserId = UserId {unUserId :: Int} deriving (Eq, Show) + -- --------------------------------------------------------------------------- -- Enum (renamed constructors) -- ---------------------------------------------------------------------------@@ -57,10 +72,16 @@ data Color = Red | Green | DarkBlue deriving (Eq, Show) -{-# ANN Red (rename "red") #-}-{-# ANN Green (rename "green") #-}-{-# ANN DarkBlue (renameStyle KebabCase) #-} +{-# ANN Red (rename "red") #-}+++{-# ANN Green (rename "green") #-}+++{-# ANN DarkBlue (renameStyle KebabCase) #-}++ -- --------------------------------------------------------------------------- -- Sum-of-products -- ---------------------------------------------------------------------------@@ -71,6 +92,11 @@ | Rect !Double !Double deriving (Eq, Show) -{-# ANN Point (rename "point") #-}++{-# ANN Point (rename "point") #-}++ {-# ANN Circle (rename "circle") #-}-{-# ANN Rect (renameStyle SnakeCase) #-}+++{-# ANN Rect (renameStyle SnakeCase) #-}
test/Test/Derive/Extension.hs view
@@ -4,35 +4,34 @@ {-# 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.+{- | 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.Map.Strict qualified as Map import Data.Text (Text)-import qualified Data.Text as T+import Data.Text qualified as T import Data.Typeable (Typeable) import GHC.Generics (Generic)--import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit (testCase, (@?=))-+import Test.Syd import Wireform.Derive.Backend (backendIceberg)-import Wireform.Derive.Extension- ( BackendModifier (..)- , extension- , hasExtension- , lookupExtension- , lookupExtensions- )+import Wireform.Derive.Extension (+ BackendModifier (..),+ extension,+ hasExtension,+ lookupExtension,+ lookupExtensions,+ ) import Wireform.Derive.Modifier (Modifier)-import Wireform.Derive.ModifierInfo- ( ModifierInfo (..)- , emptyModifierInfo- , foldModifiers- )+import Wireform.Derive.ModifierInfo (+ ModifierInfo (..),+ emptyModifierInfo,+ foldModifiers,+ ) + -- --------------------------------------------------------------------------- -- Two pretend backend extension vocabularies -- ---------------------------------------------------------------------------@@ -42,71 +41,75 @@ | 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+tests :: Spec+tests =+ describe "Wireform.Derive.Extension" $+ sequence_+ [ it "round-trip a single typed extension" $ do+ let m = extension PartitionColumn+ let mi = applyMods [m]+ lookupExtension @IcebergFieldOpt mi `shouldBe` Just PartitionColumn+ hasExtension @IcebergFieldOpt mi `shouldBe` True+ , it "round-trip an extension with a Text payload" $ do+ let m = extension (OptimisticTransform (T.pack "year"))+ let mi = applyMods [m]+ lookupExtension @IcebergFieldOpt mi `shouldBe` Just (OptimisticTransform (T.pack "year"))+ , it "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+ `shouldBe` [ PartitionColumn+ , OptimisticTransform (T.pack "month")+ ]+ , it "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 `shouldBe` Just PartitionColumn+ lookupExtensions @XmlFieldOpt mi+ `shouldBe` [AsAttribute, NamespacedTo (T.pack "ns0")]+ , it "absent extension is Nothing" $ do+ let mi = emptyModifierInfo backendIceberg+ lookupExtension @IcebergFieldOpt mi `shouldBe` Nothing+ hasExtension @IcebergFieldOpt mi `shouldBe` False+ , it "miCustom keys match the BackendModifier tag" $ do+ let mi = applyMods [extension PartitionColumn, extension AsAttribute]+ Map.keys (miCustom mi)+ `shouldBe` [ "wireform-iceberg.field-opt"+ , "wireform-xml.field-opt"+ ]+ ] - , 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.+{- | 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
test/Test/Derive/Fixtures.hs view
@@ -2,42 +2,54 @@ module Test.Derive.Fixtures (tests) where -import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit (testCase, (@?=))+import Test.Derive.Fixtures.Reified qualified as R+import Test.Syd -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)+tests :: Spec+tests =+ describe "ANN round-trip" $+ sequence_+ [ describe "wire keys (literal renames)" $+ sequence_+ [ it+ "personName JSON -> \"name\""+ (R.personNameKeyJSON `shouldBe` "name")+ , it+ "personName CBOR -> \"name\""+ (R.personNameKeyCBOR `shouldBe` "name")+ ]+ , describe "wire keys (renameStyle)" $+ sequence_+ [ it+ "personAge JSON -> \"person_age\" (literal from SnakeCase)"+ (R.personAgeKeyJSON `shouldBe` "person_age")+ , it+ "personAge Proto -> \"person_age\" (same; backend rename only on JSON-style)"+ (R.personAgeKeyProto `shouldBe` "person_age")+ ]+ , describe "wire keys (renameWith — runtime call)" $+ sequence_+ [ it+ "personSSN JSON -> \"_personssn\" (lowercase + underscore prefix)"+ (R.personSSNKeyJSON `shouldBe` "_personssn")+ , it+ "personSSN CBOR -> \"_personssn\""+ (R.personSSNKeyCBOR `shouldBe` "_personssn")+ ]+ , describe "per-backend overrides" $+ sequence_+ [ it+ "personSSN skipped in JSON (via disableFor)"+ (R.personSSNSkipJSON `shouldBe` True)+ , it+ "personSSN NOT skipped in CBOR"+ (R.personSSNSkipCBOR `shouldBe` False)+ , it+ "personAge tag visible only under proto"+ (R.personAgeTagProto `shouldBe` Just 7)+ , it+ "personAge has no tag under JSON"+ (R.personAgeTagJSON `shouldBe` Nothing)+ ] ]- ]
test/Test/Derive/Fixtures/Reified.hs view
@@ -1,93 +1,122 @@-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-} --- | 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+{- | Splices that exercise the public deriver API against the+annotated types in "Test.Derive.Fixtures.Types". - -- * Resolved flags- , personSSNSkipJSON- , personSSNSkipCBOR- , personAgeTagProto- , personAgeTagJSON- ) where+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 Test.Derive.Fixtures.Types qualified as F 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")+personNameKeyJSON =+ $( do+ mi <- reifyModifierInfoFor backendJSON 'F.personName+ renderWireKey mi "personName"+ ) + personNameKeyCBOR :: Text-personNameKeyCBOR = $(do- mi <- reifyModifierInfoFor backendCBOR 'F.personName- renderWireKey mi "personName")+personNameKeyCBOR =+ $( do+ mi <- reifyModifierInfoFor backendCBOR 'F.personName+ renderWireKey mi "personName"+ ) + personAgeKeyJSON :: Text-personAgeKeyJSON = $(do- mi <- reifyModifierInfoFor backendJSON 'F.personAge- renderWireKey mi "personAge")+personAgeKeyJSON =+ $( do+ mi <- reifyModifierInfoFor backendJSON 'F.personAge+ renderWireKey mi "personAge"+ ) + personAgeKeyProto :: Text-personAgeKeyProto = $(do- mi <- reifyModifierInfoFor backendProto 'F.personAge- renderWireKey mi "personAge")+personAgeKeyProto =+ $( do+ mi <- reifyModifierInfoFor backendProto 'F.personAge+ renderWireKey mi "personAge"+ ) + personSSNKeyJSON :: Text-personSSNKeyJSON = $(do- mi <- reifyModifierInfoFor backendJSON 'F.personSSN- renderWireKey mi "personSSN")+personSSNKeyJSON =+ $( do+ mi <- reifyModifierInfoFor backendJSON 'F.personSSN+ renderWireKey mi "personSSN"+ ) + personSSNKeyCBOR :: Text-personSSNKeyCBOR = $(do- mi <- reifyModifierInfoFor backendCBOR 'F.personSSN- renderWireKey mi "personSSN")+personSSNKeyCBOR =+ $( do+ mi <- reifyModifierInfoFor backendCBOR 'F.personSSN+ renderWireKey mi "personSSN"+ ) + -- --------------------------------------------------------------------------- -- Flags -- --------------------------------------------------------------------------- personSSNSkipJSON :: Bool-personSSNSkipJSON = $(do- mi <- reifyModifierInfoFor backendJSON 'F.personSSN- lift (miSkip mi))+personSSNSkipJSON =+ $( do+ mi <- reifyModifierInfoFor backendJSON 'F.personSSN+ lift (miSkip mi)+ ) + personSSNSkipCBOR :: Bool-personSSNSkipCBOR = $(do- mi <- reifyModifierInfoFor backendCBOR 'F.personSSN- lift (miSkip mi))+personSSNSkipCBOR =+ $( do+ mi <- reifyModifierInfoFor backendCBOR 'F.personSSN+ lift (miSkip mi)+ ) + personAgeTagProto :: Maybe Int-personAgeTagProto = $(do- mi <- reifyModifierInfoFor backendProto 'F.personAge- lift (miTag mi))+personAgeTagProto =+ $( do+ mi <- reifyModifierInfoFor backendProto 'F.personAge+ lift (miTag mi)+ ) + personAgeTagJSON :: Maybe Int-personAgeTagJSON = $(do- mi <- reifyModifierInfoFor backendJSON 'F.personAge- lift (miTag mi))+personAgeTagJSON =+ $( do+ mi <- reifyModifierInfoFor backendJSON 'F.personAge+ lift (miTag mi)+ )
test/Test/Derive/Fixtures/Types.hs view
@@ -1,47 +1,59 @@-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-} {-# 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+{- | Annotated data types used to verify that 'ANN' pragmas survive+the TH reflection round-trip. -import Data.Text (Text)-import qualified Data.Text as T+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 Data.Text qualified 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)+ , 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 personAge (renameStyle SnakeCase) #-}+++{-# ANN personSSN (renameWith 'personNameRenamer) #-}+++{- | Per-backend overrides: in JSON, 'personSSN' should be skipped;+in CBOR it should still be encoded.+-} {-# ANN personSSN (disableFor [backendJSON]) #-}+ -- | Demonstrate that several modifiers compose on a single name. {-# ANN personAge (forBackend backendProto (tag 7)) #-}
test/Test/Derive/Modifier.hs view
@@ -2,169 +2,193 @@ 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 Data.Map.Strict qualified as Map+import Test.Syd 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)+tests :: Spec+tests =+ describe "Modifier" $+ sequence_+ [ describe "foldModifiers — happy path" $+ sequence_+ [ it "empty input gives empty info" $+ foldModifiers backendJSON [] `shouldBe` Right (emptyModifierInfo backendJSON)+ , it "single rename" $+ fmap miRename (foldModifiers backendJSON [rename "name"])+ `shouldBe` Right (Just (RenameSpecLiteral "name"))+ , it "duplicate identical rename is no conflict" $+ fmap+ miRename+ ( foldModifiers+ backendJSON+ [rename "name", rename "name"]+ )+ `shouldBe` Right (Just (RenameSpecLiteral "name"))+ , it "skip flag" $+ fmap miSkip (foldModifiers backendJSON [skip])+ `shouldBe` Right True+ , it "tag set" $+ fmap miTag (foldModifiers backendJSON [tag 7])+ `shouldBe` Right (Just 7)+ , it "required + only set once" $+ fmap miRequired (foldModifiers backendJSON [required])+ `shouldBe` Right (Just True)+ , it "optional + only set once" $+ fmap miRequired (foldModifiers backendJSON [optional])+ `shouldBe` Right (Just False)+ ]+ , describe "foldModifiers — conflicts" $+ sequence_+ [ it "two distinct renames conflict" $ do+ let r =+ foldModifiers+ backendJSON+ [rename "a", rename "b"]+ case r of+ Left ConflictRename {} -> pure ()+ other -> expectationFailure ("expected ConflictRename, got " ++ show other)+ , it "two distinct tags conflict" $ do+ let r = foldModifiers backendJSON [tag 1, tag 2]+ case r of+ Left ConflictTag {} -> pure ()+ other -> expectationFailure ("expected ConflictTag, got " ++ show other)+ , it "required + optional conflict" $ do+ let r = foldModifiers backendJSON [required, optional]+ case r of+ Left ConflictRequired {} -> pure ()+ other -> expectationFailure ("expected ConflictRequired, got " ++ show other)+ , it "flatten + skip conflict" $ do+ let r = foldModifiers backendJSON [flatten, skip]+ case r of+ Left ConflictFlattenSkip -> pure ()+ other -> expectationFailure ("expected ConflictFlattenSkip, got " ++ show other)+ ]+ , describe "per-backend overrides" $+ sequence_+ [ it "backend-only modifier applies for active backend" $+ fmap+ miRename+ ( foldModifiers+ backendProto+ [forBackend backendProto (rename "n")]+ )+ `shouldBe` Right (Just (RenameSpecLiteral "n"))+ , it "backend-only modifier ignored for other backend" $+ fmap+ miRename+ ( foldModifiers+ backendJSON+ [forBackend backendProto (rename "n")]+ )+ `shouldBe` Right Nothing+ , it "per-backend rename shadows global, no conflict" $+ fmap+ miRename+ ( foldModifiers+ backendProto+ [ rename "global"+ , forBackend backendProto (rename "scoped")+ ]+ )+ `shouldBe` Right (Just (RenameSpecLiteral "scoped"))+ , it "per-backend rename does not shadow on other backend" $+ fmap+ miRename+ ( foldModifiers+ backendJSON+ [ rename "global"+ , forBackend backendProto (rename "scoped")+ ]+ )+ `shouldBe` Right (Just (RenameSpecLiteral "global"))+ , it "disableFor on active backend marks skip" $+ fmap+ miSkip+ ( foldModifiers+ backendCBOR+ [disableFor [backendCBOR, backendMsgPack]]+ )+ `shouldBe` Right True+ , it "disableFor on other backend has no effect" $+ fmap+ miSkip+ ( foldModifiers+ backendJSON+ [disableFor [backendCBOR, backendMsgPack]]+ )+ `shouldBe` Right False+ , it "forBackends groups multiple modifiers" $ do+ let mi =+ foldModifiers+ backendProto+ [forBackends [backendProto] [rename "p", tag 9]]+ fmap miRename mi `shouldBe` Right (Just (RenameSpecLiteral "p"))+ fmap miTag mi `shouldBe` Right (Just 9)+ , it "forBackends does nothing for unlisted backend" $+ fmap+ miRename+ ( foldModifiers+ backendJSON+ [forBackends [backendProto] [rename "p"]]+ )+ `shouldBe` Right Nothing+ ]+ , describe "RenameSpec variants" $+ sequence_+ [ it "rename literal" $+ fmap miRename (foldModifiers backendJSON [rename "n"])+ `shouldBe` Right (Just (RenameSpecLiteral "n"))+ , it "renameStyle preserved" $+ fmap+ miRename+ ( foldModifiers+ backendJSON+ [renameStyle (StripPrefix "person")]+ )+ `shouldBe` Right (Just (RenameSpecStyle (StripPrefix "person")))+ ]+ , describe "default rename keys" $+ sequence_+ [ it+ "JSON default is camel"+ (defaultRenameForBackend backendJSON "person_name" `shouldBe` "personName")+ , it+ "EDN default is kebab"+ (defaultRenameForBackend backendEDN "personName" `shouldBe` "person-name")+ , it+ "CBOR default is verbatim"+ (defaultRenameForBackend backendCBOR "personName" `shouldBe` "personName")+ ]+ , describe "ModCustom accumulation" $+ sequence_+ [ it "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)+ length xs `shouldBe` 2+ Left e -> expectationFailure ("unexpected " ++ show e)+ , it "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+ (Map.member "ext.foo" (miCustom info)) `shouldBe` True+ (Map.member "ext.bar" (miCustom info)) `shouldBe` True+ Left e -> expectationFailure ("unexpected " ++ show e)+ ] ]- ]
test/Test/Derive/NameStyle.hs view
@@ -2,142 +2,185 @@ module Test.Derive.NameStyle (tests) where -import qualified Data.Char as Char-import qualified Data.Text as T+import Data.Char qualified as Char+import Data.Text qualified 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 Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range+import Test.Syd+import Test.Syd.Hedgehog () 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")+tests :: Spec+tests =+ describe "NameStyle" $+ sequence_+ [ describe "applyStyle / golden" $+ sequence_+ [ it+ "snake personName"+ (applyStyle SnakeCase "personName" `shouldBe` "person_name")+ , it+ "snake HTTPRequest"+ (applyStyle SnakeCase "HTTPRequest" `shouldBe` "http_request")+ , it+ "snake httpRequest"+ (applyStyle SnakeCase "httpRequest" `shouldBe` "http_request")+ , it+ "snake-of-snake personName"+ (applyStyle SnakeCase "person_name" `shouldBe` "person_name")+ , it+ "kebab personName"+ (applyStyle KebabCase "personName" `shouldBe` "person-name")+ , it+ "kebab HTTPRequest"+ (applyStyle KebabCase "HTTPRequest" `shouldBe` "http-request")+ , it+ "camel of snake"+ (applyStyle CamelCase "person_name" `shouldBe` "personName")+ , it+ "camel idempotent"+ (applyStyle CamelCase "personName" `shouldBe` "personName")+ , it+ "pascal of snake"+ (applyStyle PascalCase "person_name" `shouldBe` "PersonName")+ , it+ "pascal idempotent"+ (applyStyle PascalCase "PersonName" `shouldBe` "PersonName")+ , it+ "upper snake"+ (applyStyle UpperSnake "personName" `shouldBe` "PERSON_NAME")+ , it+ "upper kebab"+ (applyStyle UpperKebab "personName" `shouldBe` "PERSON-NAME")+ , it+ "strip prefix present"+ (applyStyle (StripPrefix "person") "personName" `shouldBe` "Name")+ , it+ "strip prefix absent"+ (applyStyle (StripPrefix "other") "personName" `shouldBe` "personName")+ , it+ "strip prefix CI"+ (applyStyle (StripPrefixCI "PERSON") "personName" `shouldBe` "Name")+ , it+ "strip suffix present"+ (applyStyle (StripSuffix "Name") "personName" `shouldBe` "person")+ , it+ "compose strip + snake"+ ( applyStyle+ (StripPrefix "person" `andThen` SnakeCase)+ "personHttpRequest"+ `shouldBe` "http_request"+ )+ , it+ "replace"+ (applyStyle (Replace "Name" "Label") "personName" `shouldBe` "personLabel")+ , it+ "drop / take"+ (applyStyle (DropChars 6 `andThen` TakeChars 2) "personName" `shouldBe` "Na")+ , it+ "Idiomatic falls through to NoStyle without resolution"+ (applyStyle Idiomatic "personName" `shouldBe` "personName")+ ]+ , describe "Idiomatic resolution" $+ sequence_+ [ it+ "JSON resolves to CamelCase"+ ( applyStyle (resolveIdiomatic "json" Idiomatic) "person_name"+ `shouldBe` "personName"+ )+ , it+ "EDN resolves to KebabCase"+ ( applyStyle (resolveIdiomatic "edn" Idiomatic) "personName"+ `shouldBe` "person-name"+ )+ , it+ "Proto resolves to CamelCase"+ ( applyStyle (resolveIdiomatic "proto" Idiomatic) "person_name"+ `shouldBe` "personName"+ )+ , it+ "TOML resolves to SnakeCase"+ ( applyStyle (resolveIdiomatic "toml" Idiomatic) "personName"+ `shouldBe` "person_name"+ )+ , it+ "YAML resolves to KebabCase"+ ( applyStyle (resolveIdiomatic "yaml" Idiomatic) "personName"+ `shouldBe` "person-name"+ )+ , it+ "XML resolves to PascalCase"+ ( applyStyle (resolveIdiomatic "xml" Idiomatic) "person_name"+ `shouldBe` "PersonName"+ )+ , it+ "CBOR resolves to NoStyle (verbatim)"+ ( applyStyle (resolveIdiomatic "cbor" Idiomatic) "personName"+ `shouldBe` "personName"+ )+ , it+ "compose preserves outer style"+ ( applyStyle+ ( resolveIdiomatic+ "edn"+ (StripPrefix "person" `andThen` Idiomatic)+ )+ "personHttpRequest"+ `shouldBe` "http-request"+ )+ ]+ , describe "properties" $+ sequence_+ [ it "NoStyle is identity" $ property $ do+ t <- forAll genIdent+ applyStyle NoStyle t === t+ , it "Compose NoStyle a == a" $ property $ do+ t <- forAll genIdent+ applyStyle (Compose NoStyle SnakeCase) t === applyStyle SnakeCase t+ , it "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+ , it "snake produces lowercase output" $ property $ do+ t <- forAll genIdent+ let s = applyStyle SnakeCase t+ assert (T.all (\c -> not (Char.isUpper c)) s)+ , it "kebab produces lowercase output" $ property $ do+ t <- forAll genIdent+ let s = applyStyle KebabCase t+ assert (T.all (\c -> not (Char.isUpper c)) s)+ , it "applyStyle is total (never bottom)" $ property $ do+ t <- forAll genIdent+ let len = T.length (applyStyle SnakeCase t)+ assert (len >= 0)+ ] ] - , 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)- ])+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+ rest <- Gen.list (Range.linear 0 12) Gen.alphaNum pure (T.pack (first : rest))
wireform-derive.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: wireform-derive-version: 0.1.0.0+version: 0.2.0.0 synopsis: Annotation-driven Template Haskell deriver core for wireform description: Shared @Modifier@ annotation vocabulary and Template Haskell@@ -88,7 +88,7 @@ bytestring >= 0.11 && < 0.13, containers >= 0.6 && < 0.9, text >= 2.0 && < 2.2,- template-haskell >= 2.18 && < 2.24,+ template-haskell >= 2.18 && < 2.25, th-abstraction >= 0.5 && < 0.8, mtl >= 2.2 && < 2.4, transformers >= 0.5 && < 0.7,@@ -120,6 +120,5 @@ 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+ sydtest,+ sydtest-hedgehog