polytropos-dhall (empty) → 0.1.0.2
raw patch · 6 files changed
+1348/−0 lines, 6 filesdep +basedep +bytestringdep +dhall
Dependencies added: base, bytestring, dhall, either, polytropos-core, polytropos-dhall, polytropos-plugin, primitive, tasty, tasty-hunit, text
Files
- CHANGELOG.md +14/−0
- LICENSE +391/−0
- README.md +49/−0
- polytropos-dhall.cabal +69/−0
- src/Polytropos/Dhall.hs +599/−0
- test/Main.hs +226/−0
+ CHANGELOG.md view
@@ -0,0 +1,14 @@+# Changelog for polytropos-dhall++## 0.1.0.2 — 2026-10-21++- Coordinated version bump across all Polytropos packages.++## 0.1.0.1 — Initial Release++- High-performance Dhall `ToDhall` and `FromDhall` codecs for open records and variants+- Direct linear unrolling of flat contiguous `SmallArray` memory into Dhall AST expressions+- Tagged variant serialization into native Dhall union expressions+- Higher-kinded record support (`RecordF f r`) with automatic fallback for optional fields+- Turnkey generic adapters (`GenericDhall`, `GenericFromDhall`, `GenericToDhall`) for `DerivingVia`+- Homogeneous reflection and introspection helpers
+ LICENSE view
@@ -0,0 +1,391 @@+Polytropos Dual Licensing++Copyright (c) 2026, Nadia Yvette Chambers <nadia.yvette.chambers@ik.me>+All rights reserved.++SPDX-License-Identifier: EUPL-1.2 OR Apache-2.0++Polytropos is dual-licensed: you may use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the software under the terms+of EITHER:++1. The European Union Public Licence, version 1.2 (EUPL-1.2), as published by+ the European Commission (available in 23 authentic language versions); OR+2. The Apache License, Version 2.0 (Apache-2.0).++You may choose whichever license best fits your requirements and compliance+environment.++Individual license files are available in the LICENSES/ directory:+- LICENSES/EUPL-1.2.txt+- LICENSES/Apache-2.0.txt++================================================================================+1. European Union Public Licence v. 1.2 (EUPL-1.2)+================================================================================++ EUROPEAN UNION PUBLIC LICENCE v. 1.2+ EUPL © the European Union 2007, 2016++This European Union Public Licence (the ‘EUPL’) applies to the Work (as defined+below) which is provided under the terms of this Licence. Any use of the Work,+other than as authorised under this Licence is prohibited (to the extent such+use is covered by a right of the copyright holder of the Work).++The Work is provided under the terms of this Licence when the Licensor (as+defined below) has placed the following notice immediately following the+copyright notice for the Work:++ Licensed under the EUPL++or has expressed by any other means his willingness to license under the EUPL.++1. Definitions++In this Licence, the following terms have the following meaning:++- ‘The Licence’: this Licence.++- ‘The Original Work’: the work or software distributed or communicated by the+ Licensor under this Licence, available as Source Code and also as Executable+ Code as the case may be.++- ‘Derivative Works’: the works or software that could be created by the+ Licensee, based upon the Original Work or modifications thereof. This Licence+ does not define the extent of modification or dependence on the Original Work+ required in order to classify a work as a Derivative Work; this extent is+ determined by copyright law applicable in the country mentioned in Article 15.++- ‘The Work’: the Original Work or its Derivative Works.++- ‘The Source Code’: the human-readable form of the Work which is the most+ convenient for people to study and modify.++- ‘The Executable Code’: any code which has generally been compiled and which is+ meant to be interpreted by a computer as a program.++- ‘The Licensor’: the natural or legal person that distributes or communicates+ the Work under the Licence.++- ‘Contributor(s)’: any natural or legal person who modifies the Work under the+ Licence, or otherwise contributes to the creation of a Derivative Work.++- ‘The Licensee’ or ‘You’: any natural or legal person who makes any usage of+ the Work under the terms of the Licence.++- ‘Distribution’ or ‘Communication’: any act of selling, giving, lending,+ renting, distributing, communicating, transmitting, or otherwise making+ available, online or offline, copies of the Work or providing access to its+ essential functionalities at the disposal of any other natural or legal+ person.++2. Scope of the rights granted by the Licence++The Licensor hereby grants You a worldwide, royalty-free, non-exclusive,+sublicensable licence to do the following, for the duration of copyright vested+in the Original Work:++- use the Work in any circumstance and for all usage,+- reproduce the Work,+- modify the Work, and make Derivative Works based upon the Work,+- communicate to the public, including the right to make available or display+ the Work or copies thereof to the public and perform publicly, as the case may+ be, the Work,+- distribute the Work or copies thereof,+- lend and rent the Work or copies thereof,+- sublicense rights in the Work or copies thereof.++Those rights can be exercised on any media, supports and formats, whether now+known or later invented, as far as the applicable law permits so.++In the countries where moral rights apply, the Licensor waives his right to+exercise his moral right to the extent allowed by law in order to make effective+the licence of the economic rights here above listed.++The Licensor grants to the Licensee royalty-free, non-exclusive usage rights to+any patents held by the Licensor, to the extent necessary to make use of the+rights granted on the Work under this Licence.++3. Communication of the Source Code++The Licensor may provide the Work either in its Source Code form, or as+Executable Code. If the Work is provided as Executable Code, the Licensor+provides in addition a machine-readable copy of the Source Code of the Work+along with each copy of the Work that the Licensor distributes or indicates, in+a notice following the copyright notice attached to the Work, a repository where+the Source Code is easily and freely accessible for as long as the Licensor+continues to distribute or communicate the Work.++4. Limitations on copyright++Nothing in this Licence is intended to deprive the Licensee of the benefits from+any exception or limitation to the exclusive rights of the rights owners in the+Work, of the exhaustion of those rights or of other applicable limitations+thereto.++5. Obligations of the Licensee++The grant of the rights mentioned above is subject to some restrictions and+obligations imposed on the Licensee. Those obligations are the following:++Attribution right: The Licensee shall keep intact all copyright, patent or+trademarks notices and all notices that refer to the Licence and to the+disclaimer of warranties. The Licensee must include a copy of such notices and a+copy of the Licence with every copy of the Work he/she distributes or+communicates. The Licensee must cause any Derivative Work to carry prominent+notices stating that the Work has been modified and the date of modification.++Copyleft clause: If the Licensee distributes or communicates copies of the+Original Works or Derivative Works, this Distribution or Communication will be+done under the terms of this Licence or of a later version of this Licence+unless the Original Work is expressly distributed only under this version of the+Licence — for example by communicating ‘EUPL v. 1.2 only’. The Licensee+(becoming Licensor) cannot offer or impose any additional terms or conditions on+the Work or Derivative Work that alter or restrict the terms of the Licence.++Compatibility clause: If the Licensee Distributes or Communicates Derivative+Works or copies thereof based upon both the Work and another work licensed under+a Compatible Licence, this Distribution or Communication can be done under the+terms of this Compatible Licence. For the sake of this clause, ‘Compatible+Licence’ refers to the licences listed in the appendix attached to this Licence.+Should the Licensee's obligations under the Compatible Licence conflict with+his/her obligations under this Licence, the obligations of the Compatible+Licence shall prevail.++Provision of Source Code: When distributing or communicating copies of the Work,+the Licensee will provide a machine-readable copy of the Source Code or indicate+a repository where this Source will be easily and freely available for as long+as the Licensee continues to distribute or communicate the Work.++Legal Protection: This Licence does not grant permission to use the trade names,+trademarks, service marks, or names of the Licensor, except as required for+reasonable and customary use in describing the origin of the Work and+reproducing the content of the copyright notice.++6. Chain of Authorship++The original Licensor warrants that the copyright in the Original Work granted+hereunder is owned by him/her or licensed to him/her and that he/she has the+power and authority to grant the Licence.++Each Contributor warrants that the copyright in the modifications he/she brings+to the Work are owned by him/her or licensed to him/her and that he/she has the+power and authority to grant the Licence.++Each time You accept the Licence, the original Licensor and subsequent+Contributors grant You a licence to their contributions to the Work, under the+terms of this Licence.++7. Disclaimer of Warranty++The Work is a work in progress, which is continuously improved by numerous+Contributors. It is not a finished work and may therefore contain defects or+‘bugs’ inherent to this type of development.++For the above reason, the Work is provided under the Licence on an ‘as is’ basis+and without warranties of any kind concerning the Work, including without+limitation merchantability, fitness for a particular purpose, absence of defects+or errors, accuracy, non-infringement of intellectual property rights other than+copyright as stated in Article 6 of this Licence.++This disclaimer of warranty is an essential part of the Licence and a condition+for the grant of any rights to the Work.++8. Disclaimer of Liability++Except in the cases of wilful misconduct or damages directly caused to natural+persons, the Licensor will in no event be liable for any direct or indirect,+material or moral, damages of any kind, arising out of the Licence or of the use+of the Work, including without limitation, damages for loss of goodwill, work+stoppage, computer failure or malfunction, loss of data or any commercial+damage, even if the Licensor has been advised of the possibility of such damage.+However, the Licensor will be liable under statutory product liability laws as+far such laws apply to the Work.++9. Additional agreements++While distributing the Work, You may choose to conclude an additional agreement,+defining obligations or services consistent with this Licence. However, if+accepting obligations, You may act only on your own behalf and on your sole+responsibility, not on behalf of the original Licensor or any other Contributor,+and only if You agree to indemnify, defend, and hold each Contributor harmless+for any liability incurred by, or claims asserted against such Contributor by+the fact You have accepted any warranty or additional liability.++10. Acceptance of the Licence++The provisions of this Licence can be accepted by clicking on an icon ‘I agree’+placed under the bottom of a window displaying the text of this Licence or by+affirming consent in any other similar way, in accordance with the rules of+applicable law. Clicking on that icon indicates your clear and irrevocable+acceptance of this Licence and all of its terms and conditions.++Similarly, you irrevocably accept this Licence and all of its terms and+conditions by exercising any rights granted to You by Article 2 of this Licence,+such as the use of the Work, the creation by You of a Derivative Work or the+Distribution or Communication by You of the Work or copies thereof.++11. Information to the public++In case of any Distribution or Communication of the Work by means of electronic+communication by You (for example, by offering to download the Work from a+remote location) the distribution channel or media (for example, a website) must+at least provide to the public the information requested by the applicable law+regarding the Licensor, the Licence and the way it may be accessible, concluded,+stored and reproduced by the Licensee.++12. Termination of the Licence++The Licence and the rights granted hereunder will terminate automatically upon+any breach by the Licensee of the terms of the Licence.++Such a termination will not terminate the licences of any person who has+received the Work from the Licensee under the Licence, provided such persons+remain in full compliance with the Licence.++13. Miscellaneous++Without prejudice of Article 9 above, the Licence represents the complete+agreement between the Parties as to the Work.++If any provision of the Licence is invalid or unenforceable under applicable+law, this will not affect the validity or enforceability of the Licence as a+whole. Such provision will be construed or reformed so as necessary to make it+valid and enforceable.++The European Commission may publish other linguistic versions or new versions of+this Licence or updated versions of the Appendix, so far this is required and+reasonable, without reducing the scope of the rights granted by the Licence. New+versions of the Licence will be published with a unique version number.++All linguistic versions of this Licence, approved by the European Commission,+have identical value. Parties can take advantage of the linguistic version of+their choice.++14. Jurisdiction++Without prejudice to specific agreement between parties,++- any litigation resulting from the interpretation of this License, arising+ between the European Union institutions, bodies, offices or agencies, as a+ Licensor, and any Licensee, will be subject to the jurisdiction of the Court+ of Justice of the European Union, as laid down in article 272 of the Treaty on+ the Functioning of the European Union,++- any litigation arising between other parties and resulting from the+ interpretation of this License, will be subject to the exclusive jurisdiction+ of the competent court where the Licensor resides or conducts its primary+ business.++15. Applicable Law++Without prejudice to specific agreement between parties,++- this Licence shall be governed by the law of the European Union Member State+ where the Licensor has his seat, resides or has his registered office,++- this licence shall be governed by Belgian law if the Licensor has no seat,+ residence or registered office inside a European Union Member State.++Appendix++‘Compatible Licences’ according to Article 5 EUPL are:++- GNU General Public License (GPL) v. 2, v. 3+- GNU Affero General Public License (AGPL) v. 3+- Open Software License (OSL) v. 2.1, v. 3.0+- Eclipse Public License (EPL) v. 1.0+- CeCILL v. 2.0, v. 2.1+- Mozilla Public Licence (MPL) v. 2+- GNU Lesser General Public Licence (LGPL) v. 2.1, v. 3+- Creative Commons Attribution-ShareAlike v. 3.0 Unported (CC BY-SA 3.0) for+ works other than software+- European Union Public Licence (EUPL) v. 1.1, v. 1.2+- Québec Free and Open-Source Licence — Reciprocity (LiLiQ-R) or Strong+ Reciprocity (LiLiQ-R+).++The European Commission may update this Appendix to later versions of the above+licences without producing a new version of the EUPL, as long as they provide+the rights granted in Article 2 of this Licence and protect the covered Source+Code from exclusive appropriation.++All other changes or additions to this Appendix require the production of a new+EUPL version.++================================================================================+2. Apache License, Version 2.0 (Apache-2.0)+================================================================================++Apache License+Version 2.0, January 2004+http://www.apache.org/licenses/++TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++1. Definitions.++"License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document.++"Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License.++"Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity.++"You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License.++"Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files.++"Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types.++"Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below).++"Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof.++"Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution."++"Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work.++2. Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form.++3. Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed.++4. Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions:++ (a) You must give any other recipients of the Work or Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License.++ You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License.++5. Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions.++6. Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file.++7. Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License.++8. Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages.++9. Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability.++END OF TERMS AND CONDITIONS++APPENDIX: How to apply the Apache License to your work.++To apply the Apache License to your work, attach the following boilerplate notice, with the fields enclosed by brackets "[]" replaced with your own identifying information. (Don't include the brackets!) The text should be enclosed in the appropriate comment syntax for the file format. We also recommend that a file or class name and description of purpose be included on the same "printed page" as the copyright notice for easier identification within third-party archives.++Copyright [yyyy] [name of copyright owner]++Licensed under the Apache License, Version 2.0 (the "License");+you may not use this file except in compliance with the License.+You may obtain a copy of the License at++http://www.apache.org/licenses/LICENSE-2.0++Unless required by applicable law or agreed to in writing, software+distributed under the License is distributed on an "AS IS" BASIS,+WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+See the License for the specific language governing permissions and+limitations under the License.
+ README.md view
@@ -0,0 +1,49 @@+# polytropos-dhall++High-performance [Dhall](https://dhall-lang.org) configuration language codecs and generic adapters for [polytropos](https://github.com/NadiaYvette/polytropos) open records and variants.++## Overview++Unlike `GHC.Generics` which constructs intermediate binary tree representations (`(:*:)`, `(:+:)`) during serialization, `polytropos-dhall` unrolls the flat contiguous `SmallArray` payload directly into Dhall record and union AST expressions and back.++In addition to first-class open row codecs, `polytropos-dhall` provides generic adapters around `Dhall.Marshal.Decode.GenericFromDhall` and `Dhall.Marshal.Encode.GenericToDhall`, enabling turnkey `DerivingVia` configuration decoding for nominal types and downstream substrates such as `gachi`.++## Features++- **Heterogeneous Record Codecs**: Automatic `ToDhall` and `FromDhall` instances for open records (`Record r`) via compile-time field dictionary unrolling.+- **Tagged Variant Codecs**: High-performance constructor dispatch encoding variants into Dhall union expressions (`< Foo : { ... } | Bar : { ... } >`).+- **Higher-Kinded Record Codecs**: Turnkey support for `RecordF f r` (such as `RecordF Maybe r` with automatic `Nothing` defaults on omitted fields).+- **Generic Adapters**: Turnkey `GenericDhall` adapter for `deriving (FromDhall, ToDhall) via (GenericDhall MyType)` over GHC `Generic`.+- **Homogeneous Fast Path**: Introspection and reflection helpers for uniform records and sum rows.++## Quick Example++```haskell+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fplugin=Polytropos.Plugin #-}++import Dhall (input, auto, embed, inject)+import qualified Data.Text.IO as TIO+import Polytropos+import Polytropos.Dhall++type ServerConfig = Record '["host" ':= Text, "port" ':= Natural, "active" ':= Bool]++main :: IO ()+main = do+ -- Construct open record using idiomatic REC syntax:+ let cfg = REC { host = "localhost", port = 8080, active = True } :: ServerConfig++ -- Encode directly to Dhall expression:+ let expr = embed inject cfg+ print expr++ -- Decode back from Dhall text:+ cfg' <- input auto "{ host = \"0.0.0.0\", port = 9000, active = False }"+ print (cfg' :: ServerConfig)+```++## License++Dual-licensed under `EUPL-1.2 OR Apache-2.0`.
+ polytropos-dhall.cabal view
@@ -0,0 +1,69 @@+cabal-version: 3.0+name: polytropos-dhall+version: 0.1.0.2+synopsis: High-performance Dhall codecs and generic adapters for polytropos open rows+description:+ Linear O(N) 'Dhall.Marshal.Decode.FromDhall' and 'Dhall.Marshal.Encode.ToDhall' codecs+ and generic adapters for <https://hackage.haskell.org/package/polytropos polytropos> open records+ and variants via <https://hackage.haskell.org/package/dhall dhall>.++ Unlike "GHC.Generics" which builds deeply nested binary tree nodes (@(:*:)@, @(:+:)@)+ during serialization, @polytropos-dhall@ unrolls the flat contiguous+ 'Data.Primitive.SmallArray.SmallArray' payload directly into Dhall record and union literals+ and back. Variants serialize into Dhall union expressions with O(1) constructor tag dispatch.++ Also provides generic adapters via 'Dhall.Marshal.Decode.GenericFromDhall' and+ 'Dhall.Marshal.Encode.GenericToDhall' ('Polytropos.Dhall.GenericDhall') enabling+ seamless DerivingVia integration for nominal Haskell types and gachi substrates.++ Start at the front door module "Polytropos.Dhall" for complete documentation,+ codec options, and worked examples.+license: EUPL-1.2 OR Apache-2.0+license-file: LICENSE+author: Nadia Yvette Chambers+maintainer: nadia.yvette.chambers@ik.me+category: Data, Configuration+homepage: https://github.com/NadiaYvette/polytropos+bug-reports: https://github.com/NadiaYvette/polytropos/issues+extra-doc-files:+ README.md+ , CHANGELOG.md+build-type: Simple++source-repository head+ type: git+ location: https://github.com/NadiaYvette/polytropos+ subdir: packages/polytropos-dhall++library+ default-language: GHC2021+ hs-source-dirs: src+ exposed-modules: Polytropos.Dhall+ ghc-options: -Wall+ build-depends:+ base >= 4.14 && < 5,+ dhall >= 1.42 && < 1.43,+ text >= 1.2 && < 2.2,+ bytestring >= 0.10 && < 0.13,+ either >= 5.0 && < 5.1,+ primitive >= 0.7 && < 0.10,+ polytropos-core >= 0.1 && < 0.2,+ polytropos-plugin >= 0.1 && < 0.2++test-suite polytropos-dhall-test+ type: exitcode-stdio-1.0+ default-language: GHC2021+ hs-source-dirs: test+ main-is: Main.hs+ ghc-options: -Wall -fplugin=Polytropos.Plugin+ build-depends:+ base,+ dhall,+ text,+ bytestring,+ either,+ polytropos-core,+ polytropos-dhall,+ polytropos-plugin,+ tasty,+ tasty-hunit
+ src/Polytropos/Dhall.hs view
@@ -0,0 +1,599 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-}++{-|+Module : Polytropos.Dhall+Description : High-performance Dhall codecs and generic adapters for Polytropos open records and variants+Copyright : (c) 2026 The Polytropos Authors+License : EUPL-1.2 OR Apache-2.0+Maintainer : nadia.yvette.chambers@ik.me+Stability : experimental+Portability : non-portable (GHC extensions)++Linear \(O(N)\) 'Dhall.FromDhall' and 'Dhall.ToDhall' codecs for heterogeneous open+'Record', 'Variant', and higher-kinded 'RecordF' types, alongside generic adapters+powered by "Dhall.Marshal.Decode.GenericFromDhall" and "Dhall.Marshal.Encode.GenericToDhall".++= Architectural Overview & Rationale++== Flat Memory Physics vs. GHC.Generics Binary Trees++Standard "GHC.Generics" deriving for Dhall walks a deeply nested binary tree of+@(:*:)@, @(:+:)@, @M1@, and @K1@ constructors. On larger configuration schemas+(20+ fields or constructors), this induces substantial compile-time overhead and+allocates intermediate representation nodes for every parsed field.++In contrast, @polytropos-dhall@ unrolls the flat contiguous+'Data.Primitive.SmallArray.SmallArray' payload directly into and out of Dhall's+abstract syntax tree ('Dhall.Syntax.Expr'):++* __Records__: An open 'Record' encodes into a native Dhall record literal+ @RecordLit { x = ..., y = ... }@ in exact row order, and decodes directly from+ the field map into flat memory with zero intermediate binary tree allocations.+* __Variants__: An open 'Variant' encodes into a native Dhall union literal+ @< Ctor : { ... } | ... >@ with \(O(1)\) constructor tag dispatch, avoiding+ linear cascading searches.+* __Higher-Kinded Data (HKD)__: 'RecordF' (such as @RecordF Maybe r@) integrates+ natively, with automatic 'Nothing' fallback semantics for omitted configuration fields.++== Generic Adapters for Nominal Schemas and Gachi Substrates++In addition to open rows, this package provides turnkey generic adapters+('GenericDhall', 'genericFromDhall', 'genericToDhall') leveraging Dhall's internal+'GenericFromDhall' and 'GenericToDhall' classes. Nominal Haskell records or+osteological structures (such as in @gachi@) can derive 'FromDhall' and 'ToDhall'+via 'GenericDhall' through @DerivingVia@:++> data ServerConfig = ServerConfig+> { host :: Text+> , port :: Natural+> } deriving stock (Generic, Show, Eq)+> deriving (FromDhall, ToDhall) via (GenericDhall ServerConfig)++= When to Use This Module++* When reading or writing configuration files, environment profiles, or service+ manifests modeled with @polytropos@ open records or variants.+* When deriving Dhall encoders and decoders for nominal records via 'GenericDhall'.+* When building extensible, multi-agent configuration pipelines (such as in+ @sarutahiko@ or @gachi@) requiring deterministic schemas.++= Worked Example++Open records are constructed using the @REC { ... }@ syntax enabled by the+@polytropos@ source plugin (via @-fplugin=Polytropos.Plugin@):++> {-# LANGUAGE DataKinds #-}+> {-# LANGUAGE OverloadedStrings #-}+> {-# OPTIONS_GHC -fplugin=Polytropos.Plugin #-}+>+> import Dhall (input, auto, embed, inject, Natural)+> import Data.Text (Text)+> import Polytropos+> import Polytropos.Dhall+>+> type AppConfig = Record '["host" ':= Text, "port" ':= Natural, "debug" ':= Bool]+>+> cfg :: AppConfig+> cfg = REC { host = "localhost", port = 8080, debug = True }+>+> -- Embed to Dhall expression:+> dhallExpr = embed inject cfg+>+> -- Decode from Dhall text:+> cfg' <- input auto "{ host = \"0.0.0.0\", port = 9000, debug = False }"+-}+module Polytropos.Dhall+ ( -- * High-Level Convenience API+ encodeDhall+ , injectDhall+ , decodeDhall+ , extractDhall++ -- * Heterogeneous Row Codecs+ , AllToDhall (..)+ , AllFromDhall (..)+ , AllCtorsToDhall (..)+ , AllCtorsFromDhall (..)+ , DhallFieldFallback (..)++ -- * Higher-Kinded Data Codecs+ , AllToDhallHKD (..)+ , AllFromDhallHKD (..)++ -- * Generic Adapters & DerivingVia+ , GenericDhall (..)+ , genericFromDhall+ , genericFromDhallWith+ , genericToDhall+ , genericToDhallWith+ , GenericFromDhall (..)+ , GenericFromDhallUnion (..)+ , GenericToDhall (..)++ -- * Homogeneity Evidence and Row Introspection+ -- $homogeneity+ , AllFieldsAre+ , AllCtorsHom (..)+ , FieldNames (..)+ , RowField+ , SumField+ ) where++import Data.Functor ((<&>))+import Data.Functor.Contravariant (contramap)+import Data.Functor.Identity (Identity (..))+import Data.Kind (Constraint, Type)+import Data.Primitive.SmallArray (smallArrayFromList)+import Data.Proxy (Proxy (..))+import Data.Text (Text)+import qualified Data.Text as T+import Data.Void (Void)+import GHC.Exts (Any, toList)+import GHC.Generics (Generic)+import qualified GHC.Generics as GHC+import GHC.TypeLits (KnownSymbol, symbolVal)++import Dhall+ ( Decoder (..)+ , Encoder (..)+ , FromDhall (..)+ , InputNormalizer (..)+ , InterpretOptions (..)+ , ToDhall (..)+ , defaultInterpretOptions+ , genericAuto+ , genericAutoWithInputNormalizer+ , genericToDhall+ , genericToDhallWith+ , genericToDhallWithInputNormalizer+ )+import qualified Dhall+import qualified Dhall.Core as Core+import qualified Dhall.Map as Dhall.Map+import Dhall.Marshal.Decode+ ( Expector+ , Extractor+ , GenericFromDhall (..)+ , GenericFromDhallUnion (..)+ , extractError+ , typeError+ )+import Dhall.Marshal.Encode (GenericToDhall (..))+import Dhall.Core+ ( Expr (..)+ , FieldSelection (..)+ )+import Dhall.Src (Src (..))++import Polytropos (Record, RecordF, Variant)+import Polytropos.Core+ ( Pair (..)+ , ProductRow+ , Rep (..)+ , Row+ , RowRep (..)+ , SumRow+ , injectRep+ , noInlineUnsafeCo+ , productRep+ , repTag+ , repVals+ )++{-------------------------------------------------------------------------------+ High-Level Convenience API+-------------------------------------------------------------------------------}++-- | Encode any 'ToDhall' value directly into a formatted Dhall text string.+encodeDhall :: ToDhall a => a -> Text+encodeDhall = Core.pretty . injectDhall++-- | Embed any 'ToDhall' value into a Dhall abstract syntax tree ('Expr Src Void').+injectDhall :: ToDhall a => a -> Expr Src Void+injectDhall = Dhall.embed Dhall.inject++-- | Decode a Dhall text expression directly into a Haskell value.+decodeDhall :: FromDhall a => Text -> IO a+decodeDhall = Dhall.input Dhall.auto++-- | Extract a Haskell value from a parsed Dhall expression.+extractDhall :: FromDhall a => Expr Src Void -> Extractor Src Void a+extractDhall = extract Dhall.auto++{-------------------------------------------------------------------------------+ Field Fallback Handling+-------------------------------------------------------------------------------}++-- | Provides a default fallback value when a field is missing from a Dhall record literal.+--+-- By default, missing fields produce an extraction error ('extractError').+-- For 'Maybe' fields, missing fields gracefully evaluate to 'Nothing', aligning+-- with Dhall's native optional field conventions.+class DhallFieldFallback a where+ dhallMissingField :: Maybe (Extractor Src Void a)++instance {-# OVERLAPPABLE #-} DhallFieldFallback a where+ dhallMissingField = Nothing++instance DhallFieldFallback (Maybe a) where+ dhallMissingField = Just (pure Nothing)++{-------------------------------------------------------------------------------+ Heterogeneous Row Codecs+-------------------------------------------------------------------------------}++-- | Evidence that every field of the row @r@ has a 'ToDhall' instance+-- at that field's own concrete type. Unrolls payload slots in row order.+class AllToDhall (r :: Row) where+ declaredRecordFields :: InputNormalizer -> Proxy r -> [(Text, Core.RecordField Src Void)]+ encRecordFields :: InputNormalizer -> Proxy r -> [Identity Any] -> [(Text, Core.RecordField Src Void)]++instance AllToDhall '[] where+ declaredRecordFields _ _ = []+ encRecordFields _ _ _ = []++instance (KnownSymbol n, ToDhall a, AllToDhall r) => AllToDhall ((n ':= a) ': r) where+ declaredRecordFields norm _ =+ let key = T.pack (symbolVal (Proxy @n))+ Encoder _ declA = injectWith norm :: Encoder a+ in (key, Core.makeRecordField declA) : declaredRecordFields norm (Proxy @r)++ encRecordFields norm _ (Identity x : xs) =+ let key = T.pack (symbolVal (Proxy @n))+ Encoder embedA _ = injectWith norm :: Encoder a+ in (key, Core.makeRecordField (embedA (noInlineUnsafeCo x :: a)))+ : encRecordFields norm (Proxy @r) xs+ encRecordFields _ _ [] = error "polytropos-dhall: payload arity mismatch"++-- | Evidence that every field of the row @r@ has a 'FromDhall' instance+-- at that field's own concrete type. Decodes each field by name from the Dhall record.+class AllFromDhall (r :: Row) where+ expectedRecordFields :: InputNormalizer -> Proxy r -> Expector [(Text, Core.RecordField Src Void)]+ decRecordFields :: InputNormalizer -> Proxy r -> Dhall.Map.Map Text (Core.RecordField Src Void) -> Extractor Src Void [Identity Any]++instance AllFromDhall '[] where+ expectedRecordFields _ _ = pure []+ decRecordFields _ _ _ = pure []++instance (KnownSymbol n, FromDhall a, DhallFieldFallback a, AllFromDhall r) => AllFromDhall ((n ':= a) ': r) where+ expectedRecordFields norm _ =+ let key = T.pack (symbolVal (Proxy @n))+ Decoder _ expectedA = autoWith norm :: Decoder a+ expectedRest = expectedRecordFields norm (Proxy @r)+ in liftA2 (\tyA rest -> (key, Core.makeRecordField tyA) : rest) expectedA expectedRest++ decRecordFields norm _ kvs =+ let key = T.pack (symbolVal (Proxy @n))+ Decoder extractA _ = autoWith norm :: Decoder a+ valA = case Dhall.Map.lookup key kvs of+ Just rf -> extractA (Core.recordFieldValue rf)+ Nothing -> case dhallMissingField @a of+ Just fallback -> fallback+ Nothing -> extractError ("Record is missing required field: " <> key)+ valRest = decRecordFields norm (Proxy @r) kvs+ in liftA2 (\x xs -> Identity (noInlineUnsafeCo x :: Any) : xs) valA valRest++-- | Helper class for permissive extraction of single-field variant payloads.+class DecSingleField (fs :: Row) where+ decRecordFieldsSingle :: InputNormalizer -> Proxy fs -> Expr Src Void -> Maybe (Extractor Src Void [Identity Any])++instance {-# OVERLAPPABLE #-} DecSingleField fs where+ decRecordFieldsSingle _ _ _ = Nothing++instance (KnownSymbol n, FromDhall a) => DecSingleField '[(n ':= a)] where+ decRecordFieldsSingle norm _ expr =+ let Decoder extractA _ = autoWith norm :: Decoder a+ in Just ((\x -> [Identity (noInlineUnsafeCo x :: Any)]) <$> extractA expr)++-- | Evidence that every constructor of the sum row @s@ has a heterogeneous+-- field row satisfying 'AllToDhall', paired with its constructor tag index.+class AllCtorsToDhall (s :: SumRow) where+ declaredUnionAlts :: InputNormalizer -> Proxy s -> [(Text, Maybe (Expr Src Void))]+ encVariantTag :: InputNormalizer -> Dhall.Map.Map Text (Maybe (Expr Src Void)) -> Proxy s -> Word -> [Identity Any] -> Expr Src Void++instance AllCtorsToDhall '[] where+ declaredUnionAlts _ _ = []+ encVariantTag _ _ _ _ _ = error "polytropos-dhall: empty variant has no constructors"++instance (KnownSymbol c, AllToDhall fs, AllCtorsToDhall s)+ => AllCtorsToDhall ((c ':= fs) ': s) where+ declaredUnionAlts norm _ =+ let cName = T.pack (symbolVal (Proxy @c))+ fsDecls = declaredRecordFields norm (Proxy @fs)+ altType = case fsDecls of+ [] -> Nothing+ _ -> Just (Record (Dhall.Map.fromList fsDecls))+ in (cName, altType) : declaredUnionAlts norm (Proxy @s)++ encVariantTag norm fullUnion _ 0 slots =+ let cName = T.pack (symbolVal (Proxy @c))+ fieldSel = Core.makeFieldSelection cName+ fsFields = encRecordFields norm (Proxy @fs) slots+ in case fsFields of+ [] -> Field (Union fullUnion) fieldSel+ _ -> App (Field (Union fullUnion) fieldSel) (RecordLit (Dhall.Map.fromList fsFields))++ encVariantTag norm fullUnion _ tag slots =+ encVariantTag norm fullUnion (Proxy @s) (tag - 1) slots++-- | Evidence that every constructor of the sum row @s@ has a heterogeneous+-- field row satisfying 'AllFromDhall', paired with its constructor tag index.+class AllCtorsFromDhall (s :: SumRow) where+ expectedUnionAlts :: InputNormalizer -> Proxy s -> Expector [(Text, Maybe (Expr Src Void))]+ decVariantVal :: InputNormalizer -> Proxy s -> Word -> Text -> Expr Src Void -> Extractor Src Void (Word, [Identity Any])++instance AllCtorsFromDhall '[] where+ expectedUnionAlts _ _ = pure []+ decVariantVal _ _ _ cName _ = extractError ("Unknown variant constructor: " <> cName)++instance (KnownSymbol c, AllFromDhall fs, DecSingleField fs, AllCtorsFromDhall s)+ => AllCtorsFromDhall ((c ':= fs) ': s) where+ expectedUnionAlts norm _ =+ let cName = T.pack (symbolVal (Proxy @c))+ fsExpected = expectedRecordFields norm (Proxy @fs)+ altType = fsExpected <&> \case+ [] -> Nothing+ fields -> Just (Record (Dhall.Map.fromList fields))+ restAlts = expectedUnionAlts norm (Proxy @s)+ in liftA2 (\alt rest -> (cName, alt) : rest) altType restAlts++ decVariantVal norm _ idx cKey val+ | cKey == T.pack (symbolVal (Proxy @c)) = case val of+ RecordLit kvs ->+ (\slots -> (idx, slots)) <$> decRecordFields norm (Proxy @fs) kvs+ _ -> case decRecordFieldsSingle norm (Proxy @fs) val of+ Just slotsExtractor ->+ (\slots -> (idx, slots)) <$> slotsExtractor+ Nothing -> extractError ("Expected a record literal of fields for constructor: " <> cKey)+ | otherwise =+ decVariantVal norm (Proxy @s) (idx + 1) cKey val++{-------------------------------------------------------------------------------+ Record Codecs+-------------------------------------------------------------------------------}++instance AllToDhall r => ToDhall (Record r) where+ injectWith norm = Encoder+ { embed = \(RowRep rep) ->+ RecordLit (Dhall.Map.fromList (encRecordFields norm (Proxy @r) (toList (repVals rep))))+ , declared = Record (Dhall.Map.fromList (declaredRecordFields norm (Proxy @r)))+ }++instance AllFromDhall r => FromDhall (Record r) where+ autoWith norm =+ let expectedFields = expectedRecordFields norm (Proxy @r)+ expectedRec = Record . Dhall.Map.fromList <$> expectedFields+ in Decoder+ { extract = \expr -> case expr of+ RecordLit kvs -> RowRep . productRep <$> decRecordFields norm (Proxy @r) kvs+ _ -> typeError expectedRec expr+ , expected = expectedRec+ }++{-------------------------------------------------------------------------------+ Variant Codecs+-------------------------------------------------------------------------------}++-- | Deconstruct an AST node into its constructor name and payload expression.+extractUnionTag :: Expr s a -> Maybe (Text, Expr s a)+extractUnionTag = \case+ App (Field _ (FieldSelection _ fld _)) e -> Just (fld, e)+ Field _ (FieldSelection _ fld _) -> Just (fld, RecordLit mempty)+ _ -> Nothing++instance AllCtorsToDhall s => ToDhall (Variant s) where+ injectWith norm =+ let alts = Dhall.Map.fromList (declaredUnionAlts norm (Proxy @s))+ in Encoder+ { embed = \(RowRep rep) ->+ encVariantTag norm alts (Proxy @s) (repTag rep) (toList (repVals rep))+ , declared = Union alts+ }++instance AllCtorsFromDhall s => FromDhall (Variant s) where+ autoWith norm =+ let expectedU = Union . Dhall.Map.fromList <$> expectedUnionAlts norm (Proxy @s)+ in Decoder+ { extract = \expr -> case extractUnionTag expr of+ Just (cKey, val) ->+ (\(idx, slots) -> RowRep (injectRep (fromIntegral idx) slots))+ <$> decVariantVal norm (Proxy @s) 0 cKey val+ Nothing -> typeError expectedU expr+ , expected = expectedU+ }++{-------------------------------------------------------------------------------+ Higher-Kinded Data Codecs (RecordF f r)+-------------------------------------------------------------------------------}++-- | Evidence that every field of an HKD row @r@ has a 'ToDhall' instance+-- for the functor-wrapped payload @f a@.+class AllToDhallHKD (f :: Type -> Type) (r :: ProductRow f) where+ declaredRecordFieldsHKD :: InputNormalizer -> Proxy f -> Proxy r -> [(Text, Core.RecordField Src Void)]+ encRecordFieldsHKD :: InputNormalizer -> Proxy f -> Proxy r -> [f Any] -> [(Text, Core.RecordField Src Void)]++instance AllToDhallHKD f '[] where+ declaredRecordFieldsHKD _ _ _ = []+ encRecordFieldsHKD _ _ _ _ = []++instance (KnownSymbol n, ToDhall (f a), AllToDhallHKD f r)+ => AllToDhallHKD f ((n ':= f a) ': r) where+ declaredRecordFieldsHKD norm pf _ =+ let key = T.pack (symbolVal (Proxy @n))+ Encoder _ declA = injectWith norm :: Encoder (f a)+ in (key, Core.makeRecordField declA) : declaredRecordFieldsHKD norm pf (Proxy @r)++ encRecordFieldsHKD norm pf _ (x : xs) =+ let key = T.pack (symbolVal (Proxy @n))+ Encoder embedA _ = injectWith norm :: Encoder (f a)+ in (key, Core.makeRecordField (embedA (noInlineUnsafeCo x :: f a)))+ : encRecordFieldsHKD norm pf (Proxy @r) xs+ encRecordFieldsHKD _ _ _ [] = error "polytropos-dhall: HKD payload arity mismatch"++-- | Evidence that every field of an HKD row @r@ has a 'FromDhall' instance+-- for the functor-wrapped payload @f a@.+class AllFromDhallHKD (f :: Type -> Type) (r :: ProductRow f) where+ expectedRecordFieldsHKD :: InputNormalizer -> Proxy f -> Proxy r -> Expector [(Text, Core.RecordField Src Void)]+ decRecordFieldsHKD :: InputNormalizer -> Proxy f -> Proxy r -> Dhall.Map.Map Text (Core.RecordField Src Void) -> Extractor Src Void [f Any]++instance AllFromDhallHKD f '[] where+ expectedRecordFieldsHKD _ _ _ = pure []+ decRecordFieldsHKD _ _ _ _ = pure []++instance (KnownSymbol n, FromDhall (f a), DhallFieldFallback (f a), AllFromDhallHKD f r)+ => AllFromDhallHKD f ((n ':= f a) ': r) where+ expectedRecordFieldsHKD norm pf _ =+ let key = T.pack (symbolVal (Proxy @n))+ Decoder _ expectedA = autoWith norm :: Decoder (f a)+ expectedRest = expectedRecordFieldsHKD norm pf (Proxy @r)+ in liftA2 (\tyA rest -> (key, Core.makeRecordField tyA) : rest) expectedA expectedRest++ decRecordFieldsHKD norm pf _ kvs =+ let key = T.pack (symbolVal (Proxy @n))+ Decoder extractA _ = autoWith norm :: Decoder (f a)+ valA = case Dhall.Map.lookup key kvs of+ Just rf -> extractA (Core.recordFieldValue rf)+ Nothing -> case dhallMissingField @(f a) of+ Just fallback -> fallback+ Nothing -> extractError ("Record is missing required field: " <> key)+ valRest = decRecordFieldsHKD norm pf (Proxy @r) kvs+ in liftA2 (\x xs -> (noInlineUnsafeCo x :: f Any) : xs) valA valRest++instance AllToDhallHKD f r => ToDhall (RecordF f r) where+ injectWith norm = Encoder+ { embed = \(RowRep rep) ->+ RecordLit (Dhall.Map.fromList (encRecordFieldsHKD norm (Proxy @f) (Proxy @r) (toList (repVals rep))))+ , declared = Record (Dhall.Map.fromList (declaredRecordFieldsHKD norm (Proxy @f) (Proxy @r)))+ }++instance AllFromDhallHKD f r => FromDhall (RecordF f r) where+ autoWith norm =+ let expectedFields = expectedRecordFieldsHKD norm (Proxy @f) (Proxy @r)+ expectedRec = Record . Dhall.Map.fromList <$> expectedFields+ in Decoder+ { extract = \expr -> case expr of+ RecordLit kvs -> RowRep . Rep 0 . smallArrayFromList <$> decRecordFieldsHKD norm (Proxy @f) (Proxy @r) kvs+ _ -> typeError expectedRec expr+ , expected = expectedRec+ }++{-------------------------------------------------------------------------------+ Generic Adapters & DerivingVia+-------------------------------------------------------------------------------}++-- | Newtype wrapper providing generic 'FromDhall' and 'ToDhall' instances+-- for any data type with a 'Generic' instance, via 'GenericFromDhall'+-- and 'GenericToDhall'.+--+-- Usage with @DerivingVia@:+--+-- > data Config = Config+-- > { host :: Text+-- > , port :: Natural+-- > } deriving stock (Generic, Show, Eq)+-- > deriving (FromDhall, ToDhall) via (GenericDhall Config)+newtype GenericDhall a = GenericDhall { unGenericDhall :: a }++instance (Generic a, GenericFromDhall a (GHC.Rep a)) => FromDhall (GenericDhall a) where+ autoWith norm = fmap GenericDhall (genericAutoWithInputNormalizer defaultInterpretOptions norm)++instance (Generic a, GenericToDhall (GHC.Rep a)) => ToDhall (GenericDhall a) where+ injectWith norm = contramap unGenericDhall (genericToDhallWithInputNormalizer defaultInterpretOptions norm)++-- | Construct a 'Decoder' for any 'Generic' data type using Dhall's generic adapter+-- 'GenericFromDhall'.+genericFromDhall :: forall a. (Generic a, GenericFromDhall a (GHC.Rep a)) => Decoder a+genericFromDhall = genericAuto++-- | Construct a 'Decoder' for any 'Generic' data type using custom 'InterpretOptions'+-- and 'InputNormalizer'.+genericFromDhallWith+ :: forall a. (Generic a, GenericFromDhall a (GHC.Rep a))+ => InterpretOptions+ -> InputNormalizer+ -> Decoder a+genericFromDhallWith = genericAutoWithInputNormalizer+++{-------------------------------------------------------------------------------+ Homogeneity evidence and row introspection (Reflection helpers)+-------------------------------------------------------------------------------}++-- $homogeneity+--+-- === Homogeneity Evidence and Introspection Helpers+--+-- In addition to the primary heterogeneous codecs ('AllToDhall', 'AllFromDhall'),+-- this module provides closed type families and reflection classes for+-- inspecting row metadata and enforcing uniform payload types.+--+-- 1. 'AllFieldsAre' is a closed type family asserting that /every/ field in a row+-- has the uniform type @a@.+-- 2. 'RowField' and 'SumField' compute the uniform payload type directly from+-- the row or sum row, eliminating type ambiguity for custom instances.+-- 3. 'FieldNames' reifies type-level 'GHC.TypeLits.Symbol' field labels into+-- runtime @['String']@ keys in exact row order.+-- 4. 'AllCtorsHom' reifies the constructor topology of a homogeneous sum row into+-- @[(String, [String])]@ (mapping each constructor name to its list of field names).++-- | Evidence that every field of the row @r@ has type @a@.+type family AllFieldsAre (a :: Type) (r :: Row) :: Constraint where+ AllFieldsAre _ '[] = ()+ AllFieldsAre a ((n ':= a) ': rest) = AllFieldsAre a rest++-- | Extracts the uniform field type of a homogeneous row: the type of /every/+-- field, or 'Void' for the empty row @'[]@.+type family RowField (r :: Row) :: Type where+ RowField '[] = Void+ RowField ((n ':= a) ': rest) = a++-- | Extracts the uniform field type shared by every constructor of a homogeneous+-- sum row, or 'Void' for the empty sum @'[]@.+type family SumField (s :: SumRow) :: Type where+ SumField '[] = Void+ SumField ((c ':= fs) ': s) = RowField fs++-- | The field names of a row, in exact row order, reified from type-level+-- 'GHC.TypeLits.Symbol' labels into runtime @['String']@ keys.+class FieldNames (r :: Row) where+ fieldNames :: Proxy r -> [String]++instance FieldNames '[] where+ fieldNames _ = []++instance (KnownSymbol n, FieldNames r) => FieldNames ((n ':= a) ': r) where+ fieldNames _ = symbolVal (Proxy @n) : fieldNames (Proxy @r)++-- | Reflection dictionary for homogeneous sum rows (variants).+--+-- Reifies the full constructor topology into a runtime list pairing each+-- constructor symbol with its ordered field symbols: @[(String, [String])]@.+class AllCtorsHom (a :: Type) (s :: SumRow) where+ ctorSpecs :: Proxy a -> Proxy s -> [(String, [String])]++instance AllCtorsHom a '[] where+ ctorSpecs _ _ = []++instance (KnownSymbol c, FieldNames fs, AllFieldsAre a fs, AllCtorsHom a s)+ => AllCtorsHom a ((c ':= fs) ': s) where+ ctorSpecs pa _ =+ (symbolVal (Proxy @c), fieldNames (Proxy @fs)) : ctorSpecs pa (Proxy @s)
+ test/Main.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Main (main) where++import Test.Tasty+import Test.Tasty.HUnit+import Data.Proxy (Proxy (..))+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Generics (Generic)+import Dhall (FromDhall, ToDhall, Natural, auto, inject, input, embed, extract)+import qualified Dhall.Core as Core+import qualified Dhall.Map as Map++import Data.Either.Validation (Validation (..))+import Polytropos+import Polytropos.Dhall++{-------------------------------------------------------------------------------+ Record schemas+-------------------------------------------------------------------------------}++type MyRec = Record '["x" ':= Natural, "y" ':= Natural, "z" ':= Natural]+myRec :: MyRec+myRec = REC { x = 1, y = 2, z = 3 }++type HeteroRow = '["host" ':= Text, "port" ':= Natural, "active" ':= Bool, "weight" ':= Double]+type HeteroRec = Record HeteroRow+heteroRec :: HeteroRec+heteroRec = REC { host = "localhost", port = 8080, active = True, weight = 1.75 }++type OptionalRec = Record '["name" ':= Text, "timeout" ':= Maybe Natural]++type AppConfigF = RecordF Maybe '["api" ':= Maybe Text, "workers" ':= Maybe Natural]++type RowOf20 =+ '[ "f00" ':= Natural, "f01" ':= Natural, "f02" ':= Natural, "f03" ':= Natural, "f04" ':= Natural+ , "f05" ':= Natural, "f06" ':= Natural, "f07" ':= Natural, "f08" ':= Natural, "f09" ':= Natural+ , "f10" ':= Natural, "f11" ':= Natural, "f12" ':= Natural, "f13" ':= Natural, "f14" ':= Natural+ , "f15" ':= Natural, "f16" ':= Natural, "f17" ':= Natural, "f18" ':= Natural, "f19" ':= Natural+ ]++buildBig :: Natural -> Record RowOf20+buildBig n =+ insertField (Field @"f00") n+ $ insertField (Field @"f01") n+ $ insertField (Field @"f02") n+ $ insertField (Field @"f03") n+ $ insertField (Field @"f04") n+ $ insertField (Field @"f05") n+ $ insertField (Field @"f06") n+ $ insertField (Field @"f07") n+ $ insertField (Field @"f08") n+ $ insertField (Field @"f09") n+ $ insertField (Field @"f10") n+ $ insertField (Field @"f11") n+ $ insertField (Field @"f12") n+ $ insertField (Field @"f13") n+ $ insertField (Field @"f14") n+ $ insertField (Field @"f15") n+ $ insertField (Field @"f16") n+ $ insertField (Field @"f17") n+ $ insertField (Field @"f18") n+ $ insertField (Field @"f19") n+ $ emptyRecord++{-------------------------------------------------------------------------------+ Variant schemas+-------------------------------------------------------------------------------}++type MyVar = Variant '["A" ':= '["foo" ':= Natural], "B" ':= '["bar" ':= Natural]]+varA :: MyVar+varA = Variant (Field @"A") (REC { foo = 42 :: Natural })++varB :: MyVar+varB = Variant (Field @"B") (REC { bar = 7 :: Natural })++type HeteroVar = Variant '["Msg" ':= '["text" ':= Text, "priority" ':= Natural], "Ping" ':= '[]]+heteroVar1 :: HeteroVar+heteroVar1 = Variant (Field @"Msg") (REC { text = "alert", priority = 1 })++heteroVar2 :: HeteroVar+heteroVar2 = Variant (Field @"Ping") emptyRecord++type ShapeRow = '["Circle" ':= '["radius" ':= Double], "Rect" ':= '["w" ':= Double, "h" ':= Double]]+type ShapeVar = Variant ShapeRow++{-------------------------------------------------------------------------------+ Nominal types for Generic adapters+-------------------------------------------------------------------------------}++data ServerConfig = ServerConfig+ { srvHost :: Text+ , srvPort :: Natural+ , srvTls :: Bool+ } deriving stock (Generic, Show, Eq)+ deriving (FromDhall, ToDhall) via (GenericDhall ServerConfig)++{-------------------------------------------------------------------------------+ Tests+-------------------------------------------------------------------------------}++main :: IO ()+main = defaultMain $ testGroup "Dhall Integration"+ [ testGroup "Record Codecs"+ [ testCase "Roundtrip 3 fields" $ do+ let rendered = Core.pretty (embed inject myRec)+ rec' <- input auto rendered+ rec' @?= myRec+ , testCase "Roundtrip empty record" $ do+ let emptyR = emptyRecord :: Record '[]+ rendered = Core.pretty (embed inject emptyR)+ rec' <- input auto rendered+ rec' @?= emptyR+ , testCase "Roundtrip heterogeneous 4 fields" $ do+ let rendered = Core.pretty (embed inject heteroRec)+ rec' <- input auto rendered+ rec' @?= heteroRec+ , testCase "Roundtrip 20 fields" $ do+ let big = buildBig 42+ rendered = Core.pretty (embed inject big)+ rec' <- input auto rendered+ rec' @?= big+ , testCase "Decode from literal Dhall text" $ do+ let dhallSrc = "{ host = \"prod.cluster\", port = 443, active = True, weight = 2.5 }"+ rec' <- input auto dhallSrc+ rec' @?= (REC { host = "prod.cluster", port = 443, active = True, weight = 2.5 } :: HeteroRec)+ , testCase "Optional field present vs omitted fallback" $ do+ let withTimeout = "{ name = \"service-a\", timeout = Some 3000 }"+ withoutTimeout = "{ name = \"service-b\", timeout = None Natural }"+ r1 <- input auto withTimeout+ r2 <- input auto withoutTimeout+ r1 @?= (REC { name = "service-a", timeout = Just (3000 :: Natural) } :: OptionalRec)+ r2 @?= (REC { name = "service-b", timeout = Nothing } :: OptionalRec)++ -- Test AST extraction with field omitted entirely (DhallFieldFallback):+ let omittedFieldExpr = Core.RecordLit (Map.singleton "name" (Core.makeRecordField (Core.TextLit "service-b")))+ case extract auto omittedFieldExpr of+ Success r3 -> r3 @?= (REC { name = "service-b", timeout = Nothing } :: OptionalRec)+ Failure err -> assertFailure (show err)+ , testCase "encodeDhall row order" $ do+ let rendered = encodeDhall myRec+ T.strip rendered @?= "{ x = 1, y = 2, z = 3 }"+ ]+ , testGroup "Variant Codecs"+ [ testCase "Roundtrip A" $ do+ let rendered = Core.pretty (embed inject varA)+ v' <- input auto rendered+ v' @?= varA+ , testCase "Roundtrip B" $ do+ let rendered = Core.pretty (embed inject varB)+ v' <- input auto rendered+ v' @?= varB+ , testCase "Roundtrip heterogeneous Msg" $ do+ let rendered = Core.pretty (embed inject heteroVar1)+ v' <- input auto rendered+ v' @?= heteroVar1+ , testCase "Roundtrip nullary Ping" $ do+ let rendered = Core.pretty (embed inject heteroVar2)+ v' <- input auto rendered+ v' @?= heteroVar2+ , testCase "Permissive single-field payload decoding" $ do+ -- Union constructor with record payload in Dhall syntax:+ let srcRecord = "< Circle : { radius : Double } | Rect : { w : Double, h : Double } >.Circle { radius = 5.0 }"+ v1 <- input auto srcRecord :: IO ShapeVar+ let expectedCircle = Variant (Field @"Circle") (REC { radius = 5.0 :: Double }) :: ShapeVar+ v1 @?= expectedCircle++ -- Permissive single-field payload extraction on raw AST expression:+ let directExpr = Core.App (Core.Field (Core.Union mempty) (Core.makeFieldSelection "Circle")) (Core.DoubleLit (Core.DhallDouble 5.0))+ case extract auto directExpr of+ Success v2 -> v2 @?= expectedCircle+ Failure err -> assertFailure (show err)+ , testCase "Nullary variant parsing from bare constructor" $ do+ let srcBare = "< Msg : { text : Text, priority : Natural } | Ping >.Ping"+ v <- input auto srcBare :: IO HeteroVar+ v @?= heteroVar2+ ]+ , testGroup "Higher-Kinded Record Codecs (RecordF)"+ [ testCase "RecordF Maybe present & omitted roundtrip" $ do+ let srcFull = "{ api = Some \"https://api.v1\", workers = Some 8 }"+ srcPartial = "{ api = Some \"https://api.v2\", workers = None Natural }"+ c1 <- input auto srcFull :: IO AppConfigF+ c2 <- input auto srcPartial :: IO AppConfigF+ c1 @?= (insertFieldF (Field @"api") (Just "https://api.v1" :: Maybe Text)+ $ insertFieldF (Field @"workers") (Just 8 :: Maybe Natural)+ $ emptyRecordF)+ c2 @?= (insertFieldF (Field @"api") (Just "https://api.v2" :: Maybe Text)+ $ insertFieldF (Field @"workers") (Nothing :: Maybe Natural)+ $ emptyRecordF)++ -- Test HKD AST extraction with omitted field:+ let omittedHKDExpr = Core.RecordLit (Map.singleton "api" (Core.makeRecordField (embed inject (Just ("https://api.v2" :: Text)))))+ case extract auto omittedHKDExpr of+ Success c3 -> c3 @?= (insertFieldF (Field @"api") (Just "https://api.v2" :: Maybe Text)+ $ insertFieldF (Field @"workers") (Nothing :: Maybe Natural)+ $ emptyRecordF)+ Failure err -> assertFailure (show err)+ ]+ , testGroup "Generic Adapters (GenericDhall / GenericFromDhall / GenericToDhall)"+ [ testCase "DerivingVia GenericDhall roundtrip" $ do+ let cfg = ServerConfig { srvHost = "127.0.0.1", srvPort = 8443, srvTls = True }+ rendered = Core.pretty (embed inject cfg)+ cfg' <- input auto rendered+ cfg' @?= cfg+ , testCase "Direct genericFromDhall and genericToDhall" $ do+ let cfg = ServerConfig { srvHost = "gw.local", srvPort = 80, srvTls = False }+ enc = genericToDhall @ServerConfig+ dec = genericFromDhall @ServerConfig+ expr = embed enc cfg+ case extract dec expr of+ Success cfg' -> cfg' @?= cfg+ Failure err -> assertFailure (show err)+ ]+ , testGroup "Homogeneity Reflection"+ [ testCase "fieldNames in row order" $ do+ fieldNames (Proxy @HeteroRow) @?= ["host", "port", "active", "weight"]+ , testCase "ctorSpecs for homogeneous variant" $ do+ ctorSpecs (Proxy @Double) (Proxy @ShapeRow) @?= [("Circle", ["radius"]), ("Rect", ["w", "h"])]+ ]+ ]