A-gent (empty) → 0.11.0.18
raw patch · 24 files changed
Files
- A-gent.cabal +177/−0
- CHANGELOG.md +317/−0
- LICENSE.md +29/−0
- README.md +108/−0
- Setup.hs +20/−0
- src/Agent/Control/Concurrent.hs +85/−0
- src/Agent/Control/IFC.hs +81/−0
- src/Agent/Control/MAC.hs +147/−0
- src/Agent/Data/ANSI/EscapeCode.hs +224/−0
- src/Agent/Data/JSON.hs +64/−0
- src/Agent/IO/Effects.hs +216/−0
- src/Agent/IO/Restricted.hs +95/−0
- src/Agent/LLM.hs +770/−0
- src/Agent/LLM/Action.hs +74/−0
- src/Agent/LLM/Message.hs +48/−0
- 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
- src/Internal/LLM.hs +191/−0
- src/Internal/LLM/Action.hs +48/−0
- src/Internal/RIO.hs +1627/−0
- src/Internal/Utils.hs +131/−0
+ A-gent.cabal view
@@ -0,0 +1,177 @@+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.11.0.18++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+ +license: SSPL-1.0 OR AGPL-3.0-only+license-file: LICENSE.md+ +author: SPISE MISU+maintainer: SPISE MISU <mail+hackage@spisemisu.com>+copyright: (c) 2026 SPISE MISU ApS+ +stability: experimental+ +category: Agent, LLM+ +extra-doc-files: README.md, CHANGELOG.md++tested-with:+ GHC == 9.4.8+ GHC == 9.6.7+ GHC == 9.8.4+ GHC == 9.10.3+ GHC == 9.12.2+ +source-repository head+ type:+ git+ location:+ https://gitlab.com/a-gent/a-gent+ +--------------------------------------------------------------------------------+-- COMMON+--------------------------------------------------------------------------------++common base+ default-extensions:+ Safe+ default-language:+ Haskell2010+ build-depends:+ -- Prelude+ base >= 4 && < 5+ -- Process+ -- NOTE: github.com/NixOS/hydra builds with stackage lastest LST (24.…)+ -- and stackage only has 'containers 0.7' while hackage has '0.8'+ , process >= 1.6.25.0 && < 2+ , containers >= 0.7 && < 1+ -- JSON+ , 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+ -- Process+ -trust=process+ -trust=array+ -trust=ghc-prim+ -trust=deepseq+ -- JSON+ -trust=containers+ -trust=mtl+ if impl(ghc >= 9.10 && < 9.13) + ghc-options:+ -- Base+ -- NOTE: Issue with Hackage that builds with 9.8.4. 9.10.x requies this:+ -trust=ghc-internal++library+ import:+ base+ hs-source-dirs:+ src+ other-modules:+ -- error: [GHC-87110]+ -- Could not load module ‘Internal.…’.+ -- it is a hidden module in the package ‘A-gent-0.11.0.…’+ Internal.GaloisInc.Text.JSON+ Internal.GaloisInc.Text.JSON.Generic+ Internal.GaloisInc.Text.JSON.String+ Internal.GaloisInc.Text.JSON.Types+ --+ Internal.GlasgowUniversity.Data.Generics.Aliases+ --+ Internal.RIO+ --+ Internal.LLM+ Internal.LLM.Action+ --+ Internal.Utils+ exposed-modules:+ Agent.Control.Concurrent+ Agent.Control.IFC+ Agent.Control.MAC+ --+ Agent.Data.ANSI.EscapeCode+ Agent.Data.JSON+ --+ Agent.IO.Effects+ Agent.IO.Restricted+ --+ Agent.LLM+ Agent.LLM.Action+ Agent.LLM.Message++-- Reference+--+-- - https://cabal.readthedocs.io/en/latest/cabal-package-description-file.html#pkg-field-tested-with
+ CHANGELOG.md view
@@ -0,0 +1,317 @@+# Revision history for Λ-gent++## 0.11.0.18 -- 2026-05-18++* Added the `/drop` command to remove end-user provided `load` will help clear+ the context sent to the LLM when using basic chat capabilities.+ +* Refactored the main `chat` web script due to the addition of the `/drop`+ command. Also added the result of executing the script:+ + ```sh+ # Exit Λ-gent with /e or /exit. For more commands, type /? or /help.+ Λ-chat> ping+ Message {role = "assistant", content = "*PING*"}+ Λ-chat> /drop+ Dropping end-user data load+ Λ-chat> If I write ping, you write pong. If I write pong, you write ping+ Message {role = "assistant", content = "That sounds like a fun game. I'm ready."}+ Λ-chat> pong+ Message {role = "assistant", content = "ping"}+ Λ-chat> pong+ Message {role = "assistant", content = "ping"}+ Λ-chat> ping+ Message {role = "assistant", content = "pong"}+ Λ-chat> pong+ Message {role = "assistant", content = "ping"}+ Λ-chat> /drop+ Dropping end-user data load+ Λ-chat> ping+ Message {role = "assistant", content = "*PING*"}+ Λ-chat> + ```++## 0.11.0.17 -- 2026-05-18++* Inconsistency between `Linux` and `macOS` when it comes to default option for+ `pwd`:+ + * If no option is specified, `-P` is assumed (Linux)+ + * If no options are specified, the `-L` option is assumed (macOS)+ + ```+ -L, --logical use PWD from environment, even if it contains symlinks+ -P, --physical resolve all symlinks+ ```++* Removing exported helper functions from `Internal.RIO` that weren't used by+ any other module.++## 0.11.0.16 -- 2026-05-14++* The Action and Message modules need to expose used types from the internal LLM+ module as well.++## 0.11.0.15 -- 2026-05-14++* Internal LLM types MUST be exposed by LLM module.++## 0.11.0.14 -- 2026-05-14++* Ensured not to expose internal types. We import and re-export for type+ signatures, but not the constructors.++## 0.11.0.13 -- 2026-05-14++* Updated scripts from website with changes from `0.11.0.12`.++ > **NOTE:** Due to changes in this release, we need to check and update once+ > again.++* Checked scripts on `macOS` with changes from `0.11.0.12`.++ > **NOTE:** As before, with changes from this release, we need to check once+ > again.++* Moved `Message` and `Action` to their own modules. For `Action`, we also add+ an internal module to avoid exposing type constructors.++* Ensured not to expose internal types. We import and re-export for type+ signatures, but not the constructors.++## 0.11.0.12 -- 2026-05-12++There have been made some **major changes** to this library and therefore there+is no backwards compatibility with previous versions:++* Added support for `Code` mode, as in `read` and `write` files back and forth+ to the `git` repository. A new tab will be added to the website with a script+ explaining usage.++* Added support for script integrity as known from `HTML`:++ ```+ <script integrity="sha256-YBbjT3uJjnS6ofC6HIal+4vNvgA9vZBfC/KMVN51URc=" …></script>+ ```+ + If the `LLM_SIGN_SHA` environment variable is provided on execution, the+ script will check it's own file `SHA-256` hash and compare to the provided:+ + ```+ # Λ-gent integrity failed:+ > 2d3c326e2991da5876b820fe128c3840d3c0664c43907ce725f3f3f26f2fbabc (expected)+ > 8f89a79f891ce329a6142c68962fcad0b438e7d0b80c9410f0141cc6c02437d0 (observed)+ ```++* Adding `uuid` to main context future purposes.++* Due to refactoring, the context lost a few properties (ex: `exit`, `hist`,+ `root`, …) and some of the internals have changed. Still same output, but,+ less chaotic. Furthermore, `rootPath` is no longer needed.++* Due to refactoring, some of the exposed utils are no longer+ relevant. Therefore, they are moved to an internal module.++* Removed quotes from `curl` headers as some `LLM` API's would parse them, but+ others would not.++* Followed up on binary flags as we need to have the **least common** between+ `Linux` distros and `macOS`.++* Added the `/atom` and `/repo` commands to help parse and store files received+ from LLM's `atomically` with help of `git worktree` as well as list the+ produced `git branches`.++* Added `message` and `action` types simplify and make more robust the+ interactions between user and `Λ-gent`.++* Wrapped `withExitCode…` functions in `try` (`Control.Exception`) to ensure the+ `Λ-gents` don't crash and burn. Also wrapped `read` and `write` files as well+ with `try`.++## 0.11.0.11 -- 2026-04-19++* Fixed a few misspells.++* Refactored `Files` to `FilePaths`.++* Refactored `Document(s)` to already existing `File(s)` for simplicity.++* Excluding non-files (symbolic links) from search as this could bypass the+ limitation of the current working directory.++## 0.11.0.10 -- 2026-04-17++* Minor bug fixes and misspells.++* Moved Agent/JSON.hs to Agent/Data/JSON.hs++## 0.11.0.9 -- 2026-04-16++* Minor bug fixes.++## 0.11.0.8 -- 2026-04-15++* Refactored `/pile` to no longer storing a `find` filter but the absolute path+ to the `find` results.+ + > **NOTE:** Even though absolute path is stored, only relative will be shown.+ +* `/list` performance has been improved instead of performing the filters with+ Haskell, it's now passed to the `find` command.+ +* Added logic to request `ISO-8601` timestamps (`UTC`) that are file path safe.++* Added to website, info tab, a guide on how to setup LSP support for IDE's:++ * https://a-gent.org/info.html#lsp-support-for-ides+ +* Due to future `git-worktree` usage, the folder `/tmp/` MUST exist in the root+ of the project and it needs to be added to the `.gitignore` file to avoid+ `GIT` collisions.+ +* Added `Internal.RIO` so the application can execute `RestrictedIO`, but,+ consumers of the `Λ-gent` package will NOT.++* All `Context` properties, except `load`, have now `internal` constructor+ types. This will ensure that we will know that they have been instantiated by+ the `Λ-gents`.+ +* From `0.11.0.6 -- 2026-03-20` below:+ + > **NOTE**: Fix is not verified. Well, this update will confirm (or not).+ + * Package is NO longer marked as broken: https://github.com/NixOS/nixpkgs/blob/haskell-updates/pkgs/development/haskell-modules/configuration-hackage2nix/broken.yaml++* Added `withExitCodeStdIn` as `curl` has a limit on data that can be sent as a+ parameter.++* A `Agent.Data.ANSI.EscapeCode` module has been added to help distinguish+ between input/output.++* `/send` (`/s`) has been added to provide the capability of sending `/pile`+ files as context to messages sent to LLM's.++* `repl` and `replWithMode` now need to provide an optional value for the+ projects `rootPath`. This refactoring has been added to ease logic+ implementation for the `Λ-gent` package.+ + > **NOTE**: Changes to current existing Λ-gent scripts can be done by just+ > post-fixing `Nothing`. Example: `replWithMode Echo eval Nothing`++## 0.11.0.7 -- 2026-03-30++* We seem to have fixed multi-line issues. I guess we can say that we are+ probably as good as `GHCi`.+ + > **NOTE:** A thorough refactoring needs to be done to enforce `DRY`.++* Added support for:++ * `CTRL + L` clear screen.+ + * `CTRL + U` clear text from current position to start of input.+ + * `CTRL + K` clear text from current position to end of input.+ + * `CTRL + A` equivalent to `HOME`.+ + * `CTRL + E` equivalent to `END`.+ + * `CTRL + D` equivalent to `DELETE`.++## 0.11.0.6 -- 2026-03-20++* Added a `todo.org` file in the root folder of the project. This will allow to+ see current, but also future, status of the project.++* Expanded file capabilities for `Code` and `Plan`.++ * Files will be shown with `relative` paths. However, they will be handled+ with `absolute` paths under the hood.++* Added a few more `REPL` commands and improvements to typing.++ * **NOTE**: There is a `bug` with regard of multi-line text. Hopefully it will+ be fixed shortly.++* No longer on Bluesky and therefore, removed from `cabal` file.++* Issue with `haskellPackages` on `NixOS`. It seems that they use `stack` to+ build with the latest `LTS`. The fix is to change in the `cabal` file the+ following version contraint: `containers >= 0.7 && < 1` as `stackage` only has+ the version `0.7` of the `containers` package.+ + * **NOTE**: Fix is not verified. Well, this update will confirm (or not).++* Added the `Agent.Control.Concurrent` module to provide support for+ asynchronous tasks.++* Added `Agent.Utils` modules to help for the respective `modes`. This will help+ keep `Λ-gent` code small by providing ready to plug code bloks.++## 0.11.0.5 -- 2026-03-08++* `ENTER` only triggers if something is typed.++## 0.11.0.4 -- 2026-03-08++* Fixed the `BUG` when trying to print emojii's ('🍎', '🍏', …):++ ```shell+ <stdout>: hPutChar: invalid argument (cannot encode character '\55357'+ ```+ + by adding `setLocaleEncoding utf8` to `replWithMode`. Now instead of crashing,+ invalid `UTF-8` characters will just be shown as single or multiple `?`.++## 0.11.0.3 -- 2026-03-06++* Made `read` usable by providing support for:++ * `BACKSPACE` and `DELETE` to remove characters.+ + * Move back and forth with `←` & `→` (single characters) and `CTRL + ←` &+ `CTRL + →` (words).+ + * Move to start and end of the text with `HOME` and `END`.++## 0.11.0.2 -- 2026-03-05++* Fixed issue with Hackage. The project now builds for:++ * `ghc-9.4.8`+ + * `ghc-9.6.7`+ + * `ghc-9.8.4`+ + * `ghc-9.10.3`+ + * `ghc-9.12.2`++## 0.11.0.1 -- 2026-03-05++* Issue with Hackage. Since the service builds with `9.8.4` we have to comply+ with that.++## 0.11.0.0 -- 2026-03-04++* 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++* First version. Released on an unsuspecting world.++## References++* Use of a fourth component [Version scheme][haskell-stack-ver].++[haskell-stack-ver]: https://docs.haskellstack.org/en/stable/maintainers/version_scheme/#use-of-a-fourth-component
+ 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
@@ -0,0 +1,108 @@+Λ-gent+======++[](https://hackage.haskell.org/package/A-gent)++`Λ-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].++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++Project structure+=================++```sh+├── doc+│ └── TODO.md+├── src+│ ├── Agent+│ │ ├── Control+│ │ │ ├── Concurrent.hs+│ │ │ ├── IFC.hs+│ │ │ └── MAC.hs+│ │ ├── Data+│ │ │ ├── ANSI+│ │ │ │ └── EscapeCode.hs+│ │ │ └── JSON.hs+│ │ ├── IO+│ │ │ ├── Effects.hs+│ │ │ └── Restricted.hs+│ │ └── LLM.hs+│ └── Internal+│ ├── GaloisInc+│ │ └── Text+│ │ ├── JSON+│ │ │ ├── Generic.hs+│ │ │ ├── String.hs+│ │ │ └── Types.hs+│ │ ├── JSON.hs+│ │ ├── LICENSE+│ │ └── NOTES.md+│ ├── GlasgowUniversity+│ │ ├── Data+│ │ │ └── Generics+│ │ │ └── Aliases.hs+│ │ ├── LICENSE+│ │ └── NOTES.md+│ ├── LLM.hs+│ ├── RIO.hs+│ └── Utils.hs+├── uat+│ └── TODO.md+├── A-gent.cabal+├── CHANGELOG.md+├── LICENSE.md+├── LICENSE_AGPL-3.0-only.txt+├── LICENSE_SSPL-1.0.txt+├── README.md+├── Setup.hs+└── todo.org+```++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
+ Setup.hs view
@@ -0,0 +1,20 @@+{-# OPTIONS_GHC -Wall -Werror #-}++--------------------------------------------------------------------------------++-- |+-- Copyright : (c) 2026 SPISE MISU ApS+-- License : SSPL-1.0 OR AGPL-3.0-only+-- Maintainer : SPISE MISU <mail+hackage@spisemisu.com>+-- Stability : experimental++--------------------------------------------------------------------------------++import Distribution.Simple+ ( defaultMain+ )++--------------------------------------------------------------------------------++main :: IO ()+main = defaultMain
+ src/Agent/Control/Concurrent.hs view
@@ -0,0 +1,85 @@+{-# OPTIONS_GHC -Wall -Werror #-}++{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}+{-# LANGUAGE Safe #-}++{-# LANGUAGE LambdaCase #-}++--------------------------------------------------------------------------------++-- |+-- 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.Control.Concurrent+ ( Async+ , Task+ , fork+ , wait+ , join+ )+where++--------------------------------------------------------------------------------++import Control.Concurrent ( ThreadId, forkFinally )+import Control.Concurrent.MVar+ ( MVar+ , newEmptyMVar+ , putMVar+ , readMVar+ )+import GHC.Exception ( SomeException, throw )++--------------------------------------------------------------------------------++data Task a = Task !ThreadId (IO (Either SomeException a))++--------------------------------------------------------------------------------++-- |+-- To prevent the users from adding instances of `Async`, we+-- provide a middle-layer (`Proxy`) between the `Monad` instance and the `Proxy`+-- (`Async`) instance.++class Monad m => Proxy m where+ new :: m (MVar a)+ put :: MVar a -> a -> m ( )+ get :: MVar a -> m a+class Proxy m => Async m where+ fork :: m a -> m (Task a)+ wait :: Task a -> m a+ join :: [ Task a ] -> m ( )++--------------------------------------------------------------------------------++instance Proxy IO where+ -- | newEmptyMVar: Create an MVar which is initially empty.+ new = newEmptyMVar+ -- | putMVar: Put a value into an MVar.+ put = putMVar+ -- |+ -- readMVar: Atomically read the contents of an MVar. If the MVar is currently+ -- empty, readMVar will wait until it is full. readMVar is guaranteed to+ -- receive the next putMVar.+ get = readMVar++instance Async IO where+ fork compute =+ new >>= \ var ->+ forkFinally compute (finally var) >>= \ tid ->+ pure $ Task tid $ get var+ where+ finally v r = put v r+ wait (Task _ mvar) =+ ( \case+ Right v -> v+ Left e -> throw e+ )+ <$> mvar+ join =+ mapM_ wait
+ src/Agent/Control/IFC.hs view
@@ -0,0 +1,81 @@+{-# OPTIONS_GHC -Wall -Werror #-}++{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}+{-# LANGUAGE Safe #-}++{-# 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,147 @@+{-# OPTIONS_GHC -Wall -Werror #-}++{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}+{-# LANGUAGE Safe #-}++--------------------------------------------------------------------------------++-- |+-- 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/Data/ANSI/EscapeCode.hs view
@@ -0,0 +1,224 @@+{-# OPTIONS_GHC -Wall -Werror #-}++{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}+{-# LANGUAGE Safe #-}++--------------------------------------------------------------------------------++-- |+-- 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.Data.ANSI.EscapeCode+ ( -- * Type signatures+ SelectGraphicRendition+ , Blink+ , Bright+ , Background+ , Foreground+ -- * Enums+ , Colour+ ( Black+ , Red+ , Green+ , Yellow+ , Blue+ , Magenta+ , Cyan+ , White+ )+ , Frequency+ ( Slow+ , Fast+ )+ -- * Methods+ , sgr+ , foreground+ , background+ , bold+ , faint+ , italic+ , underline+ , blink+ )+where++--------------------------------------------------------------------------------++data Colour+ = Black+ | Red+ | Green+ | Yellow+ | Blue+ | Magenta+ | Cyan+ | White+ deriving (Eq)++instance Enum Colour where+ fromEnum Black = 0+ fromEnum Red = 1+ fromEnum Green = 2+ fromEnum Yellow = 3+ fromEnum Blue = 4+ fromEnum Magenta = 5+ fromEnum Cyan = 6+ fromEnum White = 7++ toEnum 0 = Black+ toEnum 1 = Red+ toEnum 2 = Green+ toEnum 3 = Yellow+ toEnum 4 = Blue+ toEnum 5 = Magenta+ toEnum 6 = Cyan+ toEnum 7 = White+ toEnum _ = error "Colour code not supported"++type Bright = Bool++data Background = BG !Bool Bright Colour+data Foreground = FG !Bool Bright Colour++data Frequency+ = Slow+ | Fast++data Blink = B !Bool Frequency++data SelectGraphicRendition+ = SGR !Background !Foreground !Bool !Bool !Bool !Bool !Blink String++instance Show SelectGraphicRendition where+ show (SGR bg fg bo fa it un bl text) =+ "\ESC[" +++ "0" +++ (cb bg) +++ (cf fg) +++ (fb bo) +++ (ff fa) +++ (fi it) +++ (fu un) +++ (bf bl) +++ "m" +++ text +++ "\ESC[00m"+ where+ cb (BG True True c) = ";" ++ (show $ 60 + 40 + fromEnum c)+ cb (BG True False c) = ";" ++ (show $ 40 + fromEnum c)+ cb (BG False _____ _) = [ ]+ cf (FG True True c) = ";" ++ (show $ 60 + 30 + fromEnum c)+ cf (FG True False c) = ";" ++ (show $ 30 + fromEnum c)+ cf (FG False _____ _) = [ ]+ fb True = ";01"+ fb False = [ ]+ ff True = ";02"+ ff False = [ ]+ fi True = ";03"+ fi False = [ ]+ fu True = ";04"+ fu False = [ ]+ bf (B True Slow) = ";05"+ bf (B True Fast) = ";06"+ bf (B False ____) = [ ]++--------------------------------------------------------------------------------++sgr+ :: String+ -> SelectGraphicRendition++foreground+ :: Bright+ -> Colour+ -> SelectGraphicRendition+ -> SelectGraphicRendition++background+ :: Bright+ -> Colour+ -> SelectGraphicRendition+ -> SelectGraphicRendition++bold+ :: SelectGraphicRendition+ -> SelectGraphicRendition++faint+ :: SelectGraphicRendition+ -> SelectGraphicRendition++italic+ :: SelectGraphicRendition+ -> SelectGraphicRendition++underline+ :: SelectGraphicRendition+ -> SelectGraphicRendition++blink+ :: Frequency+ -> SelectGraphicRendition+ -> SelectGraphicRendition++--------------------------------------------------------------------------------++sgr =+ SGR bg fg bo fa it un bl+ where+ fg = FG False undefined undefined+ bg = BG False undefined undefined+ bo = False+ fa = False+ it = False+ un = False+ bl = B False undefined++--------------------------------------------------------------------------------++foreground b c (SGR bg __ bo fa it un bl txt) =+ SGR bg fg bo fa it un bl txt+ where+ fg = FG True b c++background b c (SGR __ fg bo fa it un bl txt) =+ SGR bg fg bo fa it un bl txt+ where+ bg = BG True b c++bold (SGR bg fg __ fa it un bl txt) =+ SGR bg fg bo fa it un bl txt+ where+ bo = True++faint (SGR bg fg bo __ it un bl txt) =+ SGR bg fg bo fa it un bl txt+ where+ fa = True++italic (SGR bg fg bo fa __ un bl txt) =+ SGR bg fg bo fa it un bl txt+ where+ it = True++underline (SGR bg fg bo fa it __ bl txt) =+ SGR bg fg bo fa it un bl txt+ where+ un = True++blink f (SGR bg fg bo fa it un __ txt) =+ SGR bg fg bo fa it un bl txt+ where+ bl = B True f++--------------------------------------------------------------------------------++-- References+--+-- ANSI escape code:+-- * https://en.wikipedia.org/wiki/ANSI_escape_code#SGR_parameters
+ src/Agent/Data/JSON.hs view
@@ -0,0 +1,64 @@+{-# OPTIONS_GHC -Wall -Werror #-}++{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}+{-# LANGUAGE Safe #-}++--------------------------------------------------------------------------------++-- |+-- 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.Data.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/IO/Effects.hs view
@@ -0,0 +1,216 @@+{-# OPTIONS_GHC -Wall -Werror #-}++{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}+{-# LANGUAGE Safe #-}++--------------------------------------------------------------------------------++-- |+-- 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 (Config)+ LlmConf(llmPathCWD)+ -- * LLM (Chat)+ , LlmChatConf(llmChatKey, llmChatAPI)+ , LlmChatPost(llmChatWeb)+ , -- * LLM (Code)+ LlmCodeRoot(llmCodeDir)+ , LlmCodeMask(llmCodeMsk)+ , LlmCodeTmpl(llmCodeIns, llmCodeExa)+ , LlmCodeRead(llmCodeSeq, llmCodeGet, llmCodeGit)+ , LlmCodeSave(llmCodePut)+ , LlmCodeConf(llmCodeKey, llmCodeAPI)+ , LlmCodePost(llmCodeWeb)+ , -- * LLM (Plan)+ LlmPlanRoot(llmPlanDir)+ , LlmPlanMask(llmPlanMsk)+ , LlmPlanRead(llmPlanSeq, llmPlanGet)+ , LlmPlanConf(llmPlanKey, llmPlanAPI)+ , LlmPlanPost(llmPlanWeb)+ )+where++--------------------------------------------------------------------------------++import qualified Internal.LLM as LLM++--------------------------------------------------------------------------------++class+ Monad m+ => LlmConf m+ where+ llmPathCWD+ :: m (Maybe LLM.Root)++--------------------------------------------------------------------------------+--------------------------------------------------------------------------------++class+ Monad m+ => LlmChatConf m+ where+ llmChatAPI+ :: m (Maybe String)+ llmChatKey+ :: m (Maybe String)++--------------------------------------------------------------------------------++class+ LlmChatConf m+ => LlmChatPost m+ where+ llmChatWeb+ :: String+ -> m (Either String String)++--------------------------------------------------------------------------------+--------------------------------------------------------------------------------++class+ Monad m+ => LlmCodeRoot m+ where+ llmCodeDir+ :: m String -- Ex: "src"++--------------------------------------------------------------------------------++class+ Monad m+ => LlmCodeMask m+ where+ llmCodeMsk+ :: m [ String ] -- Ex: [ "*.hs", "*.lhs" ]++--------------------------------------------------------------------------------++class+ Monad m+ => LlmCodeTmpl m+ where+ llmCodeIns+ :: m [LLM.File]+ llmCodeExa+ :: m [LLM.File]++--------------------------------------------------------------------------------++class+ ( LlmConf m+ , LlmCodeRoot m+ , LlmCodeMask m+ )+ => LlmCodeRead m+ where+ llmCodeSeq+ :: Maybe LLM.Filter+ -> m (Either [String] LLM.FilePaths)+ llmCodeGet+ :: LLM.AbsoluteFilePath+ -> m (Either String LLM.File)+ llmCodeGit+ :: m (Either String String)++--------------------------------------------------------------------------------++class+ ( LlmConf m+ , LlmCodeRoot m+ )+ => LlmCodeSave m+ where+ llmCodePut+ :: String+ -> LLM.Files+ -> m (Either String String)++--------------------------------------------------------------------------------++class+ Monad m+ => LlmCodeConf m+ where+ llmCodeAPI+ :: m (Maybe String)+ llmCodeKey+ :: m (Maybe String)++--------------------------------------------------------------------------------++class+ LlmCodeConf m+ => LlmCodePost m+ where+ llmCodeWeb+ :: String+ -> m (Either String String)++--------------------------------------------------------------------------------+--------------------------------------------------------------------------------++class+ Monad m+ => LlmPlanRoot m+ where+ llmPlanDir+ :: m String -- Ex: "llm"++--------------------------------------------------------------------------------++class+ Monad m+ => LlmPlanMask m+ where+ llmPlanMsk+ :: m [ String ] -- Ex: [ "plan_*.md" ]++--------------------------------------------------------------------------------++class+ ( LlmConf m+ , LlmPlanRoot m+ , LlmPlanMask m+ , LlmCodeRead m+ )+ => LlmPlanRead m+ where+ llmPlanSeq+ :: Maybe LLM.Filter+ -> m (Either [String] LLM.FilePaths)+ llmPlanGet+ :: String+ -> m (Either String LLM.File)++--------------------------------------------------------------------------------++class+ Monad m+ => LlmPlanConf m+ where+ llmPlanAPI+ :: m (Maybe String)+ llmPlanKey+ :: m (Maybe String)++--------------------------------------------------------------------------------++class+ ( LlmConf m+ , LlmPlanConf m+ )+ => LlmPlanPost m+ where+ llmPlanWeb+ :: String+ -> m (Either String String)++--------------------------------------------------------------------------------+--------------------------------------------------------------------------------
+ src/Agent/IO/Restricted.hs view
@@ -0,0 +1,95 @@+{-# OPTIONS_GHC -Wall -Werror #-}++{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}+{-# LANGUAGE Safe #-}++--------------------------------------------------------------------------------++-- |+-- 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+ -- * Environment+ , getEnvVar+ -- * LLM (Config)+ , llmPathCWD+ -- * LLM (Chat)+ , llmChatKey, llmChatAPI+ , llmChatWeb+ -- * LLM (Code)+ , llmCodeDir+ , llmCodeMsk+ , llmCodeIns, llmCodeExa+ , llmCodeSeq, llmCodeGet, llmCodeGit+ , llmCodePut+ , llmCodeKey, llmCodeAPI+ , llmCodeWeb+ -- * LLM (Plan)+ , llmPlanDir+ , llmPlanMsk+ , llmPlanSeq, llmPlanGet+ , llmPlanKey, llmPlanAPI+ , llmPlanWeb+ )+where++--------------------------------------------------------------------------------++import Internal.RIO ( RIO )++import Internal.RIO ( getEnvVar )++import Internal.RIO+ ( llmChatAPI+ , llmChatKey+ , llmChatWeb+ , llmCodeAPI+ , llmCodeDir+ , llmCodeExa+ , llmCodeGet+ , llmCodeGit+ , llmCodeIns+ , llmCodeKey+ , llmCodeMsk+ , llmCodePut+ , llmCodeSeq+ , llmCodeWeb+ , llmPathCWD+ , llmPlanAPI+ , llmPlanDir+ , llmPlanGet+ , llmPlanKey+ , llmPlanMsk+ , llmPlanSeq+ , llmPlanWeb+ )
+ src/Agent/LLM.hs view
@@ -0,0 +1,770 @@+{-# OPTIONS_GHC -Wall -Werror #-}++{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}+{-# LANGUAGE Safe #-}++{-# 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+ ( -- * Modes+ Mode(..)+ -- * Context+ , Context(..)+ , AbsoluteFilePath+ , Chat+ , Chit+ , File+ , FileLine+ , FilePaths+ , Files+ , Filter+ , History+ , Load+ , Mask+ , Root+ , Template+ , UUID+ -- * Paramenters+ , Eval+ -- * Methods+ , repl+ , replWithMode+ )+where++--------------------------------------------------------------------------------++import Prelude hiding ( head, mod, print, read )+++import Data.Char ( toLower, toUpper )+import Data.Maybe ( fromMaybe )+import GHC.IO.Encoding ( setLocaleEncoding )+import System.Environment ( getProgName )+import qualified System.Environment.Blank as ENV+import System.Exit+ ( ExitCode (ExitFailure, ExitSuccess)+ )+import System.IO+ ( BufferMode (LineBuffering, NoBuffering)+ , hFlush+ , hSetBuffering+ , hSetEcho+ , stderr+ , stdin+ , stdout+ , utf8+ )+import System.Process ( readProcessWithExitCode )+import Text.Read ( readMaybe )++import Internal.LLM+ ( AbsoluteFilePath+ , Chat+ , Chit (..)+ , File+ , FileLine+ , FilePaths+ , Files+ , Filter+ , History (..)+ , Mask+ , Mode (..)+ , Root+ , Template+ , UUID+ , modes+ )+import qualified Internal.LLM as INT+import Internal.LLM.Action ( Action (..) )+import Internal.RIO ( RIO (..), input, output )+import qualified Internal.Utils as UTL++import qualified Agent.Data.ANSI.EscapeCode as AEC+import qualified Agent.LLM.Message as MSG++import Agent.Data.JSON ( Data )+import Agent.LLM.Message ( Message )+++--------------------------------------------------------------------------------++type Load a =+ ( Data a+ , Show a+ )+ => Maybe a++data Context a =+ Context+ { uuid :: !UUID+ , mode :: !Mode+ , load :: !(Load a)+ , hist :: !History+ , list :: !(Maybe Filter)+ , pile :: !(Maybe FilePaths)+ , ruck :: !(Maybe Files)+ }++type Eval a =+ Context a+ -> Message+ -> RIO (Context a, Action)++--------------------------------------------------------------------------------++repl+ :: Eval a+ -> IO ()+repl =+ replWithMode INT.Chat++replWithMode+ :: INT.Mode+ -> Eval a+ -> IO ()+replWithMode mod proc =+ do+ constraint <- integrity+ case constraint of+ Right __ ->+ do+ setLocaleEncoding utf8+ hSetBuffering stderr NoBuffering+ hSetBuffering stdin NoBuffering+ -- NOTE: logic based on `hFlush stdout`+ hSetBuffering stdout LineBuffering+ -- NOTE: No default output when typing+ hSetEcho stdin False+ putStrLn head >> hFlush stdout+ run $ loop ctx proc+ Left err ->+ putStrLn err >> hFlush stdout+ where+ ctx =+ Context+ { uuid = INT.UUID []+ , mode = mod+ , load = Nothing+ , hist =+ History+ { chit =+ Chit+ { prev = []+ , next = []+ }+ , chat = []+ }+ , list = Nothing+ , pile = Just $ INT.FilePaths []+ , ruck = Just $ INT.Files []+ }++--------------------------------------------------------------------------------++-- HELPERS (private)++{- NOTE: Doesn't seem to work+ctrlC :: IO () -> IO ()+ctrlC task =+ -- NOTE: Catch CTRL+C+ -- https://neilmitchell.blogspot.com/2015/05/handling-control-c-in-haskell.html+ sync . (:[]) <$> fork task+-}++head :: String+head =+ "# Exit Λ-gent with /e or /exit. For more commands, type /? or /help."++help :: String+help =+ unlines+ [ "# Supported commands:"+ , ds+ , "/? or /help | This message"+ , "/e or /exit | Exit Λ-gent"+ , "/w or /wipe | Wipe screen"+ , "/d or /drop | Drop end-user data load"+ , ds+ , "/m m or /mode m | Change to {" ++ ms ++ "}. Ex: /m plan"+ , ds+ , "/h or /hist | View history (input and output)"+ , " /chit | View history (only input) "+ , " /chat | View history (only output)"+ , ds+ , "/l f or /list f | List of files, limited by mode, file masks and filter"+ , "/p or /pile | Show stored list of files. See /list above"+ , "/f i or /file i | Show file with the given index. See /pile above"+ , "/n i or /nums i | Show file with line numbers. See /file above"+ , ds+ , "/s m or /send m | Sending /pile to LLM as context to the message"+ , "/r o or /ruck o | View files (opt index) from LLM response. See /send"+ , "/a d or /atom d | Atomically save /ruck files to a GIT branch (+ description)"+ , " /repo | List GIT branches (+ description). See /atom above"+ , ds+ ]+ where+ ds = replicate 80 '-'+ ms =+ foldl1 (\ x y -> x ++ "|" ++ y) $ map (map toLower . show) modes++loop+ :: Context a+ -> Eval a+ -> RIO ()+loop ctx eval =+ print prompt >>+ read hps hns >>= \ txt ->+ printLn [ ] >>+ case txt2act txt of+ -- TODO: Refactoring needed++ -- Nested -- Start+ None ->+ loop (nxt txt ctx Nothing) eval+ File _ ->+ loop (nxt txt ctx Nothing) eval+ Template _ _ _ _ ->+ loop (nxt txt ctx Nothing) eval+ -- Nested -- Stop++ Exit -> caseExit+ Help -> caseHelp txt+ Drop -> caseDrop txt+ Hist (chits, chats) -> caseHist txt chits chats+ Mode c cs -> caseMode txt c cs+ Paths (INT.FilePaths fps) -> casePaths txt fps+ Pile -> casePile txt+ Ruck mdix -> caseRuck txt mdix+ Wipe -> caseWipe txt+ UnknownCmd cmd -> caseUnknownCmd txt cmd++ Branch msg fs ->+ eval ctx (MSG.Atom msg fs) >>= \ (upd, action) ->+ case action of+ Message (MSG.Text cs) ->+ printLn cs >>+ loop (nxt txt upd (Just cs)) eval+ None ->+ loop (nxt txt upd Nothing) eval+ _________________________ ->+ -- NOTE: Unexpected error+ printLn "Unexpected error" >>+ loop (nxt txt upd (Just [])) eval++ Prompt msg ->++ eval ctx (MSG.Tmpl afps) >>= \ (upd0, action0) ->+ case action0 of+ Template f is es fs ->++ eval ctx (MSG.Send xml) >>= \ (upd1, action1) ->+ case action1 of+ Message (MSG.Text cs) ->+ printLn cs >>+ loop+ ( nxt txt+ ( upd1 { ruck = Just $ pfs }+ )+ ( Just cs+ )+ ) eval+ where+ pfs =+ case (map INT.File . f) cs of+ [] -> INT.Files []+ xs -> INT.Files xs+ None ->+ loop (nxt txt upd1 Nothing) eval+ _________________________ ->+ -- NOTE: Unexpected error+ printLn "Unexpected error" >>+ loop (nxt txt upd1 (Just [])) eval+ where+ ils = map ( \ (INT.File (_, ls)) -> unlines ls) is+ els = map ( \ (INT.File (_, ls)) -> unlines ls) es+ tpl = INT.Template msg ils els fs+ xml = INT.tpl2xmls tpl++ Message (MSG.Text cs) ->+ printLn cs >>+ loop (nxt txt upd0 (Just cs)) eval+ None ->+ loop (nxt txt upd0 Nothing) eval+ _________________________ ->+ -- NOTE: Unexpected error+ printLn "Unexpected error" >>+ loop (nxt txt upd0 (Just [])) eval+ where+ afps =+ ( \ (INT.FilePaths fps) -> map INT.AbsoluteFilePath fps+ )+ <$> pile ctx++ Message (MSG.Path ns afp) ->+ eval ctx (MSG.Path ns afp) >>= \ (upd, action) ->+ case action of+ File (INT.File (_,ls)) ->+ caseFile txt ns ls+ Message (MSG.Text cs) ->+ printLn cs >>+ loop (nxt txt upd (Just cs)) eval+ None ->+ loop (nxt txt upd Nothing) eval+ _________________________ ->+ -- NOTE: Unexpected error+ printLn "Unexpected error" >>+ loop (nxt txt upd (Just [])) eval++ Message (MSG.List fil) ->+ eval ctx (MSG.List fil) >>= \ (upd, action) ->+ case action of+ Paths (INT.FilePaths fps) ->+ casePaths txt fps+ Message (MSG.Text cs) ->+ printLn cs >>+ loop (nxt txt upd (Just cs)) eval+ None ->+ loop (nxt txt upd Nothing) eval+ _________________________ ->+ -- NOTE: Unexpected error+ printLn "Unexpected error" >>+ loop (nxt txt upd (Just [])) eval++ Message MSG.Repo ->+ eval ctx MSG.Repo >>= \ (upd, action) ->+ case action of+ Message (MSG.Text cs) ->+ printLn cs >>+ loop (nxt txt upd (Just cs)) eval+ None ->+ loop (nxt txt upd Nothing) eval+ _________________________ ->+ -- NOTE: Unexpected error+ printLn "Unexpected error" >>+ loop (nxt txt upd (Just [])) eval++ Message msg ->+ eval ctx msg >>= \ (upd, action) ->+ case action of+ Message (MSG.Text cs) ->+ printLn cs >>+ loop (nxt txt upd (Just cs)) eval+ None ->+ loop (nxt txt upd Nothing) eval+ _________________________ ->+ -- NOTE: Unexpected error+ printLn "Unexpected error" >>+ loop (nxt txt upd (Just [])) eval+ where++ -- TODO: Refactoring needed+ txt2act txt =+ -- TODO: Refactoring needed+ case txt of++ '/':'m':'o':'d':'e':' ':c:cs -> Mode c cs+ '/':'m' :' ':c:cs -> Mode c cs++ '/':'l':'i':'s':'t' :mfil ->+ -- TODO: DRY+ Message (MSG.List fil)+ where+ fil =+ case mfil of+ [ ] -> Just $ INT.Filter mfil+ ' ':cs -> Just $ INT.Filter cs+ ______ -> Nothing+ '/':'l' :mfil ->+ -- TODO: DRY+ Message (MSG.List fil)+ where+ fil =+ case mfil of+ [ ] -> Just $ INT.Filter mfil+ ' ':cs -> Just $ INT.Filter cs+ ______ -> Nothing++ '/':'f':'i':'l':'e':' ':midx ->+ -- TODO: DRY+ case oidx of+ Nothing ->+ Message (MSG.Path False Nothing)+ Just idx ->+ if 0 <= idx && idx < length pfs then+ Message (MSG.Path False (Just $ INT.AbsoluteFilePath $ pfs !! idx))+ else+ Message (MSG.Path False Nothing)+ where+ pfs = concatMap INT.filePaths $ pile ctx+ where+ oidx =+ case midx of+ [] -> Nothing+ cs -> readMaybe cs :: Maybe Int+ '/':'f' :' ':midx ->+ -- TODO: DRY+ case oidx of+ Nothing ->+ Message (MSG.Path False Nothing)+ Just idx ->+ if 0 <= idx && idx < length pfs then+ Message (MSG.Path False (Just $ INT.AbsoluteFilePath $ pfs !! idx))+ else+ Message (MSG.Path False Nothing)+ where+ pfs = concatMap INT.filePaths $ pile ctx+ where+ oidx =+ case midx of+ [] -> Nothing+ cs -> readMaybe cs :: Maybe Int+ '/':'n':'u':'m':'s':' ':midx ->+ -- TODO: DRY+ case oidx of+ Nothing ->+ Message (MSG.Path True Nothing)+ Just idx ->+ if 0 <= idx && idx < length pfs then+ Message (MSG.Path True (Just $ INT.AbsoluteFilePath $ pfs !! idx))+ else+ Message (MSG.Path True Nothing)+ where+ pfs = concatMap INT.filePaths $ pile ctx+ where+ oidx =+ case midx of+ [] -> Nothing+ cs -> readMaybe cs :: Maybe Int+ '/':'n' :' ':midx ->+ -- TODO: DRY+ case oidx of+ Nothing ->+ Message (MSG.Path True Nothing)+ Just idx ->+ if 0 <= idx && idx < length pfs then+ Message (MSG.Path True (Just $ INT.AbsoluteFilePath $ pfs !! idx))+ else+ Message (MSG.Path True Nothing)+ where+ pfs = concatMap INT.filePaths $ pile ctx+ where+ oidx =+ case midx of+ [] -> Nothing+ cs -> readMaybe cs :: Maybe Int++ '/':'s':'e':'n':'d':' ':mesg -> Prompt mesg+ '/':'s' :' ':mesg -> Prompt mesg++ '/':'a':'t':'o':'m':' ':mesg ->+ -- TODO: DRY+ Branch mesg fs+ where+ fs = fromMaybe (INT.Files []) (ruck ctx)+ '/':'a' :' ':mesg ->+ -- TODO: DRY+ Branch mesg fs+ where+ fs = fromMaybe (INT.Files []) (ruck ctx)++ '/':'r':'e':'p':'o' :[ ] -> Message MSG.Repo++ '/':'r':'u':'c':'k' :midx -> Ruck midx+ '/':'r' :midx -> Ruck midx++ "/exit" -> Exit+ "/e" -> Exit+ "/help" -> Help+ "/?" -> Help+ "/drop" -> Drop+ "/d" -> Drop+ "/hist" -> Hist ( True, True )+ "/h" -> Hist ( True, True )+ "/chit" -> Hist ( True, False )+ "/chat" -> Hist ( False, True )+ "/pile" -> Pile+ "/p" -> Pile+ "/wipe" -> Wipe+ "/w" -> Wipe++ '/':cmd -> UnknownCmd cmd+ ____________________________ -> Message (MSG.Text txt)++ -- TODO: Refactoring needed+ his = hist ctx+ chi = chit his+ hps = prev chi+ hns = next chi+ nxt p c o =+ c+ { hist =+ (hist c)+ { chit =+ (chit $ hist c)+ { prev = p : hps+ }+ , chat =+ case o of+ Nothing -> chat $ hist c+ Just r -> (r:) $ chat $ hist c+ }+ }++ caseExit =+ printLn "Λ-gent will shutdown" >>+ return ()++ caseDrop txt =+ printLn ("Dropping end-user data load") >>+ loop+ ( (nxt txt ctx Nothing)+ { load = Nothing+ }+ ) eval++ -- TODO: Refactoring needed+ caseMode txt c cs =+ case mmod of+ Just mod ->+ printLn ("Changed to " ++ low ++ "-mode") >>+ loop+ ( (nxt txt ctx Nothing)+ { mode = mod+ , pile = Just $ INT.FilePaths []+ , ruck = Just $ INT.Files []+ }+ ) eval+ where+ low = map toLower $ show mod+ Nothing ->+ printLn ("Invalid mode: " ++ c:cs) >>+ loop ctx eval+ where+ mmod = readMaybe (toUpper c : map toLower cs) :: Maybe INT.Mode++ caseHist txt chits chats =+ ( if chits then+ printLn "* Chits:" >>+ ( mapM_ printLn . UTL.combine . UTL.chits True . prev . chit . hist+ ) ctx+ else+ pure ()+ ) >>+ ( if chats then+ printLn "* Chats:" >>+ ( mapM_ printLn . UTL.combine . UTL.chats True . chat . hist+ ) ctx+ else+ pure ()+ ) >>+ loop (nxt txt ctx Nothing) eval++ caseFile txt ns ls =+ ( mapM_ printLn .+ UTL.combine .+ UTL.file ns+ ) (unlines ls) >>+ loop (nxt txt ctx Nothing) eval+ caseHelp txt =+ printLn help >>+ loop (nxt txt ctx Nothing) eval++ casePaths txt fps =+ eval ctx MSG.Root >>= \ (upd, action) ->+ case action of+ Paths (INT.FilePaths rfps) ->+ ( case rfps of+ [cwd] ->+ mapM_ printLn .+ UTL.combine .+ UTL.files [] True .+ -- NOTE: Show relative paths+ map (drop (length cwd)) $+ fps+ _____ ->+ printLn "Missing root path"+ ) >>+ loop+ ( (nxt txt upd Nothing)+ { pile = Just $ INT.FilePaths fps+ }+ ) eval+ Message (MSG.Text cs) ->+ printLn cs >>+ loop (nxt txt upd (Just cs)) eval+ None ->+ loop (nxt txt upd Nothing) eval+ _________________________ ->+ -- NOTE: Unexpected error+ printLn "Unexpected error" >>+ loop (nxt txt upd (Just [])) eval++ casePile txt =+ eval ctx MSG.Root >>= \ (upd, action) ->+ case action of+ Paths (INT.FilePaths fps) ->+ ( case fps of+ [cwd] ->+ mapM_ printLn .+ UTL.combine .+ UTL.files [] True .+ -- NOTE: Show relative paths+ map (drop (length cwd)) .+ concatMap INT.filePaths .+ pile $+ upd+ _____ ->+ printLn "Missing root path"+ ) >>+ loop (nxt txt upd Nothing) eval+ Message (MSG.Text cs) ->+ printLn cs >>+ loop (nxt txt upd (Just cs)) eval+ None ->+ loop (nxt txt upd Nothing) eval+ _________________________ ->+ -- NOTE: Unexpected error+ printLn "Unexpected error" >>+ loop (nxt txt upd (Just [])) eval++ caseRuck txt midx =+ ( if null midx then+ -- NOTE: If no optional index provided, show only paths+ ( mapM_ printLn .+ UTL.combine .+ UTL.files [] True .+ concatMap fps .+ ruck+ ) ctx+ else+ -- NOTE: Otherwise, show content or index error+ ( case idx of+ Just i ->+ if 0 <= i && i < len then+ ( mapM_ printLn .+ UTL.combine .+ UTL.file True .+ concatMap f .+ ruck+ ) ctx+ else+ let+ m = "Index (" ++ show i ++ ") is out of bounds."+ in+ printLn m+ where+ f (INT.Files fs) =+ case fs !! i of+ INT.File (_,ls) -> unlines ls+ Nothing ->+ printLn "Invalid use of /ruck. Use space between cmd and index"+ )+ ) >>+ loop (nxt txt ctx Nothing) eval+ where+ idx =+ case midx of+ [ ] -> Nothing+ ' ':cs -> readMaybe cs :: Maybe Int+ ______ -> Nothing+ len =+ case ruck ctx of+ Just (INT.Files fs) -> length fs+ Nothing -> 0+ fps (INT.Files fs) =+ map ( \ (INT.File (p,_)) -> p) fs++ caseWipe txt =+ printLn clear >>+ loop (nxt txt ctx Nothing) eval++ caseUnknownCmd txt cmd =+ printLn msg >>+ loop (nxt txt ctx Nothing) eval+ where+ msg = "Command not recognized: " ++ cmd++ -- NOTE: Clear screen & Move top-left+ clear = "\^[[H\^[[2J" -- NOTE: See `infocmp -x`+ prompt =+ (show . AEC.bold . AEC.sgr)+ ("Λ-" ++ (map toLower . show . mode) ctx ++ "> ")+ read = input+ print = output . show . AEC.faint . AEC.sgr+ printLn x = print $ x ++ "\n"++integrity :: IO (Either String ())+integrity =+ do+ ohi <- ENV.getEnv "LLM_SIGN_SHA"+ case ohi of+ Nothing -> pure $ Right ()+ Just hi ->+ do+ op <- cwd+ pn <- getProgName+ case op of+ Left e -> pure $ Left e+ Right p ->+ do+ ehf <- sha ap+ case ehf of+ Left ef -> pure $ Left ef+ Right hf ->+ if hi == h64 then+ pure $ Right ()+ else+ pure $+ Left $+ "# Λ-gent integrity failed:\n" +++ "> " ++ hi ++ " (expected)\n" +++ "> " ++ h64 ++ " (observed)"+ where+ h64 = take 64 hf+ where+ ap =+ concatMap id+ $ lines p ++ [ "/" ] ++ lines pn+ where+ -- TODO: Move "HELPERS (private)" private out from Internal/RIO.hs to+ -- Internal/IO.hs and then just wrap them with `RestrictedIO`. This will+ -- allow for logic like this to be simplified+ cwd =+ do+ -- NOTE: inconsistency between `linux` and `macOS`:+ --+ -- - If no option is specified, -P is assumed (linux)+ --+ -- - If no options are specified, the -L option is assumed (macOS)+ --+ -- -L, --logical use PWD from environment, even if it contains symlinks+ --+ -- -P, --physical resolve all symlinks+ (exitcode, out, err) <- readProcessWithExitCode "pwd" [ "-P" ] []+ case exitcode of+ ExitSuccess ->+ pure $ Right out+ ExitFailure _ ->+ pure $ Left err+ sha p =+ do+ (exitcode, out, err) <- readProcessWithExitCode "sha256sum" [ p ] []+ case exitcode of+ ExitSuccess ->+ pure $ Right out+ ExitFailure _ ->+ pure $ Left err
+ src/Agent/LLM/Action.hs view
@@ -0,0 +1,74 @@+{-# OPTIONS_GHC -Wall -Werror #-}++{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}+{-# LANGUAGE Safe #-}++--------------------------------------------------------------------------------++-- |+-- 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.LLM.Action+ ( Action+ , TextToFile+ -- * LLM (Internal)+ , File, FilePaths, Root+ -- * Methods+ , none+ , exit+ , file+ , paths+ , root+ , template+ , text+ )+where++--------------------------------------------------------------------------------++import Internal.LLM ( File, FilePaths, Root )+import qualified Internal.LLM as INT+import Internal.LLM.Action ( Action, TextToFile )+import qualified Internal.LLM.Action as ACT++import qualified Agent.LLM.Message as MSG++--------------------------------------------------------------------------------++none :: Action+none =+ ACT.None++exit :: Action+exit =+ ACT.Exit++file :: File -> Action+file =+ ACT.File++paths :: FilePaths -> Action+paths =+ ACT.Paths++root :: Root -> Action+root (INT.Root afp) =+ ACT.Paths $ INT.FilePaths [afp]++template+ :: TextToFile+ -> [File]+ -> [File]+ -> [File]+ -> Action+template =+ ACT.Template++text :: String -> Action+text =+ ACT.Message . MSG.Text
+ src/Agent/LLM/Message.hs view
@@ -0,0 +1,48 @@+{-# OPTIONS_GHC -Wall -Werror #-}++{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}+{-# LANGUAGE Safe #-}++--------------------------------------------------------------------------------++-- |+-- 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.LLM.Message+ ( Message(..)+ , AbsoluteFilePath+ , Files+ , Filter+ )+where++--------------------------------------------------------------------------------++import Internal.LLM ( AbsoluteFilePath, Files, Filter )++--------------------------------------------------------------------------------++data Message+ = Atom !String !Files+ | List !(Maybe Filter)+ | Path !Bool !(Maybe AbsoluteFilePath)+ | Repo+ | Root+ | Send ![String]+ | Text !String+ | Tmpl !(Maybe [AbsoluteFilePath])++instance Show Message where+ show (Atom _ _) = "Atom"+ show (List _) = "List"+ show (Path _ _) = "Path"+ show Repo = "Repo"+ show Root = "Root"+ show (Send _) = "Send"+ show (Text _) = "Text"+ show (Tmpl _) = "Tmpl"
+ 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}
+ src/Internal/LLM.hs view
@@ -0,0 +1,191 @@+{-# OPTIONS_GHC -Wall -Werror #-}++{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}+{-# LANGUAGE Safe #-}++--------------------------------------------------------------------------------++-- |+-- 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 Internal.LLM+ ( UUID (..)+ , Root (..)+ , Filter (..)+ , Mode (..)+ , Chit (..)+ , Chat+ , History (..)+ , Mask (..)+ , File (..)+ , Files (..)+ , FileLine+ , FilePaths (..)+ , AbsoluteFilePath (..)+ , Template (..)+ , modes+ , tpl2xmls+ )+where++--------------------------------------------------------------------------------+--------------------------------------------------------------------------------++newtype UUID = UUID String++newtype Root = Root FilePath deriving Eq++newtype Filter = Filter String++data Mode+ = Auto+ | Chat+ | Code+ | Docs+ | Echo+ | Plan+ | Test+ deriving (Bounded, Enum, Eq, Read, Show)++data Chit =+ Chit+ { prev :: ![String]+ , next :: ![String]+ }++type Chat = [String]++data History =+ History+ { chit :: !Chit+ , chat :: !Chat+ }++--------------------------------------------------------------------------------+--------------------------------------------------------------------------------++newtype Mask = Mask [String]++--------------------------------------------------------------------------------+--------------------------------------------------------------------------------++type Markdown = String++type FileLine = String++newtype File = File (FilePath, [FileLine])++--------------------------------------------------------------------------------++newtype Files = Files [File]++instance Semigroup Files where+ Files xs <> Files ys =+ Files (xs ++ ys)++instance Monoid Files where+ mempty = Files []++--------------------------------------------------------------------------------++newtype AbsoluteFilePath = AbsoluteFilePath FilePath++--------------------------------------------------------------------------------++-- NOTE: Then use `mconcat` to combine++data FilePaths = FilePaths { filePaths :: [FilePath] }++instance Semigroup FilePaths where+ FilePaths xs <> FilePaths ys =+ FilePaths (xs ++ ys)++instance Monoid FilePaths where+ mempty = FilePaths []++--------------------------------------------------------------------------------++data Template =+ Template+ { purpose :: !String+ , instructions :: ![String]+ , examples :: ![Markdown]+ , files :: ![File]+ }++--------------------------------------------------------------------------------+--------------------------------------------------------------------------------++modes :: [Mode]+modes =+ [ minBound .. maxBound ]++tpl2xmls+ :: Template+ -> [String]+tpl2xmls tpl =+ [ ( if eis && ees && efs then+ pur+ else+ "<purpose>" ++ pur ++ "</purpose>"+ ) +++ ( if eis then+ []+ else+ "<instructions>" +++ tis +++ "</instructions>"+ ) +++ ( if ees then+ []+ else+ "<examples>" +++ tes +++ "</examples>"+ ) +++ ( if efs then+ []+ else+ "<files>" +++ concatMap aux tfs +++ "</files>"+ )+ ]+ where+ pur =+ purpose tpl +++ ( if eis then+ []+ else+ ". Follow the specified `instructions`"+ ) +++ ( if ees then+ []+ else+ ". Output MUST match scaffolding from provided `examples`"+ ) +++ ( if efs then+ []+ else+ ". Apply to each of the `files`"+ )+ eis = null tis+ ees = null tes+ efs = null tfs+ tis =+ concatMap (\ x -> "<instruction>" ++ x ++ "</instruction>")+ $ instructions tpl+ tes =+ concatMap (\ x -> "<example>" ++ x ++ "</example>")+ $ examples tpl+ tfs = zip [0 :: Int ..] $ files tpl+ aux (i, File (src, ls)) =+ "<file index=\"" ++ show i ++ "\">" +++ "<source>" ++ src ++ "</source>" +++ "<content>" ++ unlines ls ++ "</content>" +++ "</file>"
+ src/Internal/LLM/Action.hs view
@@ -0,0 +1,48 @@+{-# OPTIONS_GHC -Wall -Werror #-}++{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}+{-# LANGUAGE Safe #-}++--------------------------------------------------------------------------------++-- |+-- 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 Internal.LLM.Action+ ( Action (..)+ , TextToFile+ )+where++--------------------------------------------------------------------------------++import qualified Internal.LLM as INT++import qualified Agent.LLM.Message as MSG++--------------------------------------------------------------------------------++type TextToFile = String -> [(FilePath, [INT.FileLine])]++data Action+ = None+ | Branch !String !INT.Files+ | Exit+ | Drop+ | File !INT.File+ | Help+ | Hist !(Bool, Bool)+ | Message !MSG.Message+ | Mode !Char !String+ | Paths !INT.FilePaths+ | Pile+ | Prompt !String+ | Ruck !String+ | Template !TextToFile ![INT.File] ![INT.File] ![INT.File]+ | UnknownCmd !String+ | Wipe
+ src/Internal/RIO.hs view
@@ -0,0 +1,1627 @@+{-# OPTIONS_GHC -Wall -Werror #-}++{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}+{-# LANGUAGE Safe #-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}++{-# LANGUAGE LambdaCase #-}++--------------------------------------------------------------------------------++-- |+-- 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 Internal.RIO+ ( RIO ()+ , run+ -- * Environment+ , getEnvVar+ -- * Read/Print+ , input+ , output+ -- * LLM (Config)+ , llmPathCWD+ -- * LLM (Chat)+ , llmChatKey, llmChatAPI+ , llmChatWeb+ -- * LLM (Code)+ , llmCodeDir+ , llmCodeMsk+ , llmCodeIns, llmCodeExa+ , llmCodeSeq, llmCodeGet, llmCodeGit+ , llmCodePut+ , llmCodeKey, llmCodeAPI+ , llmCodeWeb+ -- * LLM (Plan)+ , llmPlanDir+ , llmPlanMsk+ , llmPlanSeq, llmPlanGet+ , llmPlanKey, llmPlanAPI+ , llmPlanWeb+ )+where++--------------------------------------------------------------------------------++import Control.Exception ( SomeException, try )+import Data.Char ( isDigit )+import Data.Either ( fromLeft, partitionEithers )+import Data.List ( isPrefixOf )+import Data.Maybe ( maybeToList )+import qualified System.Environment.Blank as ENV+import System.Exit+ ( ExitCode (ExitFailure, ExitSuccess)+ )+import System.IO+ ( hClose+ , hFlush+ , hGetContents+ , hPutStrLn+ , hReady+ , stdin+ , stdout+ )+import System.Process+ ( CreateProcess (cwd, std_err, std_in, std_out)+ , StdStream (CreatePipe)+ , createProcess+ , proc+ , readCreateProcessWithExitCode+ , readProcessWithExitCode+ , waitForProcess+ )+import Text.Read ( readMaybe )++import qualified Internal.LLM as LLM+import qualified Internal.Utils as UTL++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++--------------------------------------------------------------------------------+--------------------------------------------------------------------------------++data Position =+ Position !Int !Int+ deriving (Eq, Show)++instance Ord Position where+ (<=) (Position y1 x1) (Position y2 x2) =+ case compare y1 y2 of+ GT -> False+ EQ -> x1 <= x2+ LT -> True++instance Read Position where+ readsPrec _ str =+ -- NOTE:+ -- "\^[[#;#R" => "\^[" and "[#;#R" (only parse last)+ maybeToList+ ( readMaybe (f str) >>= \ y ->+ readMaybe (g str) >>= \ x ->+ Just+ ( Position y x+ , h str+ )+ )+ where+ f = takeWhile (/= ';') . drop 1 . dropWhile (/= '[')+ g = takeWhile (/= 'R') . drop 1 . dropWhile (/= ';')+ h = drop 1 . dropWhile (/= 'R') . dropWhile (/= ';') . dropWhile (/= '[')++--------------------------------------------------------------------------------++data MultiLine =+ MultiLine+ { stx :: !(Maybe Position)+ , cur :: !(Maybe Position)+ , etx :: !(Maybe Position)+ , col :: !Int+ }+ deriving Show++--------------------------------------------------------------------------------+--------------------------------------------------------------------------------++class StdIn m where+ input+ :: [ String ]+ -> [ String ]+ -> m String++class StdOut m where+ output+ :: String+ -> m ()++--------------------------------------------------------------------------------++instance StdIn RIO where+ input prev next =+ -- NOTE: "\^[7" - save cursor position (SCO)+ -- - https://gist.github.com/fnky/458719343aabd01cfb17a3a4f7296797#cursor-controls+ RestrictedIO $ putStr "\^[7" >> aux gen prev next [] []+ where+ msv = 32767 :: Int+ gen =+ MultiLine+ { stx = Nothing+ , cur = Nothing+ , etx = Nothing+ , col = 0+ }+ aux mlp hps hns bcs acs =+ block >>= \ blk ->+ case (blk < ['\32'], blk) of+ -- NOTE: To view keystrokes, use: `ghc -e getLine` (hit + ENTER) and+ -- then map to ASCII control codes (use Caret notation cos Λ prefix):+ --+ -- - https://en.wikipedia.org/wiki/ASCII#Control_code_table+ (True , ['\^J']) -> caseEnter+ (True , ['\^H']) -> caseBackspace+ (True , ['\^[','[','3','~']) -> caseDelete+ (True , ['\^D']) -> caseDelete+ (True , ['\^[','[','H']) -> caseHome+ (True , ['\^A']) -> caseHome+ (True , ['\^[','[','F']) -> caseEnd+ (True , ['\^E']) -> caseEnd+ (True , ['\^L']) -> caseWipe+ (True , ['\^U']) -> caseWipeStart+ (True , ['\^K']) -> caseWipeEnd+ (True , ['\^[','[','A']) -> caseArrowUp+ (True , ['\^[','[','B']) -> caseArrowDown+ (True , ['\^[','[','C']) -> caseArrowRight blk+ (True , ['\^[','[','D']) -> caseArrowLeft blk+ (True , ['\^[','[','1',';','5','C']) -> caseArrowCtrlRight+ (True , ['\^[','[','1',';','5','D']) -> caseArrowCtrlLeft+ (True , '\^[':ps) -> casePositions ps+ (True , _) -> caseSkip+ (False, ['\DEL']) -> caseSkip+ (False, _) -> caseText blk+ where+ caseEnter =+ -- NOTE: ENTER (line feed) only if something is typed+ case (bcs, acs) of+ ([], []) ->+ aux mlp hps hns bcs acs+ ________ ->+ hFlush stdout >>+ -- NOTE: Move to end of text+ putStr hom >>+ hFlush stdout >>+ (pure . (++ acs) . reverse) bcs+ where+ hom =+ case mlp of+ MultiLine { etx = Just (Position y x) } ->+ "\^[[" ++ show y ++ ";" ++ show x ++ "H"+ _______________________________________ ->+ []+ caseBackspace =+ -- NOTE: BACKSPACE / CTRL + H (remove char if any and re-write+ -- after chars)+ case bcs of+ [ ] -> aux mlp hps hns bcs acs+ (_:cs) ->+ hFlush stdout >>+ -- NOTE: 0) Print "\^[[6n" position before action+ putStr "\^[[6n" >>+ -- NOTE: Remove char+ putChar '\^H' >>+ -- NOTE: Save position+ putStr "\^[7" >>+ -- NOTE: Clear rest of screen from position+ putStr "\^[[0J" >>+ -- NOTE: Print after chars+ putStr acs >>+ -- NOTE: 1) Print "\^[[6n" end position after action+ putStr "\^[[6n" >>+ -- NOTE: 2) Print "\^[[6n" column witdh+ putStr ("\^[[" ++ show msv ++ "C") >>+ putStr "\^[[6n" >>+ -- NOTE: Go back to saved position+ putStr "\^[8" >>+ -- NOTE: 3) Print "\^[[6n" current position after action+ putStr "\^[[6n" >>+ hFlush stdout >>+ aux mlp hps hns cs acs+ caseDelete =+ -- NOTE: DELETE / CTRL + D behave as delete key+ case acs of+ -- NOTE: Delete (remove char if any and re-write after chars)+ [ ] -> aux mlp hps hns bcs acs+ (_:cs) ->+ hFlush stdout >>+ -- NOTE: 0) Print "\^[[6n" position before action+ putStr "\^[[6n" >>+ -- NOTE: Save position+ putStr "\^[7" >>+ -- NOTE: Clear rest of screen from position+ putStr "\^[[0J" >>+ -- NOTE: Print after chars+ putStr cs >>+ -- NOTE: 1) Print "\^[[6n" end position after action+ putStr "\^[[6n" >>+ -- NOTE: 2) Print "\^[[6n" column witdh+ putStr ("\^[[" ++ show msv ++ "C") >>+ putStr "\^[[6n" >>+ -- NOTE: Go back to saved position+ putStr "\^[8" >>+ -- NOTE: 3) Print "\^[[6n" current position after action+ putStr "\^[[6n" >>+ hFlush stdout >>+ aux mlp hps hns bcs cs+ caseHome =+ -- NOTE: HOME / CTRL + A to move to start of text+ hFlush stdout >>+ putStr hom >>+ hFlush stdout >>+ aux mln hps hns [] (reverse bcs ++ acs)+ where+ (mln, hom) =+ case mlp of+ MultiLine { stx = Just (Position y x) } ->+ ( mlp { cur = Just (Position y x) }+ , "\^[[" ++ show y ++ ";" ++ show x ++ "H"+ )+ _______________________________________ ->+ ( mlp+ , "\^[8"+ )+ caseEnd =+ -- NOTE: END / CTRL + E to move to end of text+ hFlush stdout >>+ putStr hom >>+ hFlush stdout >>+ aux mln hps hns ((++ bcs) $ reverse acs) []+ where+ (mln, hom) =+ case mlp of+ MultiLine { etx = Just (Position y x) } ->+ ( mlp { cur = Just (Position y x) }+ , "\^[[" ++ show y ++ ";" ++ show x ++ "H"+ )+ _______________________________________ ->+ ( mlp+ , []+ )+ caseWipe =+ -- NOTE: CTRL + L (form feed) becomes "/w" (clear screen)+ pure "/wipe"+ caseWipeStart =+ -- NOTE: CTRL + U cut text to start+ hFlush stdout >>+ -- NOTE: 0) Print "\^[[6n" position before action+ putStr "\^[[6n" >>+ -- NOTE: Go back to start of line+ putStr hom >>+ -- NOTE: Save position+ putStr "\^[7" >>+ -- NOTE: Clear rest of screen from position+ putStr "\^[[0J" >>+ -- NOTE: Print after chars+ putStr acs >>+ -- NOTE: 1) Print "\^[[6n" end position after action+ putStr "\^[[6n" >>+ -- NOTE: 2) Print "\^[[6n" column witdh+ putStr ("\^[[" ++ show msv ++ "C") >>+ putStr "\^[[6n" >>+ -- NOTE: Go back to saved position+ putStr "\^[8" >>+ -- NOTE: 3) Print "\^[[6n" current position after action+ putStr "\^[[6n" >>+ hFlush stdout >>+ aux mlp hps hns [] acs+ where+ hom =+ case mlp of+ MultiLine { stx = Just (Position y x) } ->+ "\^[[" ++ show y ++ ";" ++ show x ++ "H"+ _______________________________________ ->+ "\^[8"+ caseWipeEnd =+ -- NOTE: CTRL + K cut text to end+ hFlush stdout >>+ -- NOTE: 0) Print "\^[[6n" position before action+ putStr "\^[[6n" >>+ -- NOTE: Save position+ putStr "\^[7" >>+ -- NOTE: Clear rest of screen from position+ putStr "\^[[0J" >>+ -- NOTE: 1) Print "\^[[6n" end position after action+ putStr "\^[[6n" >>+ -- NOTE: 2) Print "\^[[6n" column witdh+ putStr ("\^[[" ++ show msv ++ "C") >>+ putStr "\^[[6n" >>+ -- NOTE: Go back to saved position+ putStr "\^[8" >>+ -- NOTE: 3) Print "\^[[6n" current position after action+ putStr "\^[[6n" >>+ hFlush stdout >>+ aux mlp hps hns bcs []+ caseArrowUp =+ -- NOTE: Allowed escaped sequences: Arrow "↑"+ case (hps, hns) of+ ([ ], _) -> aux mlp hps hns bcs acs+ (p:ps, _) ->+ hFlush stdout >>+ -- NOTE: 0) Print "\^[[6n" position before action+ putStr "\^[[6n" >>+ -- NOTE: Move to start of text+ putStr hom >>+ -- NOTE: Print previous line+ putStr p >>+ -- NOTE: Save position+ putStr "\^[7" >>+ -- NOTE: Clear rest of screen from position+ putStr "\^[[0J" >>+ -- NOTE: Print after chars+ putStr [] >>+ -- NOTE: 1) Print "\^[[6n" end position after action+ putStr "\^[[6n" >>+ -- NOTE: 2) Print "\^[[6n" column witdh+ putStr ("\^[[" ++ show msv ++ "C") >>+ putStr "\^[[6n" >>+ -- NOTE: Go back to saved position+ putStr "\^[8" >>+ -- NOTE: 3) Print "\^[[6n" current position after action+ putStr "\^[[6n" >>+ hFlush stdout >>+ aux mlp ps (p:hns) rev []+ where+ rev = reverse p+ hom =+ case mlp of+ MultiLine { stx = Just (Position y x) } ->+ "\^[[" ++ show y ++ ";" ++ show x ++ "H"+ _______________________________________ ->+ "\^[8"+ caseArrowDown =+ -- NOTE: Allowed escaped sequences: Arrow "↓"+ case (hps, hns) of+ (_, [ ]) -> aux mlp hps hns bcs acs+ (_, p:ps) ->+ hFlush stdout >>+ -- NOTE: 0) Print "\^[[6n" position before action+ putStr "\^[[6n" >>+ -- NOTE: Move to start of text+ putStr hom >>+ -- NOTE: Print previous line+ putStr p >>+ -- NOTE: Save position+ putStr "\^[7" >>+ -- NOTE: Clear rest of screen from position+ putStr "\^[[0J" >>+ -- NOTE: Print after chars+ putStr [] >>+ -- NOTE: 1) Print "\^[[6n" end position after action+ putStr "\^[[6n" >>+ -- NOTE: 2) Print "\^[[6n" column witdh+ putStr ("\^[[" ++ show msv ++ "C") >>+ putStr "\^[[6n" >>+ -- NOTE: Go back to saved position+ putStr "\^[8" >>+ -- NOTE: 3) Print "\^[[6n" current position after action+ putStr "\^[[6n" >>+ hFlush stdout >>+ aux mlp (p:hps) ps rev []+ where+ rev = reverse p+ hom =+ case mlp of+ MultiLine { stx = Just (Position y x) } ->+ "\^[[" ++ show y ++ ";" ++ show x ++ "H"+ _______________________________________ ->+ "\^[8"+ caseArrowRight str =+ -- NOTE: Allowed escaped sequences: Arrow "→"+ case (bcs, acs) of+ (_, [ ]) ->+ aux mlp hps hns bcs acs+ (_, c:cs) ->+ hFlush stdout >>+ ( if pl then+ putStr ("\^[[" ++ "1" ++ "E")+ else+ putStr str+ ) >>+ -- NOTE: Update current position+ putStr "\^[[6n" >>+ hFlush stdout >>+ aux mlp hps hns (c:bcs) cs+ where+ pl =+ case mlp of+ MultiLine+ { cur = Just (Position cy cx)+ , etx = Just (Position ey __)+ , col = cw+ } -> cy <= ey && cx == cw+ ___ -> False+ caseArrowLeft str =+ -- NOTE: Allowed escaped sequences: Arrow "←"+ case (bcs, acs) of+ ([ ], _) ->+ aux mlp hps hns bcs acs+ (c:cs, _) ->+ hFlush stdout >>+ ( if pl then+ putStr ("\^[[" ++ "1" ++ "F") >>+ putStr ("\^[[" ++ show msv ++ "C")+ else+ putStr str+ ) >>+ -- NOTE: Update current position+ putStr "\^[[6n" >>+ hFlush stdout >>+ aux mlp hps hns cs (c:acs)+ where+ pl =+ case mlp of+ MultiLine+ { stx = Just (Position sy __)+ , cur = Just (Position cy 01)+ } -> sy < cy+ ___ -> False+ caseArrowCtrlRight =+ -- NOTE: Allowed escaped sequences: CTRL + Arrow "→"+ -- NOTE: Move to end of text+ hFlush stdout >>+ putStr np >>+ -- NOTE: Update current position+ putStr "\^[[6n" >>+ hFlush stdout >>+ aux mlp hps hns (ts ++ bcs) ds+ where+ ds = dropWhile (== ' ') $ dropWhile (/= ' ') acs+ ts = drop (length ds) $ reverse acs+ lc = length ts+ np =+ case mlp of+ MultiLine+ { cur = Just (Position cy cx)+ , etx = Just (Position ey _ )+ , col = cw+ } ->+ case (cy < ey, compare (cw - cx) lc) of+ (True, LT) ->+ "\^[[" ++ show y ++ ";" ++ show x ++ "H"+ where+ y = cy + 1+ x = lc - (cw - cx)+ __________ ->+ "\^[[" ++ show y ++ ";" ++ show x ++ "H"+ where+ y = cy+ x = cx + lc+ ___ -> []+ caseArrowCtrlLeft =+ -- NOTE: Allowed escaped sequences: CTRL + Arrow "←"+ hFlush stdout >>+ putStr np >>+ -- NOTE: Update current position+ putStr "\^[[6n" >>+ hFlush stdout >>+ aux mlp hps hns ds (ts ++ acs)+ where+ ds = dropWhile (== ' ') $ dropWhile (/= ' ') bcs+ ts = drop (length ds) $ reverse bcs+ lc = length ts+ np =+ case mlp of+ MultiLine+ { stx = Just (Position sy _ )+ , cur = Just (Position cy cx)+ , col = cw+ } ->+ case (sy < cy, compare cx lc) of+ (True, LT) ->+ "\^[[" ++ show y ++ ";" ++ show x ++ "H"+ where+ y = cy - 1+ x = cw - (lc - cx)+ __________ ->+ "\^[[" ++ show y ++ ";" ++ show x ++ "H"+ where+ y = cy+ x = cx - lc+ ___ -> []+ casePositions ps =+ -- NOTE: Other escaped sequences (skip unless positions)+ aux mln hps hns bcs acs+ where+ ops = map readMaybe $ UTL.split '\^[' ps :: [Maybe Position]+ mln =+ -- NOTE: 0) Print "\^[[6n" position before action (unused)+ -- NOTE: 1) Print "\^[[6n" end position after action+ -- NOTE: 2) Print "\^[[6n" column witdh+ -- NOTE: 3) Print "\^[[6n" current position after action+ case (mlp, ops) of+ (___________________________,+ [ ]) ->+ mlp+ (MultiLine { stx = Nothing },+ [Just (Position y x) ]) ->+ mlp+ { stx = Just sp+ , cur = Just sp+ , etx = Just sp+ , col = x+ }+ where+ sp = Position y x+ (MultiLine { etx = Just ep },+ [Just cp ]) ->+ if cp > ep then+ mlp+ { cur = Just cp+ , etx = Just cp+ }+ else+ mlp+ { cur = Just cp+ }+ (MultiLine { stx = Nothing },+ [Just sp,Just ep,Just (Position _ w),Just cp]) ->+ mlp+ { stx = Just sp+ , cur = Just cp+ , etx = Just ep+ , col = w+ }+ (___________________________,+ [Just __,Just ep,Just (Position _ w),Just cp]) ->+ mlp+ { cur = Just cp+ , etx = Just ep+ , col = w+ }+ _______________________________________________ ->+ mlp+ caseSkip =+ aux mlp hps hns bcs acs+ caseText str =+ hFlush stdout >>+ -- NOTE: 0) Print "\^[[6n" position before action+ putStr "\^[[6n" >>+ -- NOTE: Type key or text+ putStr str >>+ -- NOTE: Save position+ putStr "\^[7" >>+ -- NOTE: Clear rest of screen from position+ putStr "\^[[0J" >>+ -- NOTE: Print after chars+ putStr acs >>+ -- NOTE: 1) Print "\^[[6n" end position after action+ putStr "\^[[6n" >>+ -- NOTE: 2) Print "\^[[6n" column witdh+ putStr ("\^[[" ++ show msv ++ "C") >>+ putStr "\^[[6n" >>+ -- NOTE: Go back to saved position+ putStr "\^[8" >>+ -- NOTE: 3) Print "\^[[6n" current position after action+ putStr "\^[[6n" >>+ hFlush stdout >>+ aux mlp hps hns (reverse str ++ bcs) acs+ block =+ -- NOTE: https://stackoverflow.com/a/38553473+ --+ -- We refactored and named it `block` instead of `key` as it is possible+ -- to paste a huge block of text. Calling that a keystroke, doesn't seem+ -- appropiate+ reverse <$> nxt []+ where+ nxt cs =+ do+ c <- getChar+ m <- hReady stdin+ (if m then nxt else pure) (c:cs)++instance StdOut RIO where+ output x = RestrictedIO $+ putStr x >> hFlush stdout++--------------------------------------------------------------------------------+--------------------------------------------------------------------------------++class+ EFF.LlmConf m+ => LlmConf m+ where+ llmPathCWD+ :: m (Maybe LLM.Root)++instance+ EFF.LlmConf RIO+ => LlmConf RIO+ where+ llmPathCWD =+ ( \ case+ Just rp -> Just $ LLM.Root rp+ Nothing -> Nothing+ )+ <$> getEnvVar "LLM_PATH_CWD"++--------------------------------------------------------------------------------+--------------------------------------------------------------------------------++class+ EFF.LlmChatConf m+ => LlmChatConf m+ where+ llmChatAPI+ :: m (Maybe String)+ llmChatKey+ :: m (Maybe String)++instance+ EFF.LlmChatConf RIO+ => LlmChatConf RIO+ where+ llmChatAPI = getEnvVar "LLM_CHAT_LOCALHOST_API"+ llmChatKey = pure Nothing++--------------------------------------------------------------------------------++class+ EFF.LlmChatConf m+ => LlmChatPost m+ where+ llmChatWeb+ :: String -> m (Either String String)++instance+ EFF.LlmChatConf RIO+ => LlmChatPost RIO+ where+ llmChatWeb json =+ EFF.llmChatAPI >>= \ mapi ->+ EFF.llmChatKey >>= \ mkey ->+ llmCurl json mapi mkey++--------------------------------------------------------------------------------+--------------------------------------------------------------------------------++class+ EFF.LlmConf m+ => LlmCodeRoot m+ where+ llmCodeDir+ :: m String++instance+ ( EFF.LlmConf RIO+ , EFF.LlmCodeRoot RIO+ )+ => LlmCodeRoot RIO+ where+ llmCodeDir = pure "src"++--------------------------------------------------------------------------------++class+ EFF.LlmCodeMask m+ => LlmCodeMask m+ where+ llmCodeMsk+ :: m [String]++instance+ ( EFF.LlmConf RIO+ , EFF.LlmCodeMask RIO+ )+ => LlmCodeMask RIO+ where+ llmCodeMsk = pure [ "*.hs" ]++--------------------------------------------------------------------------------++class+ EFF.LlmCodeTmpl m+ => LlmCodeTmpl m+ where+ llmCodeIns+ :: m [LLM.File]+ llmCodeExa+ :: m [LLM.File]++instance+ ( EFF.LlmConf RIO+ , EFF.LlmCodeTmpl RIO+ )+ => LlmCodeTmpl RIO+ where+ llmCodeIns =+ EFF.llmPathCWD >>= \ ocwd ->+ case ocwd of+ Just (LLM.Root root) ->+ realPath (root ++ "llm") >>= \ efap ->+ case efap of+ -- TODO: DRY+ Right fap ->+ findFiles fap "*code_instructions_*.json" >>= \ eafps ->+ case eafps of+ Right afps ->+ mapM+ ( \ abspath ->+ LLM.File . (,) abspath . lines+ <$> readFileStrict abspath+ ) afps+ Left __ ->+ pure []+ Left ____ ->+ pure []+ Nothing ->+ pure []++ llmCodeExa =+ EFF.llmPathCWD >>= \ ocwd ->+ case ocwd of+ Just (LLM.Root root) ->+ realPath (root ++ "llm") >>= \ efap ->+ case efap of+ -- TODO: DRY+ Right fap ->+ findFiles fap "*code_examples_*.md" >>= \ eafps ->+ case eafps of+ Right afps ->+ mapM+ ( \ abspath ->+ LLM.File . (,) abspath . lines+ <$> readFileStrict abspath+ ) afps+ Left __ ->+ pure []+ Left ____ ->+ pure []+ Nothing ->+ pure []++--------------------------------------------------------------------------------++class+ ( EFF.LlmConf m+ , EFF.LlmCodeRoot m+ , EFF.LlmCodeMask m+ )+ => LlmCodeRead m+ where+ llmCodeSeq+ :: Maybe LLM.Filter+ -> m (Either [String] LLM.FilePaths)+ llmCodeGet+ :: LLM.AbsoluteFilePath+ -> m (Either String LLM.File)+ llmCodeGit+ :: m (Either String String)++instance+ ( EFF.LlmConf RIO+ , EFF.LlmCodeRoot RIO+ , EFF.LlmCodeMask RIO+ )+ => LlmCodeRead RIO+ where+ llmCodeSeq mfilter =+ EFF.llmPathCWD >>= \ ocwd ->+ case ocwd of+ Just (LLM.Root root) ->+ EFF.llmCodeDir >>= \ cdir ->+ EFF.llmCodeMsk >>= \ cmsk ->+ realPath (root ++ cdir) >>= \ efap ->+ case efap of+ -- TODO: DRY+ Right fap ->+ ( \ case+ ([], rs) -> Right $ LLM.FilePaths $ mconcat rs+ (ls, __) -> Left ls+ )+ . partitionEithers+ <$> mapM (\ msk -> findFiles fap ("*" ++ fil ++ "*" ++ msk)) cmsk+ Left err ->+ pure $ Left [err]+ Nothing ->+ pure $ Left [noLlmConf]+ where+ fil =+ case mfilter of+ Just (LLM.Filter f) -> f+ Nothing -> [ ]++ llmCodeGet (LLM.AbsoluteFilePath abspath) =+ EFF.llmPathCWD >>= \ ocwd ->+ EFF.llmCodeDir >>= \ cdir ->+ case ocwd of+ -- TODO: DRY+ Just (LLM.Root root) ->+ realPath (root ++ cdir) >>= \ efap ->+ case efap of+ Right fap ->+ if fap `isPrefixOf` abspath then+ -- NOTE: Root relative path+ Right . LLM.File . (,) (drop len abspath) . lines+ <$> readFileStrict abspath+ else+ pure $ Left $ notPrefixRootAndMode fap abspath LLM.Code+ Left err ->+ pure $ Left err+ where+ len = length root+ Nothing ->+ pure $ Left noLlmConf++ llmCodeGit =+ EFF.llmPathCWD >>= \ ocwd ->+ case ocwd of+ Just (LLM.Root root) ->+ realPath root >>= \ efap ->+ case efap of+ -- TODO: DRY+ Right fap ->+ gitExist fap >>= \ igit ->+ if igit then+ gitBranchesDesc fap+ else+ pure $ Left "No GIT repo initialized"+ Left err ->+ pure $ Left err+ Nothing ->+ pure $ Left noLlmConf++--------------------------------------------------------------------------------++class+ ( EFF.LlmConf m+ , EFF.LlmCodeRoot m+ )+ => LlmCodeSave m+ where+ llmCodePut+ :: String+ -> LLM.Files+ -> m (Either String String)++instance+ ( EFF.LlmConf RIO+ , EFF.LlmCodeRoot RIO+ )+ => LlmCodeSave RIO+ where+ -- TODO: Needs some refactoring at some point …+ llmCodePut ___ (LLM.Files []) =+ pure $ Left "No files provided, therefore no action performed"+ llmCodePut txt (LLM.Files fs) =+ EFF.llmPathCWD >>= \ ocwd ->+ EFF.llmCodeDir >>= \ cdir ->+ case ocwd of+ Just (LLM.Root root) ->+ realPath root >>= \ erap ->+ case erap of+ Right rp ->+ gitExist rp >>= \ igit ->+ gitignoreTmp rp >>= \ itmp ->+ case (igit, itmp) of+ (True, True) ->+ timestampUTC >>= \ mts ->+ case mts of+ Just ts ->+ realPath (root ++ "tmp") >>= \ etmp ->+ case etmp of+ Right tmp ->+ gitWorktreeAdd root ts tap >>= \ ewta ->+ (+ mapM+ ( \ (LLM.File (fp, fls)) ->+ let+ fil = tap ++ "/" ++ fp+ len = length $ tap ++ "/"+ in+ if dir `isPrefixOf` fil then+ ensureFolderPath tap fil >>= \ eefp ->+ writeFileStrict fil (unlines fls) >>= \ ewfs ->+ case (eefp, ewfs) of+ (Right efp, Right wfs) ->+ pure $ Right $ unlines+ [ "* Ensuring folder exists:"+ , efp+ , "* Writing file to folder:"+ , wfs+ ]+ (_, _) ->+ pure $ Left $ unlines+ [ "* Ensuring folder exists:"+ , fromLeft "No error" eefp+ , "* Writing file to folder:"+ , fromLeft "No error" ewfs+ ]+ else+ pure $ Left $+ ( (drop len fil) +++ " doesn't start with " +++ (drop len dir)+ )+ )+ fs+ ) >>= \ ewfs ->+ gitAddFiles tap >>= \ ewaf ->+ gitCommit tap txt >>= \ ewcf ->+ gitWorktreeRem root tap >>= \ ewrf ->+ case+ ( ewta+ , partitionEithers ewfs+ , ewaf+ , ewcf+ , ewrf+ )+ of+ ( Right wta+ , ( []+ , xs+ )+ , Right ___+ , Right wcf+ , Right wrf+ ) ->+ gitUpdateBranchDesc root ts txt >>= \ ewtb ->+ case ewtb of+ Right _ ->+ pure $ Right $ unlines+ [ "# Temporary worktree branch:"+ , "## Adding:"+ , wta+ , "## Saving files:"+ , concat xs+ , "## Adding files and committing :"+ , wcf+ , "## Removing:"+ , wrf+ ]+ Left e -> pure $ Left e+ ( _, (es,__), _, _, _) ->+ gitUpdateBranchDesc root ts err >>= \ ewtb ->+ case ewtb of+ Right _ ->+ pure $ Left $ unlines+ [ "# Temporary worktree branch error(s):"+ , "## Adding:"+ , fromLeft "No error" ewta+ , "## Adding description:"+ , fromLeft "No error" ewtb+ , "## Saving files:"+ , concat es+ , "## Adding files:"+ , fromLeft "No error" ewaf+ , "## Committing:"+ , fromLeft "No error" ewcf+ , "## Removing:"+ , fromLeft "No error" ewrf+ ]+ Left e -> pure $ Left e+ where+ err = "[ERROR]: " ++ txt+ where+ tap = tmp ++ "/" ++ ts+ dir = tap ++ "/" ++ cdir+ Left e ->+ pure $ Left e+ _______ ->+ pure $ Left "No timestamp"+ (False, ____) ->+ pure $ Left "No GIT repo initialized"+ (____, False) ->+ pure $ Left "No /tmp/ folder added to the .gitignore file"+ Left err ->+ pure $ Left err+ Nothing ->+ pure $ Left noLlmConf++--------------------------------------------------------------------------------++class+ ( EFF.LlmConf m+ , EFF.LlmCodeConf m+ )+ => LlmCodeConf m+ where+ llmCodeAPI+ :: m (Maybe String)+ llmCodeKey+ :: m (Maybe String)++instance+ ( EFF.LlmConf RIO+ , EFF.LlmCodeConf RIO+ )+ => LlmCodeConf RIO+ where+ llmCodeAPI = getEnvVar "LLM_CODE_LOCALHOST_API"+ llmCodeKey = pure Nothing++--------------------------------------------------------------------------------++class+ ( EFF.LlmConf m+ , EFF.LlmCodeConf m+ )+ => LlmCodePost m+ where+ llmCodeWeb+ :: String+ -> m (Either String String)++instance+ ( EFF.LlmConf RIO+ , EFF.LlmCodeConf RIO+ )+ => LlmCodePost RIO+ where+ llmCodeWeb json =+ EFF.llmCodeAPI >>= \ mapi ->+ EFF.llmCodeKey >>= \ mkey ->+ llmCurl json mapi mkey++--------------------------------------------------------------------------------+--------------------------------------------------------------------------------++class+ EFF.LlmConf m+ => LlmPlanRoot m+ where+ llmPlanDir+ :: m String++instance+ ( EFF.LlmConf RIO+ , EFF.LlmPlanRoot RIO+ )+ => LlmPlanRoot RIO+ where+ llmPlanDir = pure "."++--------------------------------------------------------------------------------++class+ EFF.LlmConf m+ => LlmPlanMask m+ where+ llmPlanMsk+ :: m [String]++instance+ ( EFF.LlmConf RIO+ , EFF.LlmPlanMask RIO+ )+ => LlmPlanMask RIO+ where+ llmPlanMsk =+ pure+ [ "*.org"+ , "*.md"+ ]++--------------------------------------------------------------------------------++class+ ( EFF.LlmConf m+ , EFF.LlmPlanRoot m+ , EFF.LlmPlanMask m+ , EFF.LlmCodeRead m+ )+ => LlmPlanRead m+ where+ llmPlanSeq+ :: Maybe LLM.Filter+ -> m (Either [String] LLM.FilePaths)+ llmPlanGet+ :: String+ -> m (Either String LLM.File)++instance+ ( EFF.LlmConf RIO+ , EFF.LlmPlanRoot RIO+ , EFF.LlmPlanMask RIO+ , EFF.LlmCodeRead RIO+ )+ => LlmPlanRead RIO+ where+ llmPlanSeq mfilter =+ EFF.llmPathCWD >>= \ ocwd ->+ case ocwd of+ Just (LLM.Root root) ->+ EFF.llmPlanDir >>= \ pdir ->+ EFF.llmPlanMsk >>= \ pmsk ->+ realPath (root ++ pdir) >>= \ efap ->+ case efap of+ -- TODO: DRY+ Right fap ->+ ( \ case+ ([], rs) -> Right $ LLM.FilePaths $ mconcat rs+ (ls, __) -> Left ls+ )+ . partitionEithers+ <$> mapM (\ msk -> findFiles fap ("*" ++ fil ++ "*" ++ msk)) pmsk+ Left err ->+ pure $ Left [err]+ Nothing ->+ pure $ Left [noLlmConf]+ where+ fil =+ case mfilter of+ Just (LLM.Filter f) -> f+ Nothing -> [ ]++ llmPlanGet abspath =+ EFF.llmPathCWD >>= \ ocwd ->+ EFF.llmPlanDir >>= \ pdir ->+ case ocwd of+ -- TODO: DRY+ Just (LLM.Root root) ->+ realPath (root ++ pdir) >>= \ efap ->+ case efap of+ Right fap ->+ if fap `isPrefixOf` abspath then+ -- NOTE: Root relative path+ Right . LLM.File . (,) (drop len abspath) . lines+ <$> readFileStrict abspath+ else+ pure $ Left $ notPrefixRootAndMode fap abspath LLM.Plan+ Left err ->+ pure $ Left err+ where+ len = length root+ Nothing ->+ pure $ Left noLlmConf++--------------------------------------------------------------------------------++class+ ( EFF.LlmConf m+ , EFF.LlmPlanConf m+ )+ => LlmPlanConf m+ where+ llmPlanAPI+ :: m (Maybe String)+ llmPlanKey+ :: m (Maybe String)++instance+ ( EFF.LlmConf RIO+ , EFF.LlmPlanConf RIO+ )+ => LlmPlanConf RIO+ where+ llmPlanAPI = getEnvVar "LLM_PLAN_LOCALHOST_API"+ llmPlanKey = pure Nothing++--------------------------------------------------------------------------------++class+ ( EFF.LlmConf m+ , EFF.LlmPlanConf m+ )+ => LlmPlanPost m+ where+ llmPlanWeb+ :: String+ -> m (Either String String)++instance+ ( EFF.LlmConf RIO+ , EFF.LlmPlanConf RIO+ )+ => LlmPlanPost RIO+ where+ llmPlanWeb json =+ EFF.llmPlanAPI >>= \ mapi ->+ EFF.llmPlanKey >>= \ mkey ->+ llmCurl json mapi mkey++--------------------------------------------------------------------------------+--------------------------------------------------------------------------------++-- HELPERS (public)++getEnvVar+ :: String+ -> RIO (Maybe String)+getEnvVar =+ RestrictedIO . ENV.getEnv++--------------------------------------------------------------------------------++-- HELPERS (private)++findFiles+ :: FilePath+ -> String+ -> RIO (Either String [String])+findFiles path mask =+ -- NOTE: Remove any '\NUL` from filepaths+ -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/10110+ ( \case+ Right str ->+ Right+ -- NOTE: We use absolute paths, but, only show relative+ $ map (filter (/= '\NUL'))+ $ lines str+ Left err ->+ Left err+ )+ <$> withExitCodeCwd path "find"+ -- NOTE: Use -ipath and -iname (case insensitive) instead?+ [ path+ -- NOTE: Limit to files, excluding symbolic links+ , "-type", "f"+ -- NOTE: Exclude tmp folder+ , "-not"+ , "-path"+ , path ++ "/tmp/*"+ , "-and"+ -- NOTE: Exclude llm tpl folder+ , "-not"+ , "-ipath"+ , path ++ "/llm/*"+ , "-and"+ -- NOTE: Exclude dot files and hereby tmp Emacs files (.*#)+ , "-not"+ , "-name"+ , ".*"+ , "-and"+ -- NOTE: Look for filter mask+ , "-path"+ , mask+ , "-print"+ ]++noLlmConf :: String+noLlmConf =+ "No EFF.LlmConf instance is defined."++notPrefixRootAndMode+ :: FilePath+ -> FilePath+ -> LLM.Mode+ -> String+notPrefixRootAndMode rpath apath mode =+ rpath ++ " is not a prefix of " ++ apath ++ " for: " ++ show mode++gitExist+ :: FilePath+ -> RIO Bool+gitExist path =+ ( \case+ Right _ -> True+ Left _ -> False+ )+ <$> withExitCodeCwd path "git"+ [ "status"+ ]++gitignoreTmp+ :: FilePath+ -> RIO Bool+gitignoreTmp path =+ any (== "/tmp/") . lines+ <$> readFileStrict gi+ where+ gi = path ++ "/.gitignore"++gitWorktreeAdd+ :: FilePath+ -> String+ -> FilePath+ -> RIO (Either String String)+gitWorktreeAdd root ts path =+ withExitCodeCwd root "git"+ [ "worktree"+ , "add", "-b", ts+ , path+ ]++gitAddFiles+ :: FilePath+ -> RIO (Either String String)+gitAddFiles path =+ withExitCodeCwd path "git"+ [ "add"+ , "."+ ]++gitCommit+ :: FilePath+ -> String+ -> RIO (Either String String)+gitCommit root mesg =+ withExitCodeCwd root "git"+ [ "commit"+ , "-m"+ , mesg+ ]++gitWorktreeRem+ :: FilePath+ -> FilePath+ -> RIO (Either String String)+gitWorktreeRem root path =+ withExitCodeCwd root "git"+ [ "worktree"+ , "remove"+ , path+ ]++gitBranchesDesc+ :: FilePath+ -> RIO (Either String String)+gitBranchesDesc root =+ withExitCodeCwd root "git"+ [ "config"+ , "--get-regexp"+ , "branch.*.description"+ ]++gitUpdateBranchDesc+ :: FilePath+ -> String+ -> String+ -> RIO (Either String String)+gitUpdateBranchDesc path ts desc =+ withExitCodeCwd path "git"+ [ "config"+ , "branch." ++ ts ++ ".description"+ , desc+ ]++llmCurl+ :: String+ -> Maybe String+ -> Maybe String+ -> RIO (Either String String)+llmCurl json mapi mkey =+ case (mapi, mkey) of+ (Nothing, _ ) ->+ RestrictedIO $ pure $ Left "No API address was provided"+ (Just api, Nothing) ->+ withExitCodeStdIn "curl"+ ( [ -- "--verbose"+ "--silent"+ , "--show-error"+ ]+ ++ hs +++ [ -- NOTE: https://curl.se/docs/manpage.html#--json+ "--json", "@-"+ , api ++ "/chat/completions"+ ]+ )+ json+ (Just api, Just key) ->+ withExitCodeStdIn "curl"+ ( [ --"--verbose"+ "--silent"+ , "--show-error"+ , "--header", "Authorization: " ++ key+ ]+ ++ hs +++ [ -- NOTE: https://curl.se/docs/manpage.html#--json+ "--json", "@-"+ , api ++ "/chat/completions"+ ]+ )+ json+ where+ hs =+ [ "--header" , "Accept: application/json"+ , "--header" , "Accept-Encoding: gzip, deflate, br"+ , "--header" , "Content-Type: application/json; charset=utf-8"+ , "--header" , "User-Agent: Λ-gent/0.11"+ ]++readFileStrict+ :: FilePath+ -> RIO String+readFileStrict path =+ -- TODO:+ --+ -- Refactor `RIO String` to `RIO (Either String String)`+ RestrictedIO $+ do+ eproc <-+ try+ ( aux+ ) :: IO (Either SomeException String)+ case eproc of+ Right txt -> pure txt+ Left ___ -> pure []+ where+ aux =+ readFile path >>= \cs ->+ length cs `seq` pure cs++writeFileStrict+ :: FilePath+ -> String+ -> RIO (Either String String)+writeFileStrict path txt =+ RestrictedIO $+ do+ eproc <-+ try+ ( writeFile path txt+ ) :: IO (Either SomeException ())+ case eproc of+ Right _ ->+ pure $ Right path+ Left e -> pure $ Left $ show e++realPath+ :: FilePath+ -> RIO (Either String String)+realPath path =+ -- NOTE: `realpath` removes any trailing '/' for directories+ --+ -- NOTE: Remove any '\NUL` from filepaths+ -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/10110+ ( \case+ Right str -> Right $ filter (/= '\n') str+ Left err -> Left err+ )+ <$> withExitCode "realpath"+ [ path+ ]++ensureFolderPath+ :: FilePath+ -> FilePath+ -> RIO (Either String String)+ensureFolderPath root path =+ withExitCodeCwd root "dirname" [ path ] >>= \ eadp ->+ case eadp of+ Right adp ->+ withExitCodeCwd root "mkdir" [ "-p", foo ] >>= \ emeh ->+ case emeh of+ Right _ -> pure $ Right foo+ Left e -> pure $ Left e+ where+ foo = filter (/= '\n') adp+ Left err -> pure $ Left err++timestampUTC :: RIO (Maybe String)+timestampUTC =+ ( \case+ Right cs -> Just $ filter ( \ c -> c == '-' || isDigit c ) cs+ Left __ -> Nothing+ )+ <$> withExitCode "date"+ [ "-u"+ , "+'%Y%m%d-%H%M%S-%N'"+ ]++withExitCode+ :: String+ -> [String]+ -> RIO (Either String String)+withExitCode cmd args =+ RestrictedIO $+ do+ eproc <-+ try+ ( readProcessWithExitCode cmd args []+ ) :: IO (Either SomeException ((ExitCode, String, String)))+ case eproc of+ Right (exitcode, out, err) ->+ case exitcode of+ ExitSuccess ->+ pure $ Right out+ ExitFailure _ ->+ pure $ Left $ err+ Left e -> pure $ Left $ show e++withExitCodeStdIn+ :: String+ -> [String]+ -> String+ -> RIO (Either String String)+withExitCodeStdIn cmd args txt =+ RestrictedIO $+ do+ eproc <-+ try+ ( aux+ ) :: IO (Either SomeException ((ExitCode, String, String)))+ case eproc of+ Right (exitcode, out, err) ->+ case exitcode of+ ExitSuccess ->+ -- NOTE: When debugging, ex: `curl`, add the `--verbose` flag,+ -- which uses `stderr`. Just combine `err` and `out` like this:+ --+ -- pure $ Right ("[DEBUG]: " ++ err ++ "\n" ++ out)+ pure $ Right out+ ExitFailure _ ->+ pure $ Left $ err+ Left e -> pure $ Left $ show e+ where+ raw = proc cmd args+ rcp =+ raw+ { std_in = CreatePipe+ , std_out = CreatePipe+ , std_err = CreatePipe+ }+ aux =+ do+ (Just hinp, Just hout, Just herr, ph) <- createProcess rcp+ hPutStrLn hinp txt+ hClose hinp+ out <- hGetContents hout+ err <- hGetContents herr+ exitcode <- waitForProcess ph+ return (exitcode, out, err)++withExitCodeCwd+ :: String+ -> String+ -> [String]+ -> RIO (Either String String)+withExitCodeCwd path cmd args =+ RestrictedIO $+ do+ eproc <-+ try+ ( readCreateProcessWithExitCode rcp []+ ) :: IO (Either SomeException ((ExitCode, String, String)))+ case eproc of+ Right (exitcode, out, err) ->+ case exitcode of+ ExitSuccess ->+ pure $ Right out+ ExitFailure _ ->+ pure $ Left $ err+ Left e -> pure $ Left $ show e+ where+ raw = proc cmd args+ rcp = raw { cwd = Just path }
+ src/Internal/Utils.hs view
@@ -0,0 +1,131 @@+{-# OPTIONS_GHC -Wall -Werror #-}++{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}+{-# LANGUAGE Safe #-}++--------------------------------------------------------------------------------++-- |+-- 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 Internal.Utils+ ( -- * Files+ files+ , file+ -- * History+ , chits+ , chats+ -- * Helpers+ , combine+ , leftpad+ , index+ , split+ , linesOptNums+ )+where++--------------------------------------------------------------------------------++import Prelude hiding ( lines )+import qualified Prelude as Prelude++--------------------------------------------------------------------------------++combine+ :: [ (String, String) ]+ -> [ String ]+combine =+ map+ ( \ (x, y) ->+ if null x then+ y+ else+ x ++ ": " ++ y+ )++leftpad+ :: Char+ -> Int+ -> [Char]+ -> [Char]+leftpad chr rep cs =+ replicate (rep - length xs) chr ++ xs+ where+ xs = take rep cs++index+ :: Int+ -> Int+ -> String+index rep idx =+ leftpad '0' rep $ show idx++split+ :: Char+ -> String+ -> [String]+split sep str =+ case dropWhile (== sep) str of+ [] -> []+ cs ->+ b : split sep bs+ where+ (b, bs) = break (== sep) cs++--------------------------------------------------------------------------------++files+ :: String+ -> Bool+ -> [ String ]+ -> [ (String, String) ]+files prefix nums fs =+ linesOptNums prefix nums 0 fs++file+ :: Bool+ -> String+ -> [ (String, String) ]+file nums f =+ linesOptNums [] nums 1 $ Prelude.lines f++--------------------------------------------------------------------------------++chits+ :: Bool+ -> [ String ]+ -> [ (String, String) ]+chits nums fs =+ linesOptNums [] nums 0 $ reverse fs++chats+ :: Bool+ -> [ String ]+ -> [ (String, String) ]+chats nums fs =+ linesOptNums [] nums 0 $ reverse fs++--------------------------------------------------------------------------------++-- HELPERS (private)++linesOptNums+ :: String+ -> Bool+ -> Int+ -> [ String ]+ -> [ (String, String) ]+linesOptNums prefix nums origo xs =+ zipWith (\ idx rel -> (prefix ++ f idx, rel)) [origo..] xs+ where+ len = length $ show $ length xs+ f i =+ if nums then+ index len i+ else+ []