A-gent 0 → 0.11.0.0
raw patch · 16 files changed
+2935/−687 lines, 16 filesdep +containersdep +mtldep +process
Dependencies added: containers, mtl, process
Files
- A-gent.cabal +115/−11
- CHANGELOG.md +8/−2
- LICENSE +0/−661
- LICENSE.md +29/−0
- README.md +51/−3
- src/Agent/Control/IFC.hs +81/−0
- src/Agent/Control/MAC.hs +155/−0
- src/Agent/IO/Effects.hs +30/−0
- src/Agent/IO/Restricted.hs +188/−0
- src/Agent/JSON.hs +66/−0
- src/Agent/LLM.hs +142/−10
- src/Internal/GaloisInc/Text/JSON.hs +537/−0
- src/Internal/GaloisInc/Text/JSON/Generic.hs +241/−0
- src/Internal/GaloisInc/Text/JSON/String.hs +412/−0
- src/Internal/GaloisInc/Text/JSON/Types.hs +126/−0
- src/Internal/GlasgowUniversity/Data/Generics/Aliases.hs +754/−0
A-gent.cabal view
@@ -1,17 +1,33 @@ cabal-version: 3.6++--------------------------------------------------------------------------------+--+-- Λ-gent, (c) 2026 SPISE MISU ApS, https://spdx.org/licenses/SSPL-1.0+--+--------------------------------------------------------------------------------++build-type: Simple+ name: A-gent-version: 0-synopsis: Λ-gent, based on placeholder definitions for TODO and unimplemented-description: Λ-gent, based placeholder definitions for TODO and unimplemented code-homepage: https://a-gent.org-license: AGPL-3.0-only-license-file: LICENSE+version: 0.11.0.0++synopsis: Polite & well educated LLM agent with excellent manners that always behaves well+description: Polite and well educated LLM agent with excellent manners that always behaves well+ +homepage: https://a-gent.org+bug-reports: https://bsky.app/profile/a-gent.org+ +license: SSPL-1.0 OR AGPL-3.0-only+license-file: LICENSE.md+ author: SPISE MISU maintainer: SPISE MISU <mail+hackage@spisemisu.com>-copyright: Copyright (c) 2026 SPISE MISU ApS+copyright: (c) 2026 SPISE MISU ApS+ stability: experimental+ category: Agent, LLM-build-type: Simple+ extra-doc-files: README.md, CHANGELOG.md source-repository head@@ -19,17 +35,90 @@ git location: https://gitlab.com/a-gent/a-gent+ +--------------------------------------------------------------------------------+-- COMMON+-------------------------------------------------------------------------------- common base- default-language:- Haskell2010 default-extensions: Safe+ default-language:+ Haskell2010 build-depends: -- Prelude- base >= 4 && < 5+ base >= 4 && < 5+ , process >= 1.6.25.0 && < 2+ , containers >= 0.8 && < 1+ , mtl >= 2.3.1 && < 3 ghc-options:+ --------------------------------------------------------------------------+ -- GHC 9.10.3 Users Guide+ -- 9. Using GHC > 9.2. Warnings and sanity-checking+ -- * Base: https://downloads.haskell.org/~ghc/9.10.3/docs/users_guide/+ -- * File: using-warnings.html+ -- Warnings that are not enabled by -Wall:+ -------------------------------------------------------------------------- -Wall+ -Wincomplete-record-updates+ -- -Wmonomorphism-restriction+ -- -Wimplicit-prelude+ -- -Wmissing-local-signatures+ -Wmissing-exported-signatures+ -- -Wmissing-export-lists+ -- -Wmissing-import-lists+ -Wmissing-home-modules+ -Widentities+ -- -Wredundant-constraints+ -- Added since GHC 8.4+ -Wpartial-fields + -- -Wmissed-specialisations+ -- -Wall-missed-specialisations+ --------------------------------------------------------------------------+ -- Added to allow instance definition in other files, in order to keep the + -- Effect module SAFE so it can be imported by the Process+ --------------------------------------------------------------------------+ -Wno-orphans+ -- Makes any warning into a fatal error.+ -- -Werror+ --------------------------------------------------------------------------+ -- Deterministic builds (Uniques):+ -- * https://gitlab.haskell.org/ghc/ghc/wikis/deterministic-builds#progress+ -- * https://www.youtube.com/watch?v=FNzTk4P4fL4 (08 GHC Determinism ICFP)+ --------------------------------------------------------------------------+ -- -dinitial-unique=0+ -- -dunique-increment=1+ --------------------------------------------------------------------------+ -- GHC 9.10.3 Users Guide+ -- 19. Known bugs and infelicities >+ -- 19.1. Haskell standards vs. Glasgow Haskell: language non-compliance >+ -- 19.1.1.3. Expressions and pointers+ -- * Base: https://downloads.haskell.org/~ghc/9.10.3/docs/users_guide/+ -- * File: bugs.html+ --------------------------------------------------------------------------+ -fpedantic-bottoms+ -- To use when GHC uses to many ticks:+ -- -ddump-simpl-stats+ -- -fsimpl-tick-factor=100+ --------------------------------------------------------------------------+ -- GHC 9.10.3 Users Guide+ -- 12.40. Safe Haskell > ... > 12.40.1.1. Strict type-safety (good style)+ -- * Enforce good style, similar to the function of -Wall.+ -- Only Trustworthy packages can be trusted+ -- * Base: https://downloads.haskell.org/~ghc/9.10.3/docs/users_guide/+ -- * File: safe_haskell.html+ --------------------------------------------------------------------------+ -fpackage-trust+ -- Base+ -trust=base+ -trust=ghc-internal+ -- Process+ -trust=process+ -trust=array+ -trust=ghc-prim+ -- JSON+ -trust=containers+ -trust=mtl library import:@@ -37,4 +126,19 @@ hs-source-dirs: src exposed-modules:+ Internal.GaloisInc.Text.JSON+ Internal.GaloisInc.Text.JSON.Generic+ Internal.GaloisInc.Text.JSON.String+ Internal.GaloisInc.Text.JSON.Types+ --+ Internal.GlasgowUniversity.Data.Generics.Aliases+ --+ Agent.JSON+ --+ Agent.Control.IFC+ Agent.Control.MAC+ --+ Agent.IO.Effects+ Agent.IO.Restricted+ -- Agent.LLM
CHANGELOG.md view
@@ -1,8 +1,14 @@ # Revision history for Λ-gent -## [next]+## 0.11.0.0 -- 2026-03-04 -* Minor documentation flow improvements+* Initial release after feedback from the NixOS Copenhagen User Group, March+ meetup: <https://www.meetup.com/nixos-copenhagen-user-group/events/313205865/>++* There is a `BUG` when trying to print emojii's ('🍎', '🍏', …):+ ```shell+ <stdout>: hPutChar: invalid argument (cannot encode character '\55357'+ ``` ## 0 -- 2026-02-25
− LICENSE
@@ -1,661 +0,0 @@- GNU AFFERO GENERAL PUBLIC LICENSE- Version 3, 19 November 2007-- Copyright (C) 2007 Free Software Foundation, Inc. <https://fsf.org/>- Everyone is permitted to copy and distribute verbatim copies- of this license document, but changing it is not allowed.-- Preamble-- The GNU Affero General Public License is a free, copyleft license for-software and other kinds of works, specifically designed to ensure-cooperation with the community in the case of network server software.-- The licenses for most software and other practical works are designed-to take away your freedom to share and change the works. By contrast,-our General Public Licenses are intended to guarantee your freedom to-share and change all versions of a program--to make sure it remains free-software for all its users.-- When we speak of free software, we are referring to freedom, not-price. Our General Public Licenses are designed to make sure that you-have the freedom to distribute copies of free software (and charge for-them if you wish), that you receive source code or can get it if you-want it, that you can change the software or use pieces of it in new-free programs, and that you know you can do these things.-- Developers that use our General Public Licenses protect your rights-with two steps: (1) assert copyright on the software, and (2) offer-you this License which gives you legal permission to copy, distribute-and/or modify the software.-- A secondary benefit of defending all users' freedom is that-improvements made in alternate versions of the program, if they-receive widespread use, become available for other developers to-incorporate. Many developers of free software are heartened and-encouraged by the resulting cooperation. However, in the case of-software used on network servers, this result may fail to come about.-The GNU General Public License permits making a modified version and-letting the public access it on a server without ever releasing its-source code to the public.-- The GNU Affero General Public License is designed specifically to-ensure that, in such cases, the modified source code becomes available-to the community. It requires the operator of a network server to-provide the source code of the modified version running there to the-users of that server. Therefore, public use of a modified version, on-a publicly accessible server, gives the public access to the source-code of the modified version.-- An older license, called the Affero General Public License and-published by Affero, was designed to accomplish similar goals. This is-a different license, not a version of the Affero GPL, but Affero has-released a new version of the Affero GPL which permits relicensing under-this license.-- The precise terms and conditions for copying, distribution and-modification follow.-- TERMS AND CONDITIONS-- 0. Definitions.-- "This License" refers to version 3 of the GNU Affero General Public License.-- "Copyright" also means copyright-like laws that apply to other kinds of-works, such as semiconductor masks.-- "The Program" refers to any copyrightable work licensed under this-License. Each licensee is addressed as "you". "Licensees" and-"recipients" may be individuals or organizations.-- To "modify" a work means to copy from or adapt all or part of the work-in a fashion requiring copyright permission, other than the making of an-exact copy. The resulting work is called a "modified version" of the-earlier work or a work "based on" the earlier work.-- A "covered work" means either the unmodified Program or a work based-on the Program.-- To "propagate" a work means to do anything with it that, without-permission, would make you directly or secondarily liable for-infringement under applicable copyright law, except executing it on a-computer or modifying a private copy. Propagation includes copying,-distribution (with or without modification), making available to the-public, and in some countries other activities as well.-- To "convey" a work means any kind of propagation that enables other-parties to make or receive copies. Mere interaction with a user through-a computer network, with no transfer of a copy, is not conveying.-- An interactive user interface displays "Appropriate Legal Notices"-to the extent that it includes a convenient and prominently visible-feature that (1) displays an appropriate copyright notice, and (2)-tells the user that there is no warranty for the work (except to the-extent that warranties are provided), that licensees may convey the-work under this License, and how to view a copy of this License. If-the interface presents a list of user commands or options, such as a-menu, a prominent item in the list meets this criterion.-- 1. Source Code.-- The "source code" for a work means the preferred form of the work-for making modifications to it. "Object code" means any non-source-form of a work.-- A "Standard Interface" means an interface that either is an official-standard defined by a recognized standards body, or, in the case of-interfaces specified for a particular programming language, one that-is widely used among developers working in that language.-- The "System Libraries" of an executable work include anything, other-than the work as a whole, that (a) is included in the normal form of-packaging a Major Component, but which is not part of that Major-Component, and (b) serves only to enable use of the work with that-Major Component, or to implement a Standard Interface for which an-implementation is available to the public in source code form. A-"Major Component", in this context, means a major essential component-(kernel, window system, and so on) of the specific operating system-(if any) on which the executable work runs, or a compiler used to-produce the work, or an object code interpreter used to run it.-- The "Corresponding Source" for a work in object code form means all-the source code needed to generate, install, and (for an executable-work) run the object code and to modify the work, including scripts to-control those activities. However, it does not include the work's-System Libraries, or general-purpose tools or generally available free-programs which are used unmodified in performing those activities but-which are not part of the work. For example, Corresponding Source-includes interface definition files associated with source files for-the work, and the source code for shared libraries and dynamically-linked subprograms that the work is specifically designed to require,-such as by intimate data communication or control flow between those-subprograms and other parts of the work.-- The Corresponding Source need not include anything that users-can regenerate automatically from other parts of the Corresponding-Source.-- The Corresponding Source for a work in source code form is that-same work.-- 2. Basic Permissions.-- All rights granted under this License are granted for the term of-copyright on the Program, and are irrevocable provided the stated-conditions are met. This License explicitly affirms your unlimited-permission to run the unmodified Program. The output from running a-covered work is covered by this License only if the output, given its-content, constitutes a covered work. This License acknowledges your-rights of fair use or other equivalent, as provided by copyright law.-- You may make, run and propagate covered works that you do not-convey, without conditions so long as your license otherwise remains-in force. You may convey covered works to others for the sole purpose-of having them make modifications exclusively for you, or provide you-with facilities for running those works, provided that you comply with-the terms of this License in conveying all material for which you do-not control copyright. Those thus making or running the covered works-for you must do so exclusively on your behalf, under your direction-and control, on terms that prohibit them from making any copies of-your copyrighted material outside their relationship with you.-- Conveying under any other circumstances is permitted solely under-the conditions stated below. Sublicensing is not allowed; section 10-makes it unnecessary.-- 3. Protecting Users' Legal Rights From Anti-Circumvention Law.-- No covered work shall be deemed part of an effective technological-measure under any applicable law fulfilling obligations under article-11 of the WIPO copyright treaty adopted on 20 December 1996, or-similar laws prohibiting or restricting circumvention of such-measures.-- When you convey a covered work, you waive any legal power to forbid-circumvention of technological measures to the extent such circumvention-is effected by exercising rights under this License with respect to-the covered work, and you disclaim any intention to limit operation or-modification of the work as a means of enforcing, against the work's-users, your or third parties' legal rights to forbid circumvention of-technological measures.-- 4. Conveying Verbatim Copies.-- You may convey verbatim copies of the Program's source code as you-receive it, in any medium, provided that you conspicuously and-appropriately publish on each copy an appropriate copyright notice;-keep intact all notices stating that this License and any-non-permissive terms added in accord with section 7 apply to the code;-keep intact all notices of the absence of any warranty; and give all-recipients a copy of this License along with the Program.-- You may charge any price or no price for each copy that you convey,-and you may offer support or warranty protection for a fee.-- 5. Conveying Modified Source Versions.-- You may convey a work based on the Program, or the modifications to-produce it from the Program, in the form of source code under the-terms of section 4, provided that you also meet all of these conditions:-- a) The work must carry prominent notices stating that you modified- it, and giving a relevant date.-- b) The work must carry prominent notices stating that it is- released under this License and any conditions added under section- 7. This requirement modifies the requirement in section 4 to- "keep intact all notices".-- c) You must license the entire work, as a whole, under this- License to anyone who comes into possession of a copy. This- License will therefore apply, along with any applicable section 7- additional terms, to the whole of the work, and all its parts,- regardless of how they are packaged. This License gives no- permission to license the work in any other way, but it does not- invalidate such permission if you have separately received it.-- d) If the work has interactive user interfaces, each must display- Appropriate Legal Notices; however, if the Program has interactive- interfaces that do not display Appropriate Legal Notices, your- work need not make them do so.-- A compilation of a covered work with other separate and independent-works, which are not by their nature extensions of the covered work,-and which are not combined with it such as to form a larger program,-in or on a volume of a storage or distribution medium, is called an-"aggregate" if the compilation and its resulting copyright are not-used to limit the access or legal rights of the compilation's users-beyond what the individual works permit. Inclusion of a covered work-in an aggregate does not cause this License to apply to the other-parts of the aggregate.-- 6. Conveying Non-Source Forms.-- You may convey a covered work in object code form under the terms-of sections 4 and 5, provided that you also convey the-machine-readable Corresponding Source under the terms of this License,-in one of these ways:-- a) Convey the object code in, or embodied in, a physical product- (including a physical distribution medium), accompanied by the- Corresponding Source fixed on a durable physical medium- customarily used for software interchange.-- b) Convey the object code in, or embodied in, a physical product- (including a physical distribution medium), accompanied by a- written offer, valid for at least three years and valid for as- long as you offer spare parts or customer support for that product- model, to give anyone who possesses the object code either (1) a- copy of the Corresponding Source for all the software in the- product that is covered by this License, on a durable physical- medium customarily used for software interchange, for a price no- more than your reasonable cost of physically performing this- conveying of source, or (2) access to copy the- Corresponding Source from a network server at no charge.-- c) Convey individual copies of the object code with a copy of the- written offer to provide the Corresponding Source. This- alternative is allowed only occasionally and noncommercially, and- only if you received the object code with such an offer, in accord- with subsection 6b.-- d) Convey the object code by offering access from a designated- place (gratis or for a charge), and offer equivalent access to the- Corresponding Source in the same way through the same place at no- further charge. You need not require recipients to copy the- Corresponding Source along with the object code. If the place to- copy the object code is a network server, the Corresponding Source- may be on a different server (operated by you or a third party)- that supports equivalent copying facilities, provided you maintain- clear directions next to the object code saying where to find the- Corresponding Source. Regardless of what server hosts the- Corresponding Source, you remain obligated to ensure that it is- available for as long as needed to satisfy these requirements.-- e) Convey the object code using peer-to-peer transmission, provided- you inform other peers where the object code and Corresponding- Source of the work are being offered to the general public at no- charge under subsection 6d.-- A separable portion of the object code, whose source code is excluded-from the Corresponding Source as a System Library, need not be-included in conveying the object code work.-- A "User Product" is either (1) a "consumer product", which means any-tangible personal property which is normally used for personal, family,-or household purposes, or (2) anything designed or sold for incorporation-into a dwelling. In determining whether a product is a consumer product,-doubtful cases shall be resolved in favor of coverage. For a particular-product received by a particular user, "normally used" refers to a-typical or common use of that class of product, regardless of the status-of the particular user or of the way in which the particular user-actually uses, or expects or is expected to use, the product. A product-is a consumer product regardless of whether the product has substantial-commercial, industrial or non-consumer uses, unless such uses represent-the only significant mode of use of the product.-- "Installation Information" for a User Product means any methods,-procedures, authorization keys, or other information required to install-and execute modified versions of a covered work in that User Product from-a modified version of its Corresponding Source. The information must-suffice to ensure that the continued functioning of the modified object-code is in no case prevented or interfered with solely because-modification has been made.-- If you convey an object code work under this section in, or with, or-specifically for use in, a User Product, and the conveying occurs as-part of a transaction in which the right of possession and use of the-User Product is transferred to the recipient in perpetuity or for a-fixed term (regardless of how the transaction is characterized), the-Corresponding Source conveyed under this section must be accompanied-by the Installation Information. But this requirement does not apply-if neither you nor any third party retains the ability to install-modified object code on the User Product (for example, the work has-been installed in ROM).-- The requirement to provide Installation Information does not include a-requirement to continue to provide support service, warranty, or updates-for a work that has been modified or installed by the recipient, or for-the User Product in which it has been modified or installed. Access to a-network may be denied when the modification itself materially and-adversely affects the operation of the network or violates the rules and-protocols for communication across the network.-- Corresponding Source conveyed, and Installation Information provided,-in accord with this section must be in a format that is publicly-documented (and with an implementation available to the public in-source code form), and must require no special password or key for-unpacking, reading or copying.-- 7. Additional Terms.-- "Additional permissions" are terms that supplement the terms of this-License by making exceptions from one or more of its conditions.-Additional permissions that are applicable to the entire Program shall-be treated as though they were included in this License, to the extent-that they are valid under applicable law. If additional permissions-apply only to part of the Program, that part may be used separately-under those permissions, but the entire Program remains governed by-this License without regard to the additional permissions.-- When you convey a copy of a covered work, you may at your option-remove any additional permissions from that copy, or from any part of-it. (Additional permissions may be written to require their own-removal in certain cases when you modify the work.) You may place-additional permissions on material, added by you to a covered work,-for which you have or can give appropriate copyright permission.-- Notwithstanding any other provision of this License, for material you-add to a covered work, you may (if authorized by the copyright holders of-that material) supplement the terms of this License with terms:-- a) Disclaiming warranty or limiting liability differently from the- terms of sections 15 and 16 of this License; or-- b) Requiring preservation of specified reasonable legal notices or- author attributions in that material or in the Appropriate Legal- Notices displayed by works containing it; or-- c) Prohibiting misrepresentation of the origin of that material, or- requiring that modified versions of such material be marked in- reasonable ways as different from the original version; or-- d) Limiting the use for publicity purposes of names of licensors or- authors of the material; or-- e) Declining to grant rights under trademark law for use of some- trade names, trademarks, or service marks; or-- f) Requiring indemnification of licensors and authors of that- material by anyone who conveys the material (or modified versions of- it) with contractual assumptions of liability to the recipient, for- any liability that these contractual assumptions directly impose on- those licensors and authors.-- All other non-permissive additional terms are considered "further-restrictions" within the meaning of section 10. If the Program as you-received it, or any part of it, contains a notice stating that it is-governed by this License along with a term that is a further-restriction, you may remove that term. If a license document contains-a further restriction but permits relicensing or conveying under this-License, you may add to a covered work material governed by the terms-of that license document, provided that the further restriction does-not survive such relicensing or conveying.-- If you add terms to a covered work in accord with this section, you-must place, in the relevant source files, a statement of the-additional terms that apply to those files, or a notice indicating-where to find the applicable terms.-- Additional terms, permissive or non-permissive, may be stated in the-form of a separately written license, or stated as exceptions;-the above requirements apply either way.-- 8. Termination.-- You may not propagate or modify a covered work except as expressly-provided under this License. Any attempt otherwise to propagate or-modify it is void, and will automatically terminate your rights under-this License (including any patent licenses granted under the third-paragraph of section 11).-- However, if you cease all violation of this License, then your-license from a particular copyright holder is reinstated (a)-provisionally, unless and until the copyright holder explicitly and-finally terminates your license, and (b) permanently, if the copyright-holder fails to notify you of the violation by some reasonable means-prior to 60 days after the cessation.-- Moreover, your license from a particular copyright holder is-reinstated permanently if the copyright holder notifies you of the-violation by some reasonable means, this is the first time you have-received notice of violation of this License (for any work) from that-copyright holder, and you cure the violation prior to 30 days after-your receipt of the notice.-- Termination of your rights under this section does not terminate the-licenses of parties who have received copies or rights from you under-this License. If your rights have been terminated and not permanently-reinstated, you do not qualify to receive new licenses for the same-material under section 10.-- 9. Acceptance Not Required for Having Copies.-- You are not required to accept this License in order to receive or-run a copy of the Program. Ancillary propagation of a covered work-occurring solely as a consequence of using peer-to-peer transmission-to receive a copy likewise does not require acceptance. However,-nothing other than this License grants you permission to propagate or-modify any covered work. These actions infringe copyright if you do-not accept this License. Therefore, by modifying or propagating a-covered work, you indicate your acceptance of this License to do so.-- 10. Automatic Licensing of Downstream Recipients.-- Each time you convey a covered work, the recipient automatically-receives a license from the original licensors, to run, modify and-propagate that work, subject to this License. You are not responsible-for enforcing compliance by third parties with this License.-- An "entity transaction" is a transaction transferring control of an-organization, or substantially all assets of one, or subdividing an-organization, or merging organizations. If propagation of a covered-work results from an entity transaction, each party to that-transaction who receives a copy of the work also receives whatever-licenses to the work the party's predecessor in interest had or could-give under the previous paragraph, plus a right to possession of the-Corresponding Source of the work from the predecessor in interest, if-the predecessor has it or can get it with reasonable efforts.-- You may not impose any further restrictions on the exercise of the-rights granted or affirmed under this License. For example, you may-not impose a license fee, royalty, or other charge for exercise of-rights granted under this License, and you may not initiate litigation-(including a cross-claim or counterclaim in a lawsuit) alleging that-any patent claim is infringed by making, using, selling, offering for-sale, or importing the Program or any portion of it.-- 11. Patents.-- A "contributor" is a copyright holder who authorizes use under this-License of the Program or a work on which the Program is based. The-work thus licensed is called the contributor's "contributor version".-- A contributor's "essential patent claims" are all patent claims-owned or controlled by the contributor, whether already acquired or-hereafter acquired, that would be infringed by some manner, permitted-by this License, of making, using, or selling its contributor version,-but do not include claims that would be infringed only as a-consequence of further modification of the contributor version. For-purposes of this definition, "control" includes the right to grant-patent sublicenses in a manner consistent with the requirements of-this License.-- Each contributor grants you a non-exclusive, worldwide, royalty-free-patent license under the contributor's essential patent claims, to-make, use, sell, offer for sale, import and otherwise run, modify and-propagate the contents of its contributor version.-- In the following three paragraphs, a "patent license" is any express-agreement or commitment, however denominated, not to enforce a patent-(such as an express permission to practice a patent or covenant not to-sue for patent infringement). To "grant" such a patent license to a-party means to make such an agreement or commitment not to enforce a-patent against the party.-- If you convey a covered work, knowingly relying on a patent license,-and the Corresponding Source of the work is not available for anyone-to copy, free of charge and under the terms of this License, through a-publicly available network server or other readily accessible means,-then you must either (1) cause the Corresponding Source to be so-available, or (2) arrange to deprive yourself of the benefit of the-patent license for this particular work, or (3) arrange, in a manner-consistent with the requirements of this License, to extend the patent-license to downstream recipients. "Knowingly relying" means you have-actual knowledge that, but for the patent license, your conveying the-covered work in a country, or your recipient's use of the covered work-in a country, would infringe one or more identifiable patents in that-country that you have reason to believe are valid.-- If, pursuant to or in connection with a single transaction or-arrangement, you convey, or propagate by procuring conveyance of, a-covered work, and grant a patent license to some of the parties-receiving the covered work authorizing them to use, propagate, modify-or convey a specific copy of the covered work, then the patent license-you grant is automatically extended to all recipients of the covered-work and works based on it.-- A patent license is "discriminatory" if it does not include within-the scope of its coverage, prohibits the exercise of, or is-conditioned on the non-exercise of one or more of the rights that are-specifically granted under this License. You may not convey a covered-work if you are a party to an arrangement with a third party that is-in the business of distributing software, under which you make payment-to the third party based on the extent of your activity of conveying-the work, and under which the third party grants, to any of the-parties who would receive the covered work from you, a discriminatory-patent license (a) in connection with copies of the covered work-conveyed by you (or copies made from those copies), or (b) primarily-for and in connection with specific products or compilations that-contain the covered work, unless you entered into that arrangement,-or that patent license was granted, prior to 28 March 2007.-- Nothing in this License shall be construed as excluding or limiting-any implied license or other defenses to infringement that may-otherwise be available to you under applicable patent law.-- 12. No Surrender of Others' Freedom.-- If conditions are imposed on you (whether by court order, agreement or-otherwise) that contradict the conditions of this License, they do not-excuse you from the conditions of this License. If you cannot convey a-covered work so as to satisfy simultaneously your obligations under this-License and any other pertinent obligations, then as a consequence you may-not convey it at all. For example, if you agree to terms that obligate you-to collect a royalty for further conveying from those to whom you convey-the Program, the only way you could satisfy both those terms and this-License would be to refrain entirely from conveying the Program.-- 13. Remote Network Interaction; Use with the GNU General Public License.-- Notwithstanding any other provision of this License, if you modify the-Program, your modified version must prominently offer all users-interacting with it remotely through a computer network (if your version-supports such interaction) an opportunity to receive the Corresponding-Source of your version by providing access to the Corresponding Source-from a network server at no charge, through some standard or customary-means of facilitating copying of software. This Corresponding Source-shall include the Corresponding Source for any work covered by version 3-of the GNU General Public License that is incorporated pursuant to the-following paragraph.-- Notwithstanding any other provision of this License, you have-permission to link or combine any covered work with a work licensed-under version 3 of the GNU General Public License into a single-combined work, and to convey the resulting work. The terms of this-License will continue to apply to the part which is the covered work,-but the work with which it is combined will remain governed by version-3 of the GNU General Public License.-- 14. Revised Versions of this License.-- The Free Software Foundation may publish revised and/or new versions of-the GNU Affero General Public License from time to time. Such new versions-will be similar in spirit to the present version, but may differ in detail to-address new problems or concerns.-- Each version is given a distinguishing version number. If the-Program specifies that a certain numbered version of the GNU Affero General-Public License "or any later version" applies to it, you have the-option of following the terms and conditions either of that numbered-version or of any later version published by the Free Software-Foundation. If the Program does not specify a version number of the-GNU Affero General Public License, you may choose any version ever published-by the Free Software Foundation.-- If the Program specifies that a proxy can decide which future-versions of the GNU Affero General Public License can be used, that proxy's-public statement of acceptance of a version permanently authorizes you-to choose that version for the Program.-- Later license versions may give you additional or different-permissions. However, no additional obligations are imposed on any-author or copyright holder as a result of your choosing to follow a-later version.-- 15. Disclaimer of Warranty.-- THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY-APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT-HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY-OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,-THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR-PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM-IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF-ALL NECESSARY SERVICING, REPAIR OR CORRECTION.-- 16. Limitation of Liability.-- IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING-WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS-THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY-GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE-USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF-DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD-PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),-EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF-SUCH DAMAGES.-- 17. Interpretation of Sections 15 and 16.-- If the disclaimer of warranty and limitation of liability provided-above cannot be given local legal effect according to their terms,-reviewing courts shall apply local law that most closely approximates-an absolute waiver of all civil liability in connection with the-Program, unless a warranty or assumption of liability accompanies a-copy of the Program in return for a fee.-- END OF TERMS AND CONDITIONS-- How to Apply These Terms to Your New Programs-- If you develop a new program, and you want it to be of the greatest-possible use to the public, the best way to achieve this is to make it-free software which everyone can redistribute and change under these terms.-- To do so, attach the following notices to the program. It is safest-to attach them to the start of each source file to most effectively-state the exclusion of warranty; and each file should have at least-the "copyright" line and a pointer to where the full notice is found.-- <one line to give the program's name and a brief idea of what it does.>- Copyright (C) <year> <name of author>-- This program is free software: you can redistribute it and/or modify- it under the terms of the GNU Affero General Public License as published by- the Free Software Foundation, either version 3 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU Affero General Public License for more details.-- You should have received a copy of the GNU Affero General Public License- along with this program. If not, see <https://www.gnu.org/licenses/>.--Also add information on how to contact you by electronic and paper mail.-- If your software can interact with users remotely through a computer-network, you should also make sure that it provides a way for users to-get its source. For example, if your program is a web application, its-interface could display a "Source" link that leads users to an archive-of the code. There are many ways you could offer source, and different-solutions will be better for different programs; see section 13 for the-specific requirements.-- You should also get your employer (if you work as a programmer) or school,-if any, to sign a "copyright disclaimer" for the program, if necessary.-For more information on this, and how to apply and follow the GNU AGPL, see-<https://www.gnu.org/licenses/>.
+ LICENSE.md view
@@ -0,0 +1,29 @@+License+=======++Source code in this repository is ONLY covered by a [**Server Side Public+License, v1 (SSPL-1.0)**][spdx-sspl-1].++However, as `SSPL-1.0` is not approved by the [Free Software Foundation+(FSF)][fsf] nor the [Open Source Initiative (OSI)][osi] as an open source+license (yet), the package will therefore be dual-licensed under the [**GNU+Affero General Public License v3.0 only (AGPL-3.0-only)**][spdx-agpl-3o] as well+so the [Hackage][hackage-osl] operators don't have any conflict with their+ability to operate the service.++Local versions of each of the licenses can be seen at:++* [**Server Side Public License, v1 (SSPL-1.0)**][local-sspl-1]++* [**GNU Affero General Public License v3.0 only+(AGPL-3.0-only)**][local-agpl-3o]++[spdx-sspl-1]: https://spdx.org/licenses/SSPL-1.0+[spdx-agpl-3o]: https://spdx.org/licenses/AGPL-3.0-only+[hackage-osl]: https://hackage.haskell.org/upload++[fsf]: https://www.fsf.org/+[osi]: https://opensource.org/++[local-sspl-1]: ./LICENSE_SSPL-1.0.txt+[local-agpl-3o]: ./LICENSE_AGPL-3.0-only.txt
README.md view
@@ -3,7 +3,55 @@ [](https://hackage.haskell.org/package/A-gent) -This package provides spiritual equivalents to rust's `todo!` and `unimplemented!` macros.+`Λ-gent`, pronounced «_**a gent**_», where the **capital lambda** (`Λ`) is a+replacement of the letter `A` in **agent** due to their similarities and [lambda+calculus][lambda-calculus-wiki] being the backbone of [Haskell][haskell] and+`nix` {[language][nix-lang] | [package manager][nix-pkg-man] |+[command][nix-cmd]} / [NixOS][nix-nixOS]. -Based placeholder definitions for TODO and unimplemented code:-<https://hackage.haskell.org/package/placeholder>.+With the substitution, we are now left with the word [gent][oxford-gent], the+abbreviation of [gentleman][oxford-gentleman], which will help us define our+[LLM][llm-wiki] **agent** as:++> _«Polite, well **educated**, has excellent manners and **always** behaves+> well»_++[haskell]: https://www.haskell.org/+[nix-lang]: https://wiki.nixos.org/wiki/Nix_(language)+[nix-pkg-man]: https://wiki.nixos.org/wiki/Nix_(package_manager)+[nix-cmd]: https://wiki.nixos.org/wiki/Nix_(command)+[nix-nixOS]: https://wiki.nixos.org/wiki/NixOS+[lambda-calculus-wiki]: https://en.wikipedia.org/wiki/Lambda_calculus+[oxford-gent]: https://www.oxfordlearnersdictionaries.com/definition/english/gent+[oxford-gentleman]: https://www.oxfordlearnersdictionaries.com/definition/english/gentleman+[llm-wiki]: https://en.wikipedia.org/wiki/Large_language_model++License+=======++Source code in this repository is ONLY covered by a [**Server Side Public+License, v1 (SSPL-1.0)**][spdx-sspl-1].++However, as `SSPL-1.0` is not approved by the [Free Software Foundation+(FSF)][fsf] nor the [Open Source Initiative (OSI)][osi] as an open source+license (yet), the package will therefore be dual-licensed under the [**GNU+Affero General Public License v3.0 only (AGPL-3.0-only)**][spdx-agpl-3o] as well+so the [Hackage][hackage-osl] operators don't have any conflict with their+ability to operate the service.++Local versions of each of the licenses can be seen at:++* [**Server Side Public License, v1 (SSPL-1.0)**][local-sspl-1]++* [**GNU Affero General Public License v3.0 only+(AGPL-3.0-only)**][local-agpl-3o]++[spdx-sspl-1]: https://spdx.org/licenses/SSPL-1.0+[spdx-agpl-3o]: https://spdx.org/licenses/AGPL-3.0-only+[hackage-osl]: https://hackage.haskell.org/upload++[fsf]: https://www.fsf.org/+[osi]: https://opensource.org/++[local-sspl-1]: ./LICENSE_SSPL-1.0.txt+[local-agpl-3o]: ./LICENSE_AGPL-3.0-only.txt
+ src/Agent/Control/IFC.hs view
@@ -0,0 +1,81 @@+{-# OPTIONS_GHC -Wall -Werror #-}++{-# LANGUAGE Safe #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}++{-# LANGUAGE MultiParamTypeClasses #-}++--------------------------------------------------------------------------------++-- |+-- Copyright : (c) 2026 SPISE MISU ApS+-- License : SSPL-1.0 OR AGPL-3.0-only+-- Maintainer : SPISE MISU <mail+hackage@spisemisu.com>+-- Stability : experimental+--+-- Information Flow Control (IFC)+--+-- https://en.wikipedia.org/wiki/Information_flow_(information_theory)+--+-- In low level information flow analysis, each variable is usually assigned a+-- security level. The basic model comprises two distinct levels: low and high,+-- meaning, respectively, publicly observable information, and secret+-- information. To ensure confidentiality, flowing information from high to low+-- variables should not be allowed. On the other hand, to ensure integrity,+-- flows to high variables should be restricted.[1]+--+-- More generally, the security levels can be viewed as a lattice with+-- information flowing only upwards in the lattice.[2]+--+-- For example, considering two security levels `L` and `H` (low and high), if+-- `L ≤ H`, flows from `L` to `L`, from `H` to `H`, and `L` to `H` would be+-- allowed, while flows from `H` to `L` would not.[3]+--+-- Throughout this article, the following notation is used:+--+-- a) variable `l ∈ L` (low) shall denote a publicly observable variable+--+-- b) variable `h ∈ H` (high) shall denote a secret variable+--+-- Where `L` and `H` are the only two security levels in the lattice being+-- considered.+--+-- [1] Andrei Sabelfeld and Andrew C. Myers. Language-Based Information-Flow+-- Security. IEEE Journal on Selected Areas in Communications, 21(1), Jan. 2003.+--+-- [2] Dorothy Denning. A lattice model of secure information+-- flow. Communications of the ACM, 19(5):236-242, 1976.+--+-- [3] Smith, Geoffrey (2007). "Principles of Secure Information Flow+-- Analysis". Advances in Information Security. 27. Springer US. pp. 291–307.++--------------------------------------------------------------------------------++module Agent.Control.IFC+ ( Flow+ -- * Observable variables+ , L+ , H+ )+where++--------------------------------------------------------------------------------++data L -- (low) denote a publicly observable variable+data H -- (high) denote a secret non-observable variable++--------------------------------------------------------------------------------++class Lattice a b++instance Lattice L L+instance Lattice L H+instance Lattice H H++--------------------------------------------------------------------------------++class Lattice a b => Flow a b++instance Flow L L+instance Flow L H+instance Flow H H
+ src/Agent/Control/MAC.hs view
@@ -0,0 +1,155 @@+{-# OPTIONS_GHC -Wall -Werror #-}++{-# LANGUAGE Safe #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}++--------------------------------------------------------------------------------++-- |+-- Copyright : (c) 2026 SPISE MISU ApS+-- License : SSPL-1.0 OR AGPL-3.0-only+-- Maintainer : SPISE MISU <mail+hackage@spisemisu.com>+-- Stability : experimental+--+-- Mandatory Access Control (MAC)+--+-- https://en.wikipedia.org/wiki/Mandatory_access_control+--+-- In computer security, mandatory access control (MAC) refers to a type of+-- access control by which the operating system or database constrains the+-- ability of a subject or initiator to access or generally perform some sort of+-- operation on an object or target.[1] In the case of operating systems, a+-- subject is usually a process or thread; objects are constructs such as files,+-- directories, TCP/UDP ports, shared memory segments, IO devices, etc. Subjects+-- and objects each have a set of security attributes. Whenever a subject+-- attempts to access an object, an authorization rule enforced by the operating+-- system kernel examines these security attributes and decides whether the+-- access can take place. Any operation by any subject on any object is tested+-- against the set of authorization rules (aka policy) to determine if the+-- operation is allowed. A database management system, in its access control+-- mechanism, can also apply mandatory access control; in this case, the objects+-- are tables, views, procedures, etc.+--+-- With mandatory access control, this security policy is centrally controlled+-- by a security policy administrator; users do not have the ability to override+-- the policy and, for example, grant access to files that would otherwise be+-- restricted. By contrast, discretionary access control (DAC), which also+-- governs the ability of subjects to access objects, allows users the ability+-- to make policy decisions and/or assign security attributes. (The traditional+-- Unix system of users, groups, and read-write-execute permissions is an+-- example of DAC.) MAC-enabled systems allow policy administrators to implement+-- organization-wide security policies. Under MAC (and unlike DAC), users cannot+-- override or modify this policy, either accidentally or intentionally. This+-- allows security administrators to define a central policy that is guaranteed+-- (in principle) to be enforced for all users.+--+-- [1] Belim, S. V.; Belim, S. Yu. (December 2018). "Implementation of Mandatory+-- Access Control in Distributed Systems". Automatic Control and Computer+-- Sciences. 52 (8): 1124–1126. doi:10.3103/S0146411618080357. ISSN 0146-4116.++--------------------------------------------------------------------------------++module Agent.Control.MAC+ ( MAC (MAC, run)+ , UID (UID, uid)+ , RES (RES, res)+ , join+ , label+ , unlabel+ , value+ )+where++--------------------------------------------------------------------------------++import Control.Monad+ ( ap+ , liftM+ )++import Control.Exception+ ( Exception+ , SomeException+ )+import qualified Control.Exception as Ex++import Agent.Control.IFC+ ( Flow+ )++--------------------------------------------------------------------------------++newtype MAC p a = MAC { run :: IO a }++instance Monad (MAC p) where+ (>>=) m f = MAC $ run m >>= run . f++instance Applicative (MAC p) where+ pure = MAC . pure+ (<*>) = ap++instance Functor (MAC p) where+ fmap = liftM++--------------------------------------------------------------------------------++-- UID: Unique identifier+-- RES: Resource+-- LAB: Label++newtype UID a = UID { uid :: a }+newtype RES p a = RES { res :: a }+type LAB p a = RES p ( UID a )++--------------------------------------------------------------------------------++value+ :: LAB l a+ -> a+value =+ uid . res++label+ :: Flow l h+ => a+ -> MAC l (LAB h a)+label =+ aux . pure . UID+ where+ aux io = RES <$> MAC io++unlabel+ :: Flow l h+ => LAB l a+ -> MAC h a+unlabel =+ aux $ pure . uid+ where+ aux io = MAC . io . res++join+ :: Flow l h+ => MAC h a+ -> MAC l (LAB h a)+join m =+ (MAC . run) (aux m) >>= label+ where+ aux x = catch x throw++--------------------------------------------------------------------------------++-- HELPERS++throw+ :: SomeException+ -> MAC l a+throw =+ MAC . Ex.throw++catch+ :: Exception e+ => MAC l a+ -> (e -> MAC l a)+ -> MAC l a+catch (MAC io) f =+ MAC $ Ex.catch io $ run . f
+ src/Agent/IO/Effects.hs view
@@ -0,0 +1,30 @@+{-# OPTIONS_GHC -Wall -Werror #-}++{-# LANGUAGE Safe #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}++--------------------------------------------------------------------------------++-- |+-- Copyright : (c) 2026 SPISE MISU ApS+-- License : SSPL-1.0 OR AGPL-3.0-only+-- Maintainer : SPISE MISU <mail+hackage@spisemisu.com>+-- Stability : experimental++--------------------------------------------------------------------------------++module Agent.IO.Effects+ ( -- * LLM+ LlmChatConf(llmChatKey, llmChatAPI)+ , LlmChatCurl(llmChatCurl)+ )+where++--------------------------------------------------------------------------------++class Monad m => LlmChatConf m where+ llmChatAPI :: m (Maybe String)+ llmChatKey :: m (Maybe String)++class LlmChatConf m => LlmChatCurl m where+ llmChatCurl :: String -> m (Either String String)
+ src/Agent/IO/Restricted.hs view
@@ -0,0 +1,188 @@+{-# OPTIONS_GHC -Wall -Werror #-}++{-# LANGUAGE Safe #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}++{-# LANGUAGE LambdaCase #-}++{-# LANGUAGE MonoLocalBinds #-}++--------------------------------------------------------------------------------++-- |+-- Copyright : (c) 2026 SPISE MISU ApS+-- License : SSPL-1.0 OR AGPL-3.0-only+-- Maintainer : SPISE MISU <mail+hackage@spisemisu.com>+-- Stability : experimental+--+-- Safe {H}askell+--+-- https://simonmar.github.io/bib/safe-haskell-2012_abstract.html+--+-- (David Terei, David Mazières, Simon Marlow, Simon Peyton Jones) Haskell ’12:+-- Proceedings of the Fifth ACM SIGPLAN Symposium on Haskell, Copenhagen,+-- Denmark, ACM, 2012+--+-- Though Haskell is predominantly type-safe, implementations contain a few+-- loopholes through which code can bypass typing and module encapsulation. This+-- paper presents Safe Haskell, a language extension that closes these+-- loopholes. Safe Haskell makes it possible to confine and safely execute+-- untrusted, possibly malicious code. By strictly enforcing types, Safe Haskell+-- allows a variety of different policies from API sandboxing to+-- information-flow control to be implemented easily as monads. Safe Haskell is+-- aimed to be as unobtrusive as possible. It enforces properties that+-- programmers tend to meet already by convention. We describe the design of+-- Safe Haskell and an implementation (currently shipping with GHC) that infers+-- safety for code that lies in a safe subset of the language. We use Safe+-- Haskell to implement an online Haskell interpreter that can securely execute+-- arbitrary untrusted code with no overhead. The use of Safe Haskell greatly+-- simplifies this task and allows the use of a large body of existing code and+-- tools.++--------------------------------------------------------------------------------++module Agent.IO.Restricted+ ( RIO ()+ , run+ -- * Environment+ , getEnvVar+ -- * Read/Print+ , input+ , output+ -- * LLM (Chat)+ , llmChatKey, llmChatAPI+ , llmChatCurl+ -- * LLM (Code)+ )+where++--------------------------------------------------------------------------------++import qualified System.Environment.Blank as ENV+import System.IO+ {-+ ( hFlush, hPutStr, stdout+ , hSetEncoding+ , utf8+ )+ -}+ ( hFlush, stdout+ )+import System.Exit+ ( ExitCode+ ( ExitFailure+ , ExitSuccess+ )+ )+import System.Process+ ( readProcessWithExitCode+ )++import qualified Agent.IO.Effects as EFF++--------------------------------------------------------------------------------++newtype RIO a = RestrictedIO { run :: IO a }++instance Functor RIO where+ fmap f m = RestrictedIO $ f <$> run m++instance Applicative RIO where+ pure = RestrictedIO . pure+ (<*>) f m = RestrictedIO $ run f <*> run m++instance Monad RIO where+ (>>=) m f = RestrictedIO $ run m >>= run . f++--------------------------------------------------------------------------------++class StdIn m where+ input :: m String ++class StdOut m where+ output :: String -> m ()++instance StdIn RIO where+ input = RestrictedIO getLine++instance StdOut RIO where+ output x = RestrictedIO $+ {- BUG: Emojis can't be printed to console (UTF-16 "surrogate pairs")+ <stdout>: hPutChar: invalid argument (cannot encode character '\55357'+ hSetEncoding stdout utf8 >>+ hPutStr stdout x >>+ hFlush stdout+ -}+ putStr x >> hFlush stdout++--------------------------------------------------------------------------------++class SysEnv m where+ getEnvVar :: String -> m (Maybe String)++instance SysEnv RIO where+ getEnvVar = RestrictedIO . ENV.getEnv++--------------------------------------------------------------------------------++class ReadProc m where+ withExitCode :: String -> [String] -> m (Either String String)++instance ReadProc RIO where+ withExitCode app fs = RestrictedIO $+ do+ (exitcode, out, err) <- readProcessWithExitCode app fs []+ case exitcode of+ ExitSuccess ->+ return $ Right out+ ExitFailure _ ->+ return $ Left err++--------------------------------------------------------------------------------++class (EFF.LlmChatConf m, SysEnv m) => LlmChatConf m where+ llmChatAPI :: m (Maybe String)+ llmChatKey :: m (Maybe String)++instance (EFF.LlmChatConf RIO, SysEnv RIO) => LlmChatConf RIO where+ llmChatAPI = getEnvVar "LLM_CHAT_LOCALHOST_API"+ llmChatKey = pure Nothing++class (EFF.LlmChatConf m , ReadProc m) => LlmChatCurl m where+ llmChatCurl :: String -> m (Either String String)++instance (EFF.LlmChatConf RIO, ReadProc RIO) => LlmChatCurl RIO where+ llmChatCurl json =+ llmChatAPI >>= \ mapi ->+ llmChatKey >>= \ mkey ->+ case (mapi, mkey) of+ (Nothing, _ ) ->+ RestrictedIO $ pure $ Left "No API address was provided"+ (Just api, Nothing) ->+ ( \ case+ Right env -> Right env+ Left err -> Left err+ )+ <$> withExitCode "curl"+ [ "--silent"+ , "--show-error"+ , "--header" , "\"Content-Type: application/json; charset=utf-8\""+ , "--data" , json+ , api ++ "/chat/completions"+ ]+ (Just api, Just key) ->+ ( \ case+ Right env -> Right env+ Left err -> Left err+ )+ <$> withExitCode "curl" -- "echo" -- + [ "--silent"+ , "--show-error"+ , "--header" , "\"Authorization: \"" ++ key ++ "\" "+ , "--header" , "\"Content-Type: application/json; charset=utf-8\""+ , "--data" , json+ , api ++ "/chat/completions"+ ]
+ src/Agent/JSON.hs view
@@ -0,0 +1,66 @@+{-# OPTIONS_GHC -Wall -Werror #-}++{-# LANGUAGE Safe #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}++--------------------------------------------------------------------------------++-- |+-- Copyright : (c) 2026 SPISE MISU ApS+-- License : SSPL-1.0 OR AGPL-3.0-only+-- Maintainer : SPISE MISU <mail+hackage@spisemisu.com>+-- Stability : experimental++--------------------------------------------------------------------------------++module Agent.JSON+ ( -- * Infer JSON from Data+ Data+ -- * JSON Encoder/Decoder+ , DecodeError(InvalidJSON, DiffSchema)+ , encode+ , decode+ )+where++--------------------------------------------------------------------------------++import Data.Data+ ( Data+ )++import Internal.GaloisInc.Text.JSON.Generic+ ( Result(Error, Ok)+ , encodeJSON+ , fromJSON+ )+import Internal.GaloisInc.Text.JSON.String+ ( readJSValue+ , runGetJSON+ )++--------------------------------------------------------------------------------++data DecodeError+ = InvalidJSON+ | DiffSchema++--------------------------------------------------------------------------------++encode+ :: Data a+ => a+ -> String+encode = encodeJSON++decode+ :: Data a+ => String+ -> Either DecodeError a+decode json =+ case runGetJSON readJSValue json of+ Left _ -> Left InvalidJSON+ Right v ->+ case fromJSON v of+ Error _ -> Left DiffSchema+ Ok a -> Right a
src/Agent/LLM.hs view
@@ -1,35 +1,167 @@--------------------------------------------------------------------------------------- Λ-gent, (c) 2026 SPISE MISU ApS------------------------------------------------------------------------------------- {-# OPTIONS_GHC -Wall -Werror #-} {-# LANGUAGE Safe #-} {-# LANGUAGE NoGeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-}+ -------------------------------------------------------------------------------- +-- |+-- Copyright : (c) 2026 SPISE MISU ApS+-- License : SSPL-1.0 OR AGPL-3.0-only+-- Maintainer : SPISE MISU <mail+hackage@spisemisu.com>+-- Stability : experimental+--+-- Polite and well educated LLM agent with excellent manners that always behaves+-- well.++--------------------------------------------------------------------------------+ module Agent.LLM- ( Mode(..)+ ( -- * Modes+ Mode(..)+ -- * Context+ , Load , Context(..)+ -- * Paramenters+ , Eval+ -- * Methods+ , repl+ , replWithMode ) where -------------------------------------------------------------------------------- +import Prelude hiding (head, mod, print, read)++import Data.Char+ ( toLower+ )+import System.IO+ ( BufferMode(NoBuffering)+ , hFlush, hSetBuffering, hSetEncoding+ , stderr, stdin, stdout+ , utf8+ )++import Agent.IO.Restricted+import Agent.JSON+ ( Data+ )++--------------------------------------------------------------------------------+ data Mode = Auto | Chat | Code | Docs+ | Echo | Plan | Test deriving (Bounded, Enum, Eq, Show) -data Context =+type Load a =+ Data a+ => Maybe a++data Context a = Context- { mode :: Mode- , quit :: Bool+ { exit :: Bool+ , mode :: Mode+ , load :: Load a }++type Eval a =+ Context a+ -> String+ -> RIO (Context a, String)++--------------------------------------------------------------------------------++repl+ :: Eval a+ -> IO ()+repl =+ replWithMode Chat++replWithMode+ :: Mode+ -> Eval a+ -> IO ()+replWithMode mod proc =+ do+ hSetBuffering stderr NoBuffering+ hSetBuffering stdin NoBuffering+ hSetBuffering stdout NoBuffering+ hSetEncoding stderr utf8+ hSetEncoding stdin utf8+ hSetEncoding stdout utf8+ putStrLn head >> hFlush stdout+ run $ loop ctx proc+ where+ ctx =+ Context+ { exit = False+ , mode = mod+ , load = Nothing+ }++--------------------------------------------------------------------------------++-- HELPERS++loop+ :: Context a+ -> Eval a+ -> RIO ()+loop ctx eval =+ if exit ctx then+ return ()+ else+ print prompt >>+ read >>= \ txt ->+ case txt of+ "/exit" ->+ printLn "Λ-gent will shutdown" >>+ loop (ctx { exit = True }) eval+ "/help" ->+ printLn help >>+ loop ctx eval+ "/mode chat" ->+ printLn "Changed to chat-mode" >>+ loop (ctx { mode = Chat }) eval+ "/mode code" ->+ printLn "Changed to code-mode" >>+ loop (ctx { mode = Code }) eval+ "/mode echo" ->+ printLn "Changed to echo-mode" >>+ loop (ctx { mode = Echo }) eval+ ____________ ->+ eval ctx txt >>= \ (upd, res) ->+ printLn res >>+ loop upd eval+ where+ prompt = "Λ-" ++ (map toLower $ show $ mode ctx) ++ "> "+ read = input+ print = output+ printLn = output . (++ "\n")++modes :: [Mode]+modes =+ [ minBound .. maxBound ]++head :: String+head =+ "# Quit Λ-gent with `/exit`. For more commands, type `/help`."++help :: String+help =+ "# Supported commands\n" +++ "* /help : This message\n" +++ "* /exit : Quit Λ-gent\n" +++ "* /mode : Change mode to {" ++ ms ++ "}`. Ex: `/mode code`\n"+ where+ ms = foldl1 (\ x y -> x ++ "|" ++ y) $ map (map toLower . show) modes
+ src/Internal/GaloisInc/Text/JSON.hs view
@@ -0,0 +1,537 @@+{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances #-}++{-# LANGUAGE Safe #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}++--------------------------------------------------------------------------------++-- |+-- Copyright : (c) 2007-2018 Galois Inc.+-- License : BSD-3-Clause+-- Maintainer : Iavor S. Diatchki (iavor.diatchki@gmail.com)+-- Stability : experimental+--+-- Serialising Haskell values to and from JSON values.++--------------------------------------------------------------------------------++module Internal.GaloisInc.Text.JSON (+ -- * JSON Types+ JSValue(..)++ -- * Serialization to and from JSValues+ , JSON(..)++ -- * Encoding and Decoding+ , Result(..)+ , encode -- :: JSON a => a -> String+ , decode -- :: JSON a => String -> Either String a+ , encodeStrict -- :: JSON a => a -> String+ , decodeStrict -- :: JSON a => String -> Either String a++ -- * Wrapper Types+ , JSString+ , toJSString+ , fromJSString++ , JSObject+ , toJSObject+ , fromJSObject+ , resultToEither++ -- * Serialization to and from Strings.+ -- ** Reading JSON+ , readJSNull, readJSBool, readJSString, readJSRational+ , readJSArray, readJSObject, readJSValue++ -- ** Writing JSON+ , showJSNull, showJSBool, showJSArray+ , showJSRational, showJSRational'+ , showJSObject, showJSValue++ -- ** Instance helpers+ , makeObj, valFromObj+ , JSKey(..), encJSDict, decJSDict+ + ) where++import Internal.GaloisInc.Text.JSON.Types+import Internal.GaloisInc.Text.JSON.String++import Data.Int+import Data.Word++{- NOTE: [GHC-66111] [-Wunused-imports] The import of `Control.Monad.Fail' is+ redundant++import Control.Monad.Fail (MonadFail (..))++-}++import Control.Monad(liftM,ap,MonadPlus(..))+import Control.Applicative++{- NOTE: Non-Safe++import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy.Char8 as L++-}++import qualified Data.IntSet as I+import qualified Data.Set as Set+import qualified Data.Map as M+import qualified Data.IntMap as IntMap++import qualified Data.Array as Array++{- NOTE: Non-Safe++import qualified Data.Text as T++-}++------------------------------------------------------------------------++-- | Decode a String representing a JSON value +-- (either an object, array, bool, number, null)+--+-- This is a superset of JSON, as types other than+-- Array and Object are allowed at the top level.+--+decode :: (JSON a) => String -> Result a+decode s = case runGetJSON readJSValue s of+ Right a -> readJSON a+ Left err -> Error err++-- | Encode a Haskell value into a string, in JSON format.+--+-- This is a superset of JSON, as types other than+-- Array and Object are allowed at the top level.+--+encode :: (JSON a) => a -> String+encode = (flip showJSValue [] . showJSON)++------------------------------------------------------------------------++-- | Decode a String representing a strict JSON value.+-- This follows the spec, and requires top level+-- JSON types to be an Array or Object.+decodeStrict :: (JSON a) => String -> Result a+decodeStrict s = case runGetJSON readJSTopType s of+ Right a -> readJSON a+ Left err -> Error err++-- | Encode a value as a String in strict JSON format.+-- This follows the spec, and requires all values+-- at the top level to be wrapped in either an Array or Object.+-- JSON types to be an Array or Object.+encodeStrict :: (JSON a) => a -> String+encodeStrict = (flip showJSTopType [] . showJSON)++------------------------------------------------------------------------++-- | The class of types serialisable to and from JSON+class JSON a where+ readJSON :: JSValue -> Result a+ showJSON :: a -> JSValue++ readJSONs :: JSValue -> Result [a]+ readJSONs (JSArray as) = mapM readJSON as+ readJSONs _ = mkError "Unable to read list"++ showJSONs :: [a] -> JSValue+ showJSONs = JSArray . map showJSON++-- | A type for parser results+data Result a = Ok a | Error String+ deriving (Eq,Show)++-- | Map Results to Eithers+resultToEither :: Result a -> Either String a+resultToEither (Ok a) = Right a+resultToEither (Error s) = Left s++instance Functor Result where fmap = liftM++{- NOTE: [GHC-22705] [-Wnoncanonical-monad-instances] Noncanonical `pure = return'+ definition detected in the instance declaration for `Applicative Result'.+ Suggested fix: Move definition from `return' to `pure'++instance Applicative Result where+ (<*>) = ap+ pure = return++-}++instance Applicative Result where+ pure x = Ok x+ (<*>) = ap++instance Alternative Result where+ Ok a <|> _ = Ok a+ Error _ <|> b = b+ empty = Error "empty"++instance MonadPlus Result where+ Ok a `mplus` _ = Ok a+ _ `mplus` x = x+ mzero = Error "Result: MonadPlus.empty"++{- NOTE: [GHC-22705] [-Wnoncanonical-monad-instances] Noncanonical `return'+ definition detected in the instance declaration for `Monad Result'. `return'+ will eventually be removed in favour of `pure' Suggested fix: Either remove+ definition for `return' (recommended) or define as `return = pure++instance Monad Result where+ return x = Ok x+ Ok a >>= f = f a+ Error x >>= _ = Error x++-}++instance Monad Result where+ Ok a >>= f = f a+ Error x >>= _ = Error x++instance MonadFail Result where+ fail x = Error x++-- | Convenient error generation+mkError :: String -> Result a+mkError s = Error s++--------------------------------------------------------------------+--+-- | To ensure we generate valid JSON, we map Haskell types to JSValue+-- internally, then pretty print that.+--+instance JSON JSValue where+ showJSON = id+ readJSON = return++second :: (a -> b) -> (x,a) -> (x,b)+second f (a,b) = (a, f b)++--------------------------------------------------------------------+-- Some simple JSON wrapper types, to avoid overlapping instances++instance JSON JSString where+ readJSON (JSString s) = return s+ readJSON _ = mkError "Unable to read JSString"+ showJSON = JSString++instance (JSON a) => JSON (JSObject a) where+ readJSON (JSObject o) =+ let f (x,y) = do y' <- readJSON y; return (x,y')+ in toJSObject `fmap` mapM f (fromJSObject o)+ readJSON _ = mkError "Unable to read JSObject"+ showJSON = JSObject . toJSObject . map (second showJSON) . fromJSObject+++-- -----------------------------------------------------------------+-- Instances+--++instance JSON Bool where+ showJSON = JSBool+ readJSON (JSBool b) = return b+ readJSON _ = mkError "Unable to read Bool"++instance JSON Char where+ showJSON = JSString . toJSString . (:[])+ showJSONs = JSString . toJSString++ readJSON (JSString s) = case fromJSString s of+ [c] -> return c+ _ -> mkError "Unable to read Char"+ readJSON _ = mkError "Unable to read Char"++ readJSONs (JSString s) = return (fromJSString s)+ readJSONs (JSArray a) = mapM readJSON a+ readJSONs _ = mkError "Unable to read String"++instance JSON Ordering where+ showJSON = encJSString show+ readJSON = decJSString "Ordering" readOrd+ where+ readOrd x = + case x of+ "LT" -> return Prelude.LT+ "EQ" -> return Prelude.EQ+ "GT" -> return Prelude.GT+ _ -> mkError ("Unable to read Ordering")++-- -----------------------------------------------------------------+-- Integral types++instance JSON Integer where+ showJSON = JSRational False . fromIntegral+ readJSON (JSRational _ i) = return $ round i+ readJSON _ = mkError "Unable to read Integer"++-- constrained:+instance JSON Int where+ showJSON = JSRational False . fromIntegral+ readJSON (JSRational _ i) = return $ round i+ readJSON _ = mkError "Unable to read Int"++-- constrained:+instance JSON Word where+ showJSON = JSRational False . toRational+ readJSON (JSRational _ i) = return $ truncate i+ readJSON _ = mkError "Unable to read Word"++-- -----------------------------------------------------------------++instance JSON Word8 where+ showJSON = JSRational False . fromIntegral+ readJSON (JSRational _ i) = return $ truncate i+ readJSON _ = mkError "Unable to read Word8"++instance JSON Word16 where+ showJSON = JSRational False . fromIntegral+ readJSON (JSRational _ i) = return $ truncate i+ readJSON _ = mkError "Unable to read Word16"++instance JSON Word32 where+ showJSON = JSRational False . fromIntegral+ readJSON (JSRational _ i) = return $ truncate i+ readJSON _ = mkError "Unable to read Word32"++instance JSON Word64 where+ showJSON = JSRational False . fromIntegral+ readJSON (JSRational _ i) = return $ truncate i+ readJSON _ = mkError "Unable to read Word64"++instance JSON Int8 where+ showJSON = JSRational False . fromIntegral+ readJSON (JSRational _ i) = return $ truncate i+ readJSON _ = mkError "Unable to read Int8"++instance JSON Int16 where+ showJSON = JSRational False . fromIntegral+ readJSON (JSRational _ i) = return $ truncate i+ readJSON _ = mkError "Unable to read Int16"++instance JSON Int32 where+ showJSON = JSRational False . fromIntegral+ readJSON (JSRational _ i) = return $ truncate i+ readJSON _ = mkError "Unable to read Int32"++instance JSON Int64 where+ showJSON = JSRational False . fromIntegral+ readJSON (JSRational _ i) = return $ truncate i+ readJSON _ = mkError "Unable to read Int64"++-- -----------------------------------------------------------------++instance JSON Double where+ showJSON = JSRational False . toRational+ readJSON (JSRational _ r) = return $ fromRational r+ readJSON _ = mkError "Unable to read Double"+ -- can't use JSRational here, due to ambiguous '0' parse+ -- it will parse as Integer.++instance JSON Float where+ showJSON = JSRational True . toRational+ readJSON (JSRational _ r) = return $ fromRational r+ readJSON _ = mkError "Unable to read Float"++-- -----------------------------------------------------------------+-- Sums++instance (JSON a) => JSON (Maybe a) where+ readJSON (JSObject o) = case "Just" `lookup` as of+ Just x -> Just <$> readJSON x+ _ -> case ("Nothing" `lookup` as) of+ Just JSNull -> return Nothing+ _ -> mkError "Unable to read Maybe"+ where as = fromJSObject o+ readJSON _ = mkError "Unable to read Maybe"+ showJSON (Just x) = JSObject $ toJSObject [("Just", showJSON x)]+ showJSON Nothing = JSObject $ toJSObject [("Nothing", JSNull)]++instance (JSON a, JSON b) => JSON (Either a b) where+ readJSON (JSObject o) = case "Left" `lookup` as of+ Just a -> Left <$> readJSON a+ Nothing -> case "Right" `lookup` as of+ Just b -> Right <$> readJSON b+ Nothing -> mkError "Unable to read Either"+ where as = fromJSObject o+ readJSON _ = mkError "Unable to read Either"+ showJSON (Left a) = JSObject $ toJSObject [("Left", showJSON a)]+ showJSON (Right b) = JSObject $ toJSObject [("Right", showJSON b)]++-- -----------------------------------------------------------------+-- Products++instance JSON () where+ showJSON _ = JSArray []+ readJSON (JSArray []) = return ()+ readJSON _ = mkError "Unable to read ()"++instance (JSON a, JSON b) => JSON (a,b) where+ showJSON (a,b) = JSArray [ showJSON a, showJSON b ]+ readJSON (JSArray [a,b]) = (,) `fmap` readJSON a `ap` readJSON b+ readJSON _ = mkError "Unable to read Pair"++instance (JSON a, JSON b, JSON c) => JSON (a,b,c) where+ showJSON (a,b,c) = JSArray [ showJSON a, showJSON b, showJSON c ]+ readJSON (JSArray [a,b,c]) = (,,) `fmap`+ readJSON a `ap`+ readJSON b `ap`+ readJSON c+ readJSON _ = mkError "Unable to read Triple"++instance (JSON a, JSON b, JSON c, JSON d) => JSON (a,b,c,d) where+ showJSON (a,b,c,d) = JSArray [showJSON a, showJSON b, showJSON c, showJSON d]+ readJSON (JSArray [a,b,c,d]) = (,,,) `fmap`+ readJSON a `ap`+ readJSON b `ap`+ readJSON c `ap`+ readJSON d++ readJSON _ = mkError "Unable to read 4 tuple"++-- -----------------------------------------------------------------+-- List-like types+++instance JSON a => JSON [a] where+ showJSON = showJSONs+ readJSON = readJSONs++-- container types:++#if !defined(MAP_AS_DICT)+instance (Ord a, JSON a, JSON b) => JSON (M.Map a b) where+ showJSON = encJSArray M.toList+ readJSON = decJSArray "Map" M.fromList++instance (JSON a) => JSON (IntMap.IntMap a) where+ showJSON = encJSArray IntMap.toList+ readJSON = decJSArray "IntMap" IntMap.fromList++#else+instance (Ord a, JSKey a, JSON b) => JSON (M.Map a b) where+ showJSON = encJSDict . M.toList+ readJSON o = M.fromList <$> decJSDict "Map" o++instance (JSON a) => JSON (IntMap.IntMap a) where+ {- alternate (dict) mapping: -}+ showJSON = encJSDict . IntMap.toList+ readJSON o = IntMap.fromList <$> decJSDict "IntMap" o+#endif+++instance (Ord a, JSON a) => JSON (Set.Set a) where+ showJSON = encJSArray Set.toList+ readJSON = decJSArray "Set" Set.fromList++instance (Array.Ix i, JSON i, JSON e) => JSON (Array.Array i e) where+ showJSON = encJSArray Array.assocs+ readJSON = decJSArray "Array" arrayFromList++instance JSON I.IntSet where+ showJSON = encJSArray I.toList+ readJSON = decJSArray "IntSet" I.fromList++-- helper functions for array / object serializers:+arrayFromList :: (Array.Ix i) => [(i,e)] -> Array.Array i e+arrayFromList [] = Array.array undefined []+arrayFromList ls@((i,_):xs) = Array.array bnds ls+ where+ bnds = foldr step (i,i) xs++ step (ix,_) (mi,ma) =+ let mi1 = min ix mi+ ma1 = max ix ma+ in mi1 `seq` ma1 `seq` (mi1,ma1)++{- NOTE: Non-Safe++-- -----------------------------------------------------------------+-- ByteStrings++instance JSON S.ByteString where+ showJSON = encJSString S.unpack+ readJSON = decJSString "ByteString" (return . S.pack)++instance JSON L.ByteString where+ showJSON = encJSString L.unpack+ readJSON = decJSString "Lazy.ByteString" (return . L.pack)++-- -----------------------------------------------------------------+-- Data.Text++instance JSON T.Text where+ readJSON (JSString s) = return (T.pack . fromJSString $ s)+ readJSON _ = mkError "Unable to read JSString"+ showJSON = JSString . toJSString . T.unpack++-}++-- -----------------------------------------------------------------+-- Instance Helpers++makeObj :: [(String, JSValue)] -> JSValue+makeObj = JSObject . toJSObject++-- | Pull a value out of a JSON object.+valFromObj :: JSON a => String -> JSObject JSValue -> Result a+valFromObj k o = maybe (Error $ "valFromObj: Could not find key: " ++ show k)+ readJSON+ (lookup k (fromJSObject o))++encJSString :: (a -> String) -> a -> JSValue+encJSString f v = JSString (toJSString (f v))++decJSString :: String -> (String -> Result a) -> JSValue -> Result a+decJSString _ f (JSString s) = f (fromJSString s)+decJSString l _ _ = mkError ("readJSON{"++l++"}: unable to parse string value")++encJSArray :: (JSON a) => (b-> [a]) -> b -> JSValue+encJSArray f v = showJSON (f v)++decJSArray :: (JSON a) => String -> ([a] -> b) -> JSValue -> Result b+decJSArray _ f a@JSArray{} = f <$> readJSON a+decJSArray l _ _ = mkError ("readJSON{"++l++"}: unable to parse array value")++-- | Haskell types that can be used as keys in JSON objects.+class JSKey a where+ toJSKey :: a -> String+ fromJSKey :: String -> Maybe a++instance JSKey JSString where+ toJSKey x = fromJSString x+ fromJSKey x = Just (toJSString x)++instance JSKey Int where+ toJSKey = show+ fromJSKey key = case reads key of+ [(a,"")] -> Just a+ _ -> Nothing++-- NOTE: This prevents us from making other instances for lists but,+-- our guess is that strings are used as keys more often then other list types.+instance JSKey String where+ toJSKey = id+ fromJSKey = Just+ +-- | Encode an association list as 'JSObject' value.+encJSDict :: (JSKey a, JSON b) => [(a,b)] -> JSValue+encJSDict v = makeObj [ (toJSKey x, showJSON y) | (x,y) <- v ]++-- | Decode a 'JSObject' value into an association list.+decJSDict :: (JSKey a, JSON b)+ => String+ -> JSValue+ -> Result [(a,b)]+decJSDict l (JSObject o) = mapM rd (fromJSObject o)+ where rd (a,b) = case fromJSKey a of+ Just pa -> readJSON b >>= \pb -> return (pa,pb)+ Nothing -> mkError ("readJSON{" ++ l ++ "}:" +++ "unable to read dict; invalid object key")++decJSDict l _ = mkError ("readJSON{"++l ++ "}: unable to read dict; expected JSON object")
+ src/Internal/GaloisInc/Text/JSON/Generic.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE PatternGuards #-}++{-# LANGUAGE Safe #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}++--------------------------------------------------------------------------------++-- |+-- Copyright : (c) 2007-2018 Galois Inc.+-- License : BSD-3-Clause+-- Maintainer : Iavor S. Diatchki (iavor.diatchki@gmail.com)+-- Stability : experimental+--+-- JSON serializer and deserializer using Data.Generics.+-- The functions here handle algebraic data types and primitive types.+-- It uses the same representation as "Internal.GaloisInc.Text.JSON" for "Prelude"+-- types.++--------------------------------------------------------------------------------++module Internal.GaloisInc.Text.JSON.Generic+ ( module Internal.GaloisInc.Text.JSON+ , Data+ , Typeable+ , toJSON+ , fromJSON+ , encodeJSON+ , decodeJSON++ , toJSON_generic+ , fromJSON_generic+ ) where++import Control.Monad.State+import Internal.GaloisInc.Text.JSON+import Internal.GaloisInc.Text.JSON.String ( runGetJSON )++{- NOTE: `Data.Generics` from `syb` just wraps `Data.Data` from `base`:+ https://github.com/dreixel/syb/blob/master/src/Data/Generics.hs+ https://hackage-content.haskell.org/package/syb-0.7.3/docs/Data-Generics.html+ https://hackage-content.haskell.org/package/base-4.19.2.0/docs/Data-Data.html++import Data.Generics++-}++import Data.Data++import Data.Word+import Data.Int++{- NOTE: Non-Safe++import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy.Char8 as L++-}++import qualified Data.IntSet as I+-- FIXME: The JSON library treats this specially, needs ext2Q+-- import qualified Data.Map as M++import Internal.GlasgowUniversity.Data.Generics.Aliases++type T a = a -> JSValue++-- |Convert anything to a JSON value.+toJSON :: (Data a) => a -> JSValue+toJSON = toJSON_generic+ `ext1Q` jList+ -- Use the standard encoding for all base types.+ `extQ` (showJSON :: T Integer)+ `extQ` (showJSON :: T Int)+ `extQ` (showJSON :: T Word8)+ `extQ` (showJSON :: T Word16)+ `extQ` (showJSON :: T Word32)+ `extQ` (showJSON :: T Word64)+ `extQ` (showJSON :: T Int8)+ `extQ` (showJSON :: T Int16)+ `extQ` (showJSON :: T Int32)+ `extQ` (showJSON :: T Int64)+ `extQ` (showJSON :: T Double)+ `extQ` (showJSON :: T Float)+ `extQ` (showJSON :: T Char)+ `extQ` (showJSON :: T String)+ -- Bool has a special encoding.+ `extQ` (showJSON :: T Bool)+ `extQ` (showJSON :: T ())+ `extQ` (showJSON :: T Ordering)++ -- More special cases.+ `extQ` (showJSON :: T I.IntSet)+ + {- NOTE: Non-Safe++ `extQ` (showJSON :: T S.ByteString)+ `extQ` (showJSON :: T L.ByteString)++ -}+ where+ -- Lists are simply coded as arrays.+ jList vs = JSArray $ map toJSON vs+++toJSON_generic :: (Data a) => a -> JSValue+toJSON_generic = generic+ where+ -- Generic encoding of an algebraic data type.+ -- No constructor, so it must be an error value. Code it anyway as JSNull.+ -- Elide a single constructor and just code the arguments.+ -- For multiple constructors, make an object with a field name that is the+ -- constructor (except lower case) and the data is the arguments encoded.+ generic a =+ case dataTypeRep (dataTypeOf a) of+ AlgRep [] -> JSNull+ AlgRep [c] -> encodeArgs c (gmapQ toJSON a)+ AlgRep _ -> encodeConstr (toConstr a) (gmapQ toJSON a)+ rep -> err (dataTypeOf a) rep+ where+ err dt r = error $ "toJSON: not AlgRep " ++ show r ++ "(" ++ show dt ++ ")"+ -- Encode nullary constructor as a string.+ -- Encode non-nullary constructors as an object with the constructor+ -- name as the single field and the arguments as the value.+ -- Use an array if the are no field names, but elide singleton arrays,+ -- and use an object if there are field names.+ encodeConstr c [] = JSString $ toJSString $ constrString c+ encodeConstr c as = jsObject [(constrString c, encodeArgs c as)]++ constrString = showConstr++ encodeArgs c = encodeArgs' (constrFields c)+ encodeArgs' [] [j] = j+ encodeArgs' [] js = JSArray js+ encodeArgs' ns js = jsObject $ zip (map mungeField ns) js++ -- Skip leading '_' in field name so we can use keywords etc. as field names.+ mungeField ('_':cs) = cs+ mungeField cs = cs++ jsObject :: [(String, JSValue)] -> JSValue+ jsObject = JSObject . toJSObject+++type F a = Result a++-- |Convert a JSON value to anything (fails if the types do not match).+fromJSON :: (Data a) => JSValue -> Result a+fromJSON j = fromJSON_generic j+ `ext1R` jList++ `extR` (value :: F Integer)+ `extR` (value :: F Int)+ `extR` (value :: F Word8)+ `extR` (value :: F Word16)+ `extR` (value :: F Word32)+ `extR` (value :: F Word64)+ `extR` (value :: F Int8)+ `extR` (value :: F Int16)+ `extR` (value :: F Int32)+ `extR` (value :: F Int64)+ `extR` (value :: F Double)+ `extR` (value :: F Float)+ `extR` (value :: F Char)+ `extR` (value :: F String)++ `extR` (value :: F Bool)+ `extR` (value :: F ())+ `extR` (value :: F Ordering)++ `extR` (value :: F I.IntSet)+ + {- NOTE: Non-Safe++ `extR` (value :: F S.ByteString)+ `extR` (value :: F L.ByteString)++ -}+ where value :: (JSON a) => Result a+ value = readJSON j++ jList :: (Data e) => Result [e]+ jList = case j of+ JSArray js -> mapM fromJSON js+ _ -> Error $ "fromJSON: Prelude.[] bad data: " ++ show j++++fromJSON_generic :: (Data a) => JSValue -> Result a+fromJSON_generic j = generic+ where+ typ = dataTypeOf $ resType generic+ generic = case dataTypeRep typ of+ AlgRep [] -> case j of JSNull -> return (error "Empty type"); _ -> Error $ "fromJSON: no-constr bad data"+ AlgRep [_] -> decodeArgs (indexConstr typ 1) j+ AlgRep _ -> do (c, j') <- getConstr typ j; decodeArgs c j'+ rep -> Error $ "fromJSON: " ++ show rep ++ "(" ++ show typ ++ ")"+ getConstr t (JSObject o) | [(s, j')] <- fromJSObject o = do c <- readConstr' t s; return (c, j')+ getConstr t (JSString js) = do c <- readConstr' t (fromJSString js); return (c, JSNull) -- handle nullare constructor+ getConstr _ _ = Error "fromJSON: bad constructor encoding"+ readConstr' t s =+ maybe (Error $ "fromJSON: unknown constructor: " ++ s ++ " " ++ show t)+ return $ readConstr t s++ decodeArgs c = decodeArgs' (numConstrArgs (resType generic) c) c (constrFields c)+ decodeArgs' 0 c _ JSNull = construct c [] -- nullary constructor+ decodeArgs' 1 c [] jd = construct c [jd] -- unary constructor+ decodeArgs' n c [] (JSArray js) | n > 1 = construct c js -- no field names+ -- FIXME? We could allow reading an array into a constructor with field names.+ decodeArgs' _ c fs@(_:_) (JSObject o) = selectFields (fromJSObject o) fs >>= construct c -- field names+ decodeArgs' _ c _ jd = Error $ "fromJSON: bad decodeArgs data " ++ show (c, jd)++ -- Build the value by stepping through the list of subparts.+ construct c = evalStateT $ fromConstrM f c+ where f :: (Data a) => StateT [JSValue] Result a+ f = do js <- get; case js of [] -> lift $ Error "construct: empty list"; j' : js' -> do put js'; lift $ fromJSON j'++ -- Select the named fields from a JSON object. FIXME? Should this use a map?+ selectFields fjs = mapM sel+ where sel f = maybe (Error $ "fromJSON: field does not exist " ++ f) Ok $ lookup f fjs++ -- Count how many arguments a constructor has. The value x is used to determine what type the constructor returns.+ numConstrArgs :: (Data a) => a -> Constr -> Int+ numConstrArgs x c = execState (fromConstrM f c `asTypeOf` return x) 0+ where f = do modify (+1); return undefined++ resType :: Result a -> a+ resType _ = error "resType"++-- |Encode a value as a string.+encodeJSON :: (Data a) => a -> String+encodeJSON x = showJSValue (toJSON x) ""++-- |Decode a string as a value.+decodeJSON :: (Data a) => String -> a+decodeJSON s =+ case runGetJSON readJSValue s of+ Left msg -> error msg+ Right j ->+ case fromJSON j of+ Error msg -> error msg+ Ok x -> x
+ src/Internal/GaloisInc/Text/JSON/String.hs view
@@ -0,0 +1,412 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}++--------------------------------------------------------------------------------++-- |+-- Copyright : (c) 2007-2018 Galois Inc.+-- License : BSD-3-Clause+-- Maintainer : Iavor S. Diatchki (iavor.diatchki@gmail.com)+-- Stability : experimental+--+-- Basic support for working with JSON values.++--------------------------------------------------------------------------------++module Internal.GaloisInc.Text.JSON.String + ( + -- * Parsing+ --+ GetJSON+ , runGetJSON++ -- ** Reading JSON+ , readJSNull+ , readJSBool+ , readJSString+ , readJSRational+ , readJSArray+ , readJSObject++ , readJSValue+ , readJSTopType++ -- ** Writing JSON+ , showJSNull+ , showJSBool+ , showJSArray+ , showJSObject+ , showJSRational+ , showJSRational'++ , showJSValue+ , showJSTopType+ ) where++import Prelude hiding (fail)+import Internal.GaloisInc.Text.JSON.Types (JSValue(..),+ JSString, toJSString, fromJSString,+ JSObject, toJSObject, fromJSObject)++import Control.Monad (liftM, ap)+import Control.Monad.Fail (MonadFail (..))++{- NOTE: [GHC-66111] [-Wunused-imports] The import of `Control.Applicative' is+ redundant++import Control.Applicative((<$>))++-}++import qualified Control.Applicative as A++{- NOTE: [GHC-38856] [-Wunused-imports] The import of `digitToInt' from module+ `Data.Char' is redundant++import Data.Char (isSpace, isDigit, digitToInt)++-}++import Data.Char (isSpace, isDigit)++{- NOTE: [GHC-38856] [-Wunused-imports] The import of `%' from module `Data.Ratio'+ is redundant++import Data.Ratio (numerator, denominator, (%))++-}++import Data.Ratio (numerator, denominator)++{- NOTE: [GHC-38856] [-Wunused-imports] The import of `readDec' from module+ `Numeric' is redundant+++import Numeric (readHex, readDec, showHex, readSigned, readFloat)++-}++import Numeric (readHex, showHex, readSigned, readFloat)++-- -----------------------------------------------------------------+-- | Parsing JSON++-- | The type of JSON parsers for String+newtype GetJSON a = GetJSON { un :: String -> Either String (a,String) }++{- NOTE: [GHC-22705] [-Wnoncanonical-monad-instances] Noncanonical `pure = return'+ definition detected in the instance declaration for `Applicative GetJSON'.+ Suggested fix: Move definition from `return' to `pure'++instance Functor GetJSON where fmap = liftM+instance A.Applicative GetJSON where+ pure = return+ (<*>) = ap++instance Monad GetJSON where+ return x = GetJSON (\s -> Right (x,s))+ GetJSON m >>= f = GetJSON (\s -> case m s of+ Left err -> Left err+ Right (a,s1) -> un (f a) s1)++-}++instance Functor GetJSON where fmap = liftM+instance A.Applicative GetJSON where+ pure x = GetJSON (\s -> Right (x,s))+ (<*>) = ap++instance Monad GetJSON where+ GetJSON m >>= f = GetJSON (\s -> case m s of+ Left err -> Left err+ Right (a,s1) -> un (f a) s1)++instance MonadFail GetJSON where+ fail x = GetJSON (\_ -> Left x)++-- | Run a JSON reader on an input String, returning some Haskell value.+-- All input will be consumed.+runGetJSON :: GetJSON a -> String -> Either String a+runGetJSON (GetJSON m) s = case m s of+ Left err -> Left err+ Right (a,t) -> case t of+ [] -> Right a+ _ -> Left $ "Invalid tokens at end of JSON string: "++ show (take 10 t)++getInput :: GetJSON String+getInput = GetJSON (\s -> Right (s,s))++setInput :: String -> GetJSON ()+setInput s = GetJSON (\_ -> Right ((),s))++-------------------------------------------------------------------------++-- | Find 8 chars context, for error messages+context :: String -> String+context s = take 8 s++-- | Read the JSON null type+readJSNull :: GetJSON JSValue+readJSNull = do+ xs <- getInput+ case xs of+ 'n':'u':'l':'l':xs1 -> setInput xs1 >> return JSNull+ _ -> fail $ "Unable to parse JSON null: " ++ context xs++tryJSNull :: GetJSON JSValue -> GetJSON JSValue+tryJSNull k = do+ xs <- getInput+ case xs of+ 'n':'u':'l':'l':xs1 -> setInput xs1 >> return JSNull+ _ -> k ++-- | Read the JSON Bool type+readJSBool :: GetJSON JSValue+readJSBool = do+ xs <- getInput+ case xs of+ 't':'r':'u':'e':xs1 -> setInput xs1 >> return (JSBool True)+ 'f':'a':'l':'s':'e':xs1 -> setInput xs1 >> return (JSBool False)+ _ -> fail $ "Unable to parse JSON Bool: " ++ context xs++-- | Read the JSON String type+readJSString :: GetJSON JSValue+readJSString = do+ x <- getInput+ case x of+ '"' : cs -> parse [] cs+ _ -> fail $ "Malformed JSON: expecting string: " ++ context x+ where + parse rs cs = + case cs of+ '\\' : c : ds -> esc rs c ds+ '"' : ds -> do setInput ds+ return (JSString (toJSString (reverse rs)))+ c : ds+ | c >= '\x20' && c <= '\xff' -> parse (c:rs) ds+ | c < '\x20' -> fail $ "Illegal unescaped character in string: " ++ context cs+ | i <= 0x10ffff -> parse (c:rs) ds+ | otherwise -> fail $ "Illegal unescaped character in string: " ++ context cs+ where+ i = (fromIntegral (fromEnum c) :: Integer)+ _ -> fail $ "Unable to parse JSON String: unterminated String: " ++ context cs++ esc rs c cs = case c of+ '\\' -> parse ('\\' : rs) cs+ '"' -> parse ('"' : rs) cs+ 'n' -> parse ('\n' : rs) cs+ 'r' -> parse ('\r' : rs) cs+ 't' -> parse ('\t' : rs) cs+ 'f' -> parse ('\f' : rs) cs+ 'b' -> parse ('\b' : rs) cs+ '/' -> parse ('/' : rs) cs+ 'u' -> case cs of+ d1 : d2 : d3 : d4 : cs' ->+ case readHex [d1,d2,d3,d4] of+ [(n,"")] -> parse (toEnum n : rs) cs'++ x -> fail $ "Unable to parse JSON String: invalid hex: " ++ context (show x)+ _ -> fail $ "Unable to parse JSON String: invalid hex: " ++ context cs+ _ -> fail $ "Unable to parse JSON String: invalid escape char: " ++ show c+++-- | Read an Integer or Double in JSON format, returning a Rational+readJSRational :: GetJSON Rational+readJSRational = do+ cs <- getInput+ case (reads cs, readSigned readFloat cs) of+ ([(x,_)], _)+ | isInfinite (x :: Double) ->+ fail ("JSON Rational out of range: " ++ context cs)+ (_, [(y,cs')]) -> setInput cs' >> return y+ _ -> fail ("Unable to parse JSON Rational: " ++ context cs)+++-- | Read a list in JSON format+readJSArray :: GetJSON JSValue+readJSArray = readSequence '[' ']' ',' >>= return . JSArray++-- | Read an object in JSON format+readJSObject :: GetJSON JSValue+readJSObject = readAssocs '{' '}' ',' >>= return . JSObject . toJSObject+++-- | Read a sequence of items+readSequence :: Char -> Char -> Char -> GetJSON [JSValue]+readSequence start end sep = do+ zs <- getInput+ case dropWhile isSpace zs of+ c : cs | c == start ->+ case dropWhile isSpace cs of+ d : ds | d == end -> setInput (dropWhile isSpace ds) >> return []+ ds -> setInput ds >> parse []+ _ -> fail $ "Unable to parse JSON sequence: sequence stars with invalid character: " ++ context zs++ where parse rs = rs `seq` do+ a <- readJSValue+ ds <- getInput+ case dropWhile isSpace ds of+ e : es | e == sep -> do setInput (dropWhile isSpace es)+ parse (a:rs)+ | e == end -> do setInput (dropWhile isSpace es)+ return (reverse (a:rs))+ _ -> fail $ "Unable to parse JSON array: unterminated array: " ++ context ds+++-- | Read a sequence of JSON labelled fields+readAssocs :: Char -> Char -> Char -> GetJSON [(String,JSValue)]+readAssocs start end sep = do+ zs <- getInput+ case dropWhile isSpace zs of+ c:cs | c == start -> case dropWhile isSpace cs of+ d:ds | d == end -> setInput (dropWhile isSpace ds) >> return []+ ds -> setInput ds >> parsePairs []+ _ -> fail "Unable to parse JSON object: unterminated object"++ where parsePairs rs = rs `seq` do+ a <- do k <- do x <- readJSString ; case x of+ JSString s -> return (fromJSString s)+ _ -> fail $ "Malformed JSON field labels: object keys must be quoted strings."+ ds <- getInput+ case dropWhile isSpace ds of+ ':':es -> do setInput (dropWhile isSpace es)+ v <- readJSValue+ return (k,v)+ _ -> fail $ "Malformed JSON labelled field: " ++ context ds++ ds <- getInput+ case dropWhile isSpace ds of+ e : es | e == sep -> do setInput (dropWhile isSpace es)+ parsePairs (a:rs)+ | e == end -> do setInput (dropWhile isSpace es)+ return (reverse (a:rs))+ _ -> fail $ "Unable to parse JSON object: unterminated sequence: "+ ++ context ds++-- | Read one of several possible JS types+readJSValue :: GetJSON JSValue+readJSValue = do+ cs <- getInput+ case cs of+ '"' : _ -> readJSString+ '[' : _ -> readJSArray+ '{' : _ -> readJSObject+ 't' : _ -> readJSBool+ 'f' : _ -> readJSBool+ (x:_) | isDigit x || x == '-' -> JSRational False <$> readJSRational+ xs -> tryJSNull+ (fail $ "Malformed JSON: invalid token in this context " ++ context xs)++-- | Top level JSON can only be Arrays or Objects+readJSTopType :: GetJSON JSValue+readJSTopType = do+ cs <- getInput+ case cs of+ '[' : _ -> readJSArray+ '{' : _ -> readJSObject+ _ -> fail "Invalid JSON: a JSON text a serialized object or array at the top level."++-- -----------------------------------------------------------------+-- | Writing JSON++-- | Show strict JSON top level types. Values not permitted+-- at the top level are wrapped in a singleton array.+showJSTopType :: JSValue -> ShowS+showJSTopType (JSArray a) = showJSArray a+showJSTopType (JSObject o) = showJSObject o+showJSTopType x = showJSTopType $ JSArray [x]++-- | Show JSON values+showJSValue :: JSValue -> ShowS+showJSValue jv =+ case jv of+ JSNull{} -> showJSNull+ JSBool b -> showJSBool b+ JSRational asF r -> showJSRational' asF r+ JSArray a -> showJSArray a+ JSString s -> showJSString s+ JSObject o -> showJSObject o++-- | Write the JSON null type+showJSNull :: ShowS+showJSNull = showString "null"++-- | Write the JSON Bool type+showJSBool :: Bool -> ShowS+showJSBool True = showString "true"+showJSBool False = showString "false"++-- | Write the JSON String type+showJSString :: JSString -> ShowS+showJSString x xs = quote (encJSString x (quote xs))+ where+ quote = showChar '"'++-- | Show a Rational in JSON format+showJSRational :: Rational -> ShowS+showJSRational r = showJSRational' False r++showJSRational' :: Bool -> Rational -> ShowS+showJSRational' asFloat r + | denominator r == 1 = shows $ numerator r+ | isInfinite x || isNaN x = showJSNull+ | asFloat = shows xf+ | otherwise = shows x+ where + x :: Double+ x = realToFrac r+ + xf :: Float+ xf = realToFrac r++++-- | Show a list in JSON format+showJSArray :: [JSValue] -> ShowS+showJSArray = showSequence '[' ']' ','++-- | Show an association list in JSON format+showJSObject :: JSObject JSValue -> ShowS+showJSObject = showAssocs '{' '}' ',' . fromJSObject++-- | Show a generic sequence of pairs in JSON format+showAssocs :: Char -> Char -> Char -> [(String,JSValue)] -> ShowS+showAssocs start end sep xs rest = start : go xs+ where+ go [(k,v)] = '"' : encJSString (toJSString k)+ ('"' : ':' : showJSValue v (go []))+ go ((k,v):kvs) = '"' : encJSString (toJSString k)+ ('"' : ':' : showJSValue v (sep : go kvs))+ go [] = end : rest++-- | Show a generic sequence in JSON format+showSequence :: Char -> Char -> Char -> [JSValue] -> ShowS+showSequence start end sep xs rest = start : go xs+ where+ go [y] = showJSValue y (go [])+ go (y:ys) = showJSValue y (sep : go ys)+ go [] = end : rest++encJSString :: JSString -> ShowS+encJSString jss ss = go (fromJSString jss)+ where+ go s1 =+ case s1 of+ (x :xs) | x < '\x20' -> '\\' : encControl x (go xs)+ ('"' :xs) -> '\\' : '"' : go xs+ ('\\':xs) -> '\\' : '\\' : go xs+ (x :xs) -> x : go xs+ "" -> ss++ encControl x xs = case x of+ '\b' -> 'b' : xs+ '\f' -> 'f' : xs+ '\n' -> 'n' : xs+ '\r' -> 'r' : xs+ '\t' -> 't' : xs+ _ | x < '\x10' -> 'u' : '0' : '0' : '0' : hexxs+ | x < '\x100' -> 'u' : '0' : '0' : hexxs+ | x < '\x1000' -> 'u' : '0' : hexxs+ | otherwise -> 'u' : hexxs+ where hexxs = showHex (fromEnum x) xs+
+ src/Internal/GaloisInc/Text/JSON/Types.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE DeriveDataTypeable #-}++{-# LANGUAGE Safe #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}++--------------------------------------------------------------------------------++-- |+-- Copyright : (c) 2007-2018 Galois Inc.+-- License : BSD-3-Clause+-- Maintainer : Iavor S. Diatchki (iavor.diatchki@gmail.com)+-- Stability : experimental+--+-- Basic support for working with JSON values.++--------------------------------------------------------------------------------++module Internal.GaloisInc.Text.JSON.Types (++ -- * JSON Types+ JSValue(..)++ -- * Wrapper Types+ , JSString({-fromJSString-}..)+ , toJSString++ , JSObject({-fromJSObject-}..)+ , toJSObject++ , get_field+ , set_field++ ) where++{- NOTE: [GHC-66111] [-Wunused-imports] The import of `Data.Typeable' is redundant++import Data.Typeable ( Typeable )++-}++import Data.String(IsString(..))++--+-- | JSON values+--+-- The type to which we encode Haskell values. There's a set+-- of primitives, and a couple of heterogenous collection types.+--+-- Objects:+--+-- An object structure is represented as a pair of curly brackets+-- surrounding zero or more name\/value pairs (or members). A name is a+-- string. A single colon comes after each name, separating the name+-- from the value. A single comma separates a value from a+-- following name.+--+-- Arrays:+--+-- An array structure is represented as square brackets surrounding+-- zero or more values (or elements). Elements are separated by commas.+--+-- Only valid JSON can be constructed this way+--+data JSValue+ = JSNull+ | JSBool !Bool+ | JSRational Bool{-as Float?-} !Rational+ | JSString JSString+ | JSArray [JSValue]+ | JSObject (JSObject JSValue)+ + {- NOTE: [GHC-90584] [-Wderiving-typeable] Deriving `Typeable' has no effect: all+ types now auto-derive Typeable++ deriving (Show, Read, Eq, Ord, Typeable)++ -}++ deriving (Show, Read, Eq, Ord)++-- | Strings can be represented a little more efficiently in JSON+newtype JSString = JSONString { fromJSString :: String }+ + {- NOTE: [GHC-90584] [-Wderiving-typeable] Deriving `Typeable' has no effect: all+ types now auto-derive Typeable++ deriving (Show, Read, Eq, Ord, Typeable)++ -}+ + deriving (Eq, Ord, Show, Read)++-- | Turn a Haskell string into a JSON string.+toJSString :: String -> JSString+toJSString = JSONString+ -- Note: we don't encode the string yet, that's done when serializing.++instance IsString JSString where+ fromString = toJSString++instance IsString JSValue where+ fromString = JSString . fromString++-- | As can association lists+newtype JSObject e = JSONObject { fromJSObject :: [(String, e)] }+ + {- NOTE: [GHC-90584] [-Wderiving-typeable] Deriving `Typeable' has no effect: all+ types now auto-derive Typeable++ deriving (Show, Read, Eq, Ord, Typeable)++ -}+ + deriving (Eq, Ord, Show, Read)++-- | Make JSON object out of an association list.+toJSObject :: [(String,a)] -> JSObject a+toJSObject = JSONObject++-- | Get the value of a field, if it exist.+get_field :: JSObject a -> String -> Maybe a+get_field (JSONObject xs) x = lookup x xs++-- | Set the value of a field. Previous values are overwritten.+set_field :: JSObject a -> String -> a -> JSObject a+set_field (JSONObject xs) k v = JSONObject ((k,v) : filter ((/= k).fst) xs)
+ src/Internal/GlasgowUniversity/Data/Generics/Aliases.hs view
@@ -0,0 +1,754 @@+{-# LANGUAGE RankNTypes, CPP #-}++{-# LANGUAGE Safe #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}++-----------------------------------------------------------------------------+-- |+-- Module : Data.Generics.Aliases+-- Copyright : (c) The University of Glasgow, CWI 2001--2004+-- License : BSD-style (see the LICENSE file)+--+-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable (local universal quantification)+--+-- This module provides a number of declarations for typical generic+-- function types, corresponding type case, and others.+--+-----------------------------------------------------------------------------++module Internal.GlasgowUniversity.Data.Generics.Aliases (++ -- * Combinators which create generic functions via cast+ --+ -- $castcombinators++ -- ** Transformations+ mkT,+ extT,+ -- ** Queries+ mkQ,+ extQ,+ -- ** Monadic transformations+ mkM,+ extM,+ -- ** MonadPlus transformations+ mkMp,+ extMp,+ -- ** Readers+ mkR,+ extR,+ -- ** Builders+ extB,+ -- ** Other+ ext0,+ -- * Types for generic functions+ -- ** Transformations+ GenericT,+ GenericT'(..),+ -- ** Queries+ GenericQ,+ GenericQ'(..),+ -- ** Monadic transformations+ GenericM,+ GenericM'(..),+ -- ** Readers+ GenericR,+ GenericR'(..),+ -- ** Builders+ GenericB,+ GenericB'(..),+ -- ** Other+ Generic,+ Generic'(..),++ -- * Ingredients of generic functions+ orElse,++ -- * Function combinators on generic functions+ recoverMp,+ recoverQ,+ choiceMp,+ choiceQ,++ -- * Type extension for unary type constructors+ ext1,+ ext1T,+ ext1M,+ ext1Q,+ ext1R,+ ext1B,++ -- * Type extension for binary type constructors+ ext2,+ ext2T,+ ext2M,+ ext2Q,+ ext2R,+ ext2B++ ) where++#ifdef __HADDOCK__+import Prelude+#endif+import Control.Monad+import Data.Data++------------------------------------------------------------------------------+--+-- Combinators to "make" generic functions+-- We use type-safe cast in a number of ways to make generic functions.+--+------------------------------------------------------------------------------++-- $castcombinators+--+-- Other programming languages sometimes provide an operator @instanceof@ which+-- can check whether an expression is an instance of a given type. This operator+-- allows programmers to implement a function @f :: forall a. a -> a@ which exhibits+-- a different behaviour depending on whether a `Bool` or a `Char` is passed.+-- In Haskell this is not the case: A function with type @forall a. a -> a@+-- can only be the identity function or a function which loops indefinitely+-- or throws an exception. That is, it must implement exactly the same behaviour+-- for any type at which it is used. But sometimes it is very useful to have+-- a function which can accept (almost) any type and exhibit a different behaviour+-- for different types. Haskell provides this functionality with the 'Typeable'+-- typeclass, whose instances can be automatically derived by GHC for almost all+-- types. This typeclass allows the definition of a functon 'cast' which has type+-- @forall a b. (Typeable a, Typeable b) => a -> Maybe b@. The 'cast' function allows+-- to implement a polymorphic function with different behaviour at different types:+--+-- >>> cast True :: Maybe Bool+-- Just True+--+-- >>> cast True :: Maybe Int+-- Nothing+--+-- This section provides combinators which make use of 'cast' internally to+-- provide various polymorphic functions with type-specific behaviour.+++-- | Extend the identity function with a type-specific transformation.+-- The function created by @mkT ext@ behaves like the identity function on all+-- arguments which cannot be cast to type @b@, and like the function @ext@ otherwise.+-- The name 'mkT' is short for "make transformation".+--+-- === __Examples__+--+-- >>> mkT not True+-- False+--+-- >>> mkT not 'a'+-- 'a'+--+-- @since 0.1.0.0+mkT :: ( Typeable a+ , Typeable b+ )+ => (b -> b)+ -- ^ The type-specific transformation+ -> a+ -- ^ The argument we try to cast to type @b@+ -> a+mkT = extT id+++-- | The function created by @mkQ def f@ returns the default result+-- @def@ if its argument cannot be cast to type @b@, otherwise it returns+-- the result of applying @f@ to its argument.+-- The name 'mkQ' is short for "make query".+--+-- === __Examples__+--+-- >>> mkQ "default" (show :: Bool -> String) True+-- "True"+--+-- >>> mkQ "default" (show :: Bool -> String) ()+-- "default"+--+-- @since 0.1.0.0+mkQ :: ( Typeable a+ , Typeable b+ )+ => r+ -- ^ The default result+ -> (b -> r)+ -- ^ The transformation to apply if the cast is successful+ -> a+ -- ^ The argument we try to cast to type @b@+ -> r+(r `mkQ` br) a = case cast a of+ Just b -> br b+ Nothing -> r+++-- | Extend the default monadic action @pure :: Monad m => a -> m a@ by a type-specific+-- monadic action. The function created by @mkM act@ behaves like 'pure' if its+-- argument cannot be cast to type @b@, and like the monadic action @act@ otherwise.+-- The name 'mkM' is short for "make monadic transformation".+--+-- === __Examples__+--+-- >>> mkM (\x -> [x, not x]) True+-- [True,False]+--+-- >>> mkM (\x -> [x, not x]) (5 :: Int)+-- [5]+--+-- @since 0.1.0.0+mkM :: ( Monad m+ , Typeable a+ , Typeable b+ )+ => (b -> m b)+ -- ^ The type-specific monadic transformation+ -> a+ -- ^ The argument we try to cast to type @b@+ -> m a+mkM = extM return++-- | Extend the default 'MonadPlus' action @const mzero@ by a type-specific 'MonadPlus'+-- action. The function created by @mkMp act@ behaves like @const mzero@ if its argument+-- cannot be cast to type @b@, and like the monadic action @act@ otherwise.+-- The name 'mkMp' is short for "make MonadPlus transformation".+--+-- === __Examples__+--+-- >>> mkMp (\x -> Just (not x)) True+-- Just False+--+-- >>> mkMp (\x -> Just (not x)) 'a'+-- Nothing+--+-- @since 0.1.0.0+mkMp :: ( MonadPlus m+ , Typeable a+ , Typeable b+ )+ => (b -> m b)+ -- ^ The type-specific MonadPlus action+ -> a+ -- ^ The argument we try to cast to type @b@+ -> m a+mkMp = extM (const mzero)+++-- | Make a generic reader from a type-specific case.+-- The function created by @mkR f@ behaves like the reader @f@ if an expression+-- of type @a@ can be cast to type @b@, and like the expression @mzero@ otherwise.+-- The name 'mkR' is short for "make reader".+--+-- === __Examples__+--+-- >>> mkR (Just True) :: Maybe Bool+-- Just True+--+-- >>> mkR (Just True) :: Maybe Int+-- Nothing+--+-- @since 0.1.0.0+mkR :: ( MonadPlus m+ , Typeable a+ , Typeable b+ )+ => m b+ -- ^ The type-specific reader+ -> m a+mkR f = mzero `extR` f+++-- | Flexible type extension+--+-- === __Examples__+--+-- >>> ext0 [1 :: Int, 2, 3] [True, False] :: [Int]+-- [1,2,3]+--+-- >>> ext0 [1 :: Int, 2, 3] [4 :: Int, 5, 6] :: [Int]+-- [4,5,6]+--+-- @since 0.1.0.0+ext0 :: (Typeable a, Typeable b) => c a -> c b -> c a+ext0 def ext = maybe def id (gcast ext)+++-- | Extend a generic transformation by a type-specific transformation.+-- The function created by @extT def ext@ behaves like the generic transformation+-- @def@ if its argument cannot be cast to the type @b@, and like the type-specific+-- transformation @ext@ otherwise.+-- The name 'extT' is short for "extend transformation".+--+-- === __Examples__+--+-- >>> extT id not True+-- False+--+-- >>> extT id not 'a'+-- 'a'+--+-- @since 0.1.0.0+extT :: ( Typeable a+ , Typeable b+ )+ => (a -> a)+ -- ^ The transformation we want to extend+ -> (b -> b)+ -- ^ The type-specific transformation+ -> a+ -- ^ The argument we try to cast to type @b@+ -> a+extT def ext = unT ((T def) `ext0` (T ext))+++-- | Extend a generic query by a type-specific query. The function created by @extQ def ext@ behaves+-- like the generic query @def@ if its argument cannot be cast to the type @b@, and like the type-specific+-- query @ext@ otherwise.+-- The name 'extQ' is short for "extend query".+--+-- === __Examples__+--+-- >>> extQ (const True) not True+-- False+--+-- >>> extQ (const True) not 'a'+-- True+--+-- @since 0.1.0.0+extQ :: ( Typeable a+ , Typeable b+ )+ => (a -> r)+ -- ^ The query we want to extend+ -> (b -> r)+ -- ^ The type-specific query+ -> a+ -- ^ The argument we try to cast to type @b@+ -> r+extQ f g a = maybe (f a) g (cast a)+++-- | Extend a generic monadic transformation by a type-specific case.+-- The function created by @extM def ext@ behaves like the monadic transformation+-- @def@ if its argument cannot be cast to type @b@, and like the monadic transformation+-- @ext@ otherwise.+-- The name 'extM' is short for "extend monadic transformation".+--+-- === __Examples__+--+-- >>> extM (\x -> [x,x])(\x -> [not x, x]) True+-- [False,True]+--+-- >>> extM (\x -> [x,x])(\x -> [not x, x]) (5 :: Int)+-- [5,5]+--+-- @since 0.1.0.0+extM :: ( Monad m+ , Typeable a+ , Typeable b+ )+ => (a -> m a)+ -- ^ The monadic transformation we want to extend+ -> (b -> m b)+ -- ^ The type-specific monadic transformation+ -> a+ -- ^ The argument we try to cast to type @b@+ -> m a+extM def ext = unM ((M def) `ext0` (M ext))+++-- | Extend a generic MonadPlus transformation by a type-specific case.+-- The function created by @extMp def ext@ behaves like 'MonadPlus' transformation @def@+-- if its argument cannot be cast to type @b@, and like the transformation @ext@ otherwise.+-- Note that 'extMp' behaves exactly like 'extM'.+-- The name 'extMp' is short for "extend MonadPlus transformation".+--+-- === __Examples__+--+-- >>> extMp (\x -> [x,x])(\x -> [not x, x]) True+-- [False,True]+--+-- >>> extMp (\x -> [x,x])(\x -> [not x, x]) (5 :: Int)+-- [5,5]+--+-- @since 0.1.0.0+extMp :: ( MonadPlus m+ , Typeable a+ , Typeable b+ )+ => (a -> m a)+ -- ^ The 'MonadPlus' transformation we want to extend+ -> (b -> m b)+ -- ^ The type-specific 'MonadPlus' transformation+ -> a+ -- ^ The argument we try to cast to type @b@+ -> m a+extMp = extM+++-- | Extend a generic builder by a type-specific case.+-- The builder created by @extB def ext@ returns @def@ if @ext@ cannot be cast+-- to type @a@, and like @ext@ otherwise.+-- The name 'extB' is short for "extend builder".+--+-- === __Examples__+--+-- >>> extB True 'a'+-- True+--+-- >>> extB True False+-- False+--+-- @since 0.1.0.0+extB :: ( Typeable a+ , Typeable b+ )+ => a+ -- ^ The default result+ -> b+ -- ^ The argument we try to cast to type @a@+ -> a+extB a = maybe a id . cast+++-- | Extend a generic reader by a type-specific case.+-- The reader created by @extR def ext@ behaves like the reader @def@+-- if expressions of type @b@ cannot be cast to type @a@, and like the+-- reader @ext@ otherwise.+-- The name 'extR' is short for "extend reader".+--+-- === __Examples__+--+-- >>> extR (Just True) (Just 'a')+-- Just True+--+-- >>> extR (Just True) (Just False)+-- Just False+--+-- @since 0.1.0.0+extR :: ( Monad m+ , Typeable a+ , Typeable b+ )+ => m a+ -- ^ The generic reader we want to extend+ -> m b+ -- ^ The type-specific reader+ -> m a+extR def ext = unR ((R def) `ext0` (R ext))++++------------------------------------------------------------------------------+--+-- Types for generic functions+--+------------------------------------------------------------------------------+++-- | Generic transformations,+-- i.e., take an \"a\" and return an \"a\"+--+-- @since 0.1.0.0+type GenericT = forall a. Data a => a -> a++-- | The type synonym `GenericT` has a polymorphic type, and can therefore not+-- appear in places where monomorphic types are expected, for example in a list.+-- The newtype `GenericT'` wraps `GenericT` in a newtype to lift this restriction.+--+-- @since 0.1.0.0+newtype GenericT' = GT { unGT :: GenericT }++-- | Generic queries of type \"r\",+-- i.e., take any \"a\" and return an \"r\"+--+-- @since 0.1.0.0+type GenericQ r = forall a. Data a => a -> r++-- | The type synonym `GenericQ` has a polymorphic type, and can therefore not+-- appear in places where monomorphic types are expected, for example in a list.+-- The newtype `GenericQ'` wraps `GenericQ` in a newtype to lift this restriction.+--+-- @since 0.1.0.0+newtype GenericQ' r = GQ { unGQ :: GenericQ r }++-- | Generic monadic transformations,+-- i.e., take an \"a\" and compute an \"a\"+--+-- @since 0.1.0.0+type GenericM m = forall a. Data a => a -> m a++-- | The type synonym `GenericM` has a polymorphic type, and can therefore not+-- appear in places where monomorphic types are expected, for example in a list.+-- The newtype `GenericM'` wraps `GenericM` in a newtype to lift this restriction.+--+-- @since 0.1.0.0+newtype GenericM' m = GM { unGM :: GenericM m }++-- | Generic builders+-- i.e., produce an \"a\".+--+-- @since 0.1.0.0+type GenericB = forall a. Data a => a++-- | The type synonym `GenericB` has a polymorphic type, and can therefore not+-- appear in places where monomorphic types are expected, for example in a list.+-- The data type `GenericB'` wraps `GenericB` in a data type to lift this restriction.+--+-- @since 0.7.3+newtype GenericB' = GenericB' { unGenericB' :: GenericB }++-- | Generic readers, say monadic builders,+-- i.e., produce an \"a\" with the help of a monad \"m\".+--+-- @since 0.1.0.0+type GenericR m = forall a. Data a => m a++-- | The type synonym `GenericR` has a polymorphic type, and can therefore not+-- appear in places where monomorphic types are expected, for example in a list.+-- The data type `GenericR'` wraps `GenericR` in a data type to lift this restriction.+--+-- @since 0.7.3+newtype GenericR' m = GenericR' { unGenericR' :: GenericR m }++-- | The general scheme underlying generic functions+-- assumed by gfoldl; there are isomorphisms such as+-- GenericT = Generic T.+--+-- @since 0.1.0.0+type Generic c = forall a. Data a => a -> c a+++-- | The type synonym `Generic` has a polymorphic type, and can therefore not+-- appear in places where monomorphic types are expected, for example in a list.+-- The data type `Generic'` wraps `Generic` in a data type to lift this restriction.+--+-- @since 0.1.0.0+newtype Generic' c = Generic' { unGeneric' :: Generic c }++------------------------------------------------------------------------------+--+-- Ingredients of generic functions+--+------------------------------------------------------------------------------++-- | Left-biased choice on maybes+--+-- === __Examples__+--+-- >>> orElse Nothing Nothing+-- Nothing+--+-- >>> orElse Nothing (Just 'a')+-- Just 'a'+--+-- >>> orElse (Just 'a') Nothing+-- Just 'a'+--+-- >>> orElse (Just 'a') (Just 'b')+-- Just 'a'+--+-- @since 0.1.0.0+orElse :: Maybe a -> Maybe a -> Maybe a+x `orElse` y = case x of+ Just _ -> x+ Nothing -> y+++------------------------------------------------------------------------------+--+-- Function combinators on generic functions+--+------------------------------------------------------------------------------+{-++The following variations take "orElse" to the function+level. Furthermore, we generalise from "Maybe" to any+"MonadPlus". This makes sense for monadic transformations and+queries. We say that the resulting combinators modell choice. We also+provide a prime example of choice, that is, recovery from failure. In+the case of transformations, we recover via return whereas for+queries a given constant is returned.++-}++-- | Choice for monadic transformations+--+-- @since 0.1.0.0+choiceMp :: MonadPlus m => GenericM m -> GenericM m -> GenericM m+choiceMp f g x = f x `mplus` g x+++-- | Choice for monadic queries+--+-- @since 0.1.0.0+choiceQ :: MonadPlus m => GenericQ (m r) -> GenericQ (m r) -> GenericQ (m r)+choiceQ f g x = f x `mplus` g x+++-- | Recover from the failure of monadic transformation by identity+--+-- @since 0.1.0.0+recoverMp :: MonadPlus m => GenericM m -> GenericM m+recoverMp f = f `choiceMp` return+++-- | Recover from the failure of monadic query by a constant+--+-- @since 0.1.0.0+recoverQ :: MonadPlus m => r -> GenericQ (m r) -> GenericQ (m r)+recoverQ r f = f `choiceQ` const (return r)++++------------------------------------------------------------------------------+-- Type extension for unary type constructors+------------------------------------------------------------------------------++#if __GLASGOW_HASKELL__ >= 707+#define Typeable1 Typeable+#define Typeable2 Typeable+#endif++-- | Flexible type extension+--+-- @since 0.3+ext1 :: (Data a, Typeable1 t)+ => c a+ -> (forall d. Data d => c (t d))+ -> c a+ext1 def ext = maybe def id (dataCast1 ext)+++-- | Type extension of transformations for unary type constructors+--+-- @since 0.1.0.0+ext1T :: (Data d, Typeable1 t)+ => (forall e. Data e => e -> e)+ -> (forall f. Data f => t f -> t f)+ -> d -> d+ext1T def ext = unT ((T def) `ext1` (T ext))+++-- | Type extension of monadic transformations for type constructors+--+-- @since 0.1.0.0+ext1M :: (Monad m, Data d, Typeable1 t)+ => (forall e. Data e => e -> m e)+ -> (forall f. Data f => t f -> m (t f))+ -> d -> m d+ext1M def ext = unM ((M def) `ext1` (M ext))+++-- | Type extension of queries for type constructors+--+-- @since 0.1.0.0+ext1Q :: (Data d, Typeable1 t)+ => (d -> q)+ -> (forall e. Data e => t e -> q)+ -> d -> q+ext1Q def ext = unQ ((Q def) `ext1` (Q ext))+++-- | Type extension of readers for type constructors+--+-- @since 0.1.0.0+ext1R :: (Monad m, Data d, Typeable1 t)+ => m d+ -> (forall e. Data e => m (t e))+ -> m d+ext1R def ext = unR ((R def) `ext1` (R ext))+++-- | Type extension of builders for type constructors+--+-- @since 0.2+ext1B :: (Data a, Typeable1 t)+ => a+ -> (forall b. Data b => (t b))+ -> a+ext1B def ext = unB ((B def) `ext1` (B ext))++------------------------------------------------------------------------------+-- Type extension for binary type constructors+------------------------------------------------------------------------------++-- | Flexible type extension+ext2 :: (Data a, Typeable2 t)+ => c a+ -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2))+ -> c a+ext2 def ext = maybe def id (dataCast2 ext)+++-- | Type extension of transformations for unary type constructors+--+-- @since 0.3+ext2T :: (Data d, Typeable2 t)+ => (forall e. Data e => e -> e)+ -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> t d1 d2)+ -> d -> d+ext2T def ext = unT ((T def) `ext2` (T ext))+++-- | Type extension of monadic transformations for type constructors+--+-- @since 0.3+ext2M :: (Monad m, Data d, Typeable2 t)+ => (forall e. Data e => e -> m e)+ -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> m (t d1 d2))+ -> d -> m d+ext2M def ext = unM ((M def) `ext2` (M ext))+++-- | Type extension of queries for type constructors+--+-- @since 0.3+ext2Q :: (Data d, Typeable2 t)+ => (d -> q)+ -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)+ -> d -> q+ext2Q def ext = unQ ((Q def) `ext2` (Q ext))+++-- | Type extension of readers for type constructors+--+-- @since 0.3+ext2R :: (Monad m, Data d, Typeable2 t)+ => m d+ -> (forall d1 d2. (Data d1, Data d2) => m (t d1 d2))+ -> m d+ext2R def ext = unR ((R def) `ext2` (R ext))+++-- | Type extension of builders for type constructors+--+-- @since 0.3+ext2B :: (Data a, Typeable2 t)+ => a+ -> (forall d1 d2. (Data d1, Data d2) => (t d1 d2))+ -> a+ext2B def ext = unB ((B def) `ext2` (B ext))++------------------------------------------------------------------------------+--+-- Type constructors for type-level lambdas+--+------------------------------------------------------------------------------+++-- | The type constructor for transformations+newtype T x = T { unT :: x -> x }++-- | The type constructor for transformations+newtype M m x = M { unM :: x -> m x }++-- | The type constructor for queries+newtype Q q x = Q { unQ :: x -> q }++-- | The type constructor for readers+newtype R m x = R { unR :: m x }++-- | The type constructor for builders+newtype B x = B {unB :: x}