diff --git a/A-gent.cabal b/A-gent.cabal new file mode 100644 --- /dev/null +++ b/A-gent.cabal @@ -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 +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 diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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`: + + ``` + + ``` + + 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 + : 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: + +* There is a `BUG` when trying to print emojii's ('🍎', '🍏', …): + ```shell + : 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 diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -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 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,108 @@ +Λ-gent +====== + +[![Hackage](https://img.shields.io/hackage/v/A-gent.svg)](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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -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 +-- Stability : experimental + +-------------------------------------------------------------------------------- + +import Distribution.Simple + ( defaultMain + ) + +-------------------------------------------------------------------------------- + +main :: IO () +main = defaultMain diff --git a/src/Agent/Control/Concurrent.hs b/src/Agent/Control/Concurrent.hs new file mode 100644 --- /dev/null +++ b/src/Agent/Control/Concurrent.hs @@ -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 +-- 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 diff --git a/src/Agent/Control/IFC.hs b/src/Agent/Control/IFC.hs new file mode 100644 --- /dev/null +++ b/src/Agent/Control/IFC.hs @@ -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 +-- 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 diff --git a/src/Agent/Control/MAC.hs b/src/Agent/Control/MAC.hs new file mode 100644 --- /dev/null +++ b/src/Agent/Control/MAC.hs @@ -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 +-- 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 diff --git a/src/Agent/Data/ANSI/EscapeCode.hs b/src/Agent/Data/ANSI/EscapeCode.hs new file mode 100644 --- /dev/null +++ b/src/Agent/Data/ANSI/EscapeCode.hs @@ -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 +-- 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 diff --git a/src/Agent/Data/JSON.hs b/src/Agent/Data/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Agent/Data/JSON.hs @@ -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 +-- 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 diff --git a/src/Agent/IO/Effects.hs b/src/Agent/IO/Effects.hs new file mode 100644 --- /dev/null +++ b/src/Agent/IO/Effects.hs @@ -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 +-- 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) + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- diff --git a/src/Agent/IO/Restricted.hs b/src/Agent/IO/Restricted.hs new file mode 100644 --- /dev/null +++ b/src/Agent/IO/Restricted.hs @@ -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 +-- 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 + ) diff --git a/src/Agent/LLM.hs b/src/Agent/LLM.hs new file mode 100644 --- /dev/null +++ b/src/Agent/LLM.hs @@ -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 +-- 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 diff --git a/src/Agent/LLM/Action.hs b/src/Agent/LLM/Action.hs new file mode 100644 --- /dev/null +++ b/src/Agent/LLM/Action.hs @@ -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 +-- 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 diff --git a/src/Agent/LLM/Message.hs b/src/Agent/LLM/Message.hs new file mode 100644 --- /dev/null +++ b/src/Agent/LLM/Message.hs @@ -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 +-- 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" diff --git a/src/Internal/GaloisInc/Text/JSON.hs b/src/Internal/GaloisInc/Text/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Internal/GaloisInc/Text/JSON.hs @@ -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") diff --git a/src/Internal/GaloisInc/Text/JSON/Generic.hs b/src/Internal/GaloisInc/Text/JSON/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Internal/GaloisInc/Text/JSON/Generic.hs @@ -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 diff --git a/src/Internal/GaloisInc/Text/JSON/String.hs b/src/Internal/GaloisInc/Text/JSON/String.hs new file mode 100644 --- /dev/null +++ b/src/Internal/GaloisInc/Text/JSON/String.hs @@ -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 + diff --git a/src/Internal/GaloisInc/Text/JSON/Types.hs b/src/Internal/GaloisInc/Text/JSON/Types.hs new file mode 100644 --- /dev/null +++ b/src/Internal/GaloisInc/Text/JSON/Types.hs @@ -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) diff --git a/src/Internal/GlasgowUniversity/Data/Generics/Aliases.hs b/src/Internal/GlasgowUniversity/Data/Generics/Aliases.hs new file mode 100644 --- /dev/null +++ b/src/Internal/GlasgowUniversity/Data/Generics/Aliases.hs @@ -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} diff --git a/src/Internal/LLM.hs b/src/Internal/LLM.hs new file mode 100644 --- /dev/null +++ b/src/Internal/LLM.hs @@ -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 +-- 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 + "" ++ pur ++ "" + ) ++ + ( if eis then + [] + else + "" ++ + tis ++ + "" + ) ++ + ( if ees then + [] + else + "" ++ + tes ++ + "" + ) ++ + ( if efs then + [] + else + "" ++ + concatMap aux tfs ++ + "" + ) + ] + 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 -> "" ++ x ++ "") + $ instructions tpl + tes = + concatMap (\ x -> "" ++ x ++ "") + $ examples tpl + tfs = zip [0 :: Int ..] $ files tpl + aux (i, File (src, ls)) = + "" ++ + "" ++ src ++ "" ++ + "" ++ unlines ls ++ "" ++ + "" diff --git a/src/Internal/LLM/Action.hs b/src/Internal/LLM/Action.hs new file mode 100644 --- /dev/null +++ b/src/Internal/LLM/Action.hs @@ -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 +-- 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 diff --git a/src/Internal/RIO.hs b/src/Internal/RIO.hs new file mode 100644 --- /dev/null +++ b/src/Internal/RIO.hs @@ -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 +-- 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 } diff --git a/src/Internal/Utils.hs b/src/Internal/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Utils.hs @@ -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 +-- 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 + []