api-tools 0.10.0.1 → 0.10.1.0

raw patch · 6 files changed

+62/−19 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• api-tools.cabal +2/−2
• changelog +4/−0
• src/Data/API/Tools/CBOR.hs +40/−12
• src/Data/API/Tools/Datatypes.hs +7/−2
• src/Data/API/Tools/Traversal.hs +8/−2
• src/Data/Binary/Serialise/CBOR/Extra.hs +1/−1

@@ -1,5 +1,5 @@ Name:                api-tools-Version:             0.10.0.1+Version:             0.10.1.0 Synopsis:            DSL for generating API boilerplate and docs Description:         api-tools provides a compact DSL for describing an API.                      It uses Template Haskell to generate the@@ -26,7 +26,7 @@ Source-Repository this   Type:              git   Location:          git://github.com/iconnect/api-tools.git-  Tag:               0.10.0.1+  Tag:               0.10.1.0  Library   Hs-Source-Dirs:    src

@@ -1,5 +1,9 @@ -*-change-log-*- +0.10.1.0 Adam Gundry <adam@well-typed.com> March 2023+	* Fix a space leak in CBOR encoding+	* Add traversalsTool to Data.API.Tools.Traversal+ 0.10.0.1 Adam Gundry <adam@well-typed.com> March 2023 	* Performance fix in CBOR encoding 

@@ -71,13 +71,13 @@  {- instance Serialise JobSpecId where-     encode = \ x ->-        encodeMapLen 4 >>+     encode = \ (JobSpecId _jsi_id _jsi_input _jsi_output _jsi_pipelineId) ->+        encodeMapLen 4 <>         encodeRecordFields-            [ encodeString "Id"         <> encode (jsiId         x)-            , encodeString "Input"      <> encode (jsiInput      x)-            , encodeString "Output"     <> encode (jsiOutput     x)-            , encodeString "PipelineId" <> encode (jsiPipelineId x)+            [ encodeString "Id"         <> encode _jsi_id+            , encodeString "Input"      <> encode _jsi_input+            , encodeString "Output"     <> encode _jsi_output+            , encodeString "PipelineId" <> encode _jsi_pipelineId             ]      decode (Record v) =         decodeMapLen >>@@ -88,16 +88,44 @@  Note that fields are stored alphabetically ordered by field name, so that we are insensitive to changes in field order in the schema.+++Previously we generated code like this:++     encode = \ x ->+         encodeMapLen 4 <>+         encodeRecordFields+            [ encodeString "Id"         <> encode (_jsi_id         x)+            , encodeString "Input"      <> encode (_jsi_input      x)+            , encodeString "Output"     <> encode (_jsi_output     x)+            , encodeString "PipelineId" <> encode (_jsi_pipelineId x)+            ]++This binds the record to the variable `x` and uses the record selectors to+project out the components. As a consequence, we can end up retaining the entire+record until the very end of encoding it. This is a problem if the record is+constructed lazily and each component would otherwise have been freed once it+was encoded, because we end up realising the whole thing in memory rather than+being incremental.++The fix is to pattern-match once on the value to be serialised and bind its+components separately. Now the record constructor is garbage once we evaluate+the outer pattern-match, and we can free individual fields once they are+encoded.++One might hope that the selector thunk optimisation would squash this+automatically, but that is somewhat fragile and may not apply at all to large+records (see https://gitlab.haskell.org/ghc/ghc/-/issues/20139).+ -}  gen_sr_to :: Tool (APINode, SpecRecord)-gen_sr_to = mkTool $ \ ts (an, sr) -> do-    x <- newName "x"-    optionalInstanceD ts ''Serialise [nodeRepT an] [ simpleD 'encode (bdy_in an sr x)+gen_sr_to = mkTool $ \ ts (an, sr) ->+    optionalInstanceD ts ''Serialise [nodeRepT an] [ simpleD 'encode (bdy_in an sr)                                                    , simpleD 'decode (cl an sr)                                                    ]   where-    bdy_in an sr x =+    bdy_in an sr =         let fields = sortFields sr             len = fromIntegral (length fields)  -- to Integer             lenE = varE 'fromIntegral  -- to Word@@ -111,9 +139,9 @@             encFields =                 varE 'encodeRecordFields `appE`                     listE [ [e| encodeString $(fieldNameE fn)-                                <> encode ($(nodeFieldE an fn) $(varE x)) |]+                                <> encode $(nodeFieldE an fn) |]                             | (fn, _fty) <- fields ]-        in lamE [varP x] $+        in lamE [nodeConP an [nodeFieldP an fn | (fn, _) <- srFields sr ]] $                varE '(<>)                  `appE` writeRecordHeader                  `appE` encFields

@@ -8,6 +8,7 @@     , nodeT     , nodeRepT     , nodeConE+    , nodeConP     , nodeNewtypeConE     , nodeFieldE     , nodeFieldP@@ -239,10 +240,14 @@ nodeRepT :: APINode -> TypeQ nodeRepT = conT . rep_type_nm --- | The constructor for a record API node+-- | The constructor for a record API node, as an expression nodeConE :: APINode -> ExpQ nodeConE = conE . rep_type_nm +-- | The constructor for a record API node, as a pattern+nodeConP :: APINode -> [PatQ] -> PatQ+nodeConP an = conP (rep_type_nm an)+ -- | The constructor for a newtype, which might be renamed nodeNewtypeConE :: ToolSettings -> APINode -> SpecNewtype -> ExpQ nodeNewtypeConE ts an sn = conE $ newtype_con_nm (newtypeSmartConstructors ts && isJust (snFilter sn)) an@@ -263,6 +268,6 @@ nodeAltConP :: APINode -> FieldName -> [PatQ] -> PatQ nodeAltConP an fn = conP (pref_con_nm an fn) --- | The projection function from a newtype API node, as an epxression+-- | The projection function from a newtype API node, as an expression newtypeProjectionE :: APINode -> ExpQ newtypeProjectionE = varE . newtype_prj_nm

@@ -4,6 +4,7 @@  module Data.API.Tools.Traversal     ( traversalTool+    , traversalsTool     ) where  import           Data.API.NormalForm@@ -37,7 +38,12 @@ -- defined manually in the same module as the call to 'traversalTool', -- otherwise the generated code will lead to scope errors. traversalTool :: TypeName -> TypeName -> APITool-traversalTool root x = readTool (apiNodeTool . s)+traversalTool root = traversalsTool [root]++-- | Like 'traversalTool', but it allows passing a list of \"roots\", to avoid conflicting+-- declarations.+traversalsTool :: [TypeName] -> TypeName -> APITool+traversalsTool root x = readTool (apiNodeTool . s)   where     s api = apiSpecTool mempty (simpleTool (uncurry $ traversalRecord napi targets x))                                (simpleTool (uncurry $ traversalUnion  napi targets x)) mempty mempty@@ -49,7 +55,7 @@         -- traversed type         targets = (transitiveDeps        napi rootSet `Set.union` rootSet) `Set.intersection`                   (transitiveReverseDeps napi xSet    `Set.union` xSet)-        rootSet = Set.singleton root+        rootSet = Set.fromList root         xSet    = Set.singleton x  

@@ -13,7 +13,6 @@  import           Codec.Serialise.Decoding import           Codec.Serialise.Encoding-import           Data.List (foldl1') import qualified Data.Text                      as T  #if MIN_VERSION_base(4,8,0)@@ -41,6 +40,7 @@ -- We can assume the record has at least 1 field. encodeRecordFields :: [Encoding] -> Encoding encodeRecordFields = mconcat+{-# INLINE encodeRecordFields #-}  -- | Encode an element of a union as single-element map from a field -- name to a value.