diff --git a/A-gent.cabal b/A-gent.cabal --- a/A-gent.cabal +++ b/A-gent.cabal @@ -9,7 +9,7 @@ build-type: Simple name: A-gent -version: 0.11.0.19 +version: 0.11.0.20 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 @@ -30,11 +30,15 @@ extra-doc-files: README.md, CHANGELOG.md tested-with: - GHC == 9.4.8 + -- NOTE: Only support versions that are recommended for use: + -- + -- https://gitlab.haskell.org/ghc/ghc/-/wikis/GHC%20Status#most-recent-ghc-major-versions + -- https://github.com/NixOS/nixpkgs/tree/haskell-updates/pkgs/development/compilers/ghc GHC == 9.6.7 GHC == 9.8.4 GHC == 9.10.3 GHC == 9.12.4 + GHC == 9.14.1 source-repository head type: @@ -129,10 +133,11 @@ -- JSON -trust=containers -trust=mtl - if impl(ghc >= 9.10 && < 9.13) + if impl(ghc >= 9.10 && < 9.15) ghc-options: -- Base - -- NOTE: Issue with Hackage that builds with 9.8.4. 9.10.x requies this: + -- NOTE: Issue with Hackage that builds with 9.8.4. 9.10.x and greater, + -- requies this: -trust=ghc-internal library @@ -155,6 +160,7 @@ -- Internal.LLM Internal.LLM.Action + Internal.LLM.SystemOne -- Internal.Utils exposed-modules: diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,108 @@ # Revision history for Λ-gent +## 0.11.0.20 -- 2026-10-21 + +* Added [Cabal-plan][cabal-plan] info and topology for the project to help deal + with the `nix/NixOS` as well as `Hackage` issues when it comes to package + dependencies. + +* Added Mockup servers for traditional (outdated/legacy?) LLM's as well as SOM + with static JSON payloads for faster development pace: + + * `muppt.{sh|json}`: [OpenAI][openai-api] style chat completion API + + * `musom.{sh|json}`: [Jev][jev-api] system one style API + +* Hone/Auto-mode were initially implemented with support for traditional + (outdated/legacy?) LLM's. However due to the release of usable open source + decision models, we have refactored and now ONLY support [System One (API) + models (SOM)][systemone]: + + ``` + #!/bin/sh + + ################################################################################ + ## + ## Λ-gent, (c) 2026 SPISE MISU ApS, https://spdx.org/licenses/SSPL-1.0 + ## + ################################################################################ + + clear + + cwd="${HOME}/temp/a-gent/no-prelude-loc/" + som="http://127.0.0.1:3000/v1" # clef-omni-8bit, clef-flash-8bit and clef-Nbit + + LLM_PATH_CWD="${cwd}" \ + LLM_HSOM_LOCALHOST_SOM="${som}" \ + LC_ALL=en_US.UTF-8 ./hone.lhs + ``` + +* Hone-mode as well as Auto-mode, to provide `Λ-gent` with Automated Typed-Hole + development capabilities, has been added as well. For more info, see the + following commands: + + ``` + /disc | Discover files with typed-holes and store them in /pile + /hole i | Show file (idx) typed-holes, if any. See /pile above + /fill | Send /pile to LLM, to fill typed-holes with best suggestions + ``` + + and + + ``` + /exec | Execute the automated mode. Limited by /mode auto + /halt | Bring automation to a halt. Limited by /mode auto + ``` + + > **NOTE:** These modes depend on scaffolding that MUST be provided by the + > Plan-mode (generate minimum code files with typed-holes aka "green") as well + > as the Spec-mode (generating property-base test cases aka "red") as in the + > [Test-Driven Development (TDD)][tdd] mantra: "red/green/refactor". + > + > However, these modes are not released yet as by doing so, they would be + > limited ONLY to Haskell and hereby lock-in `Λ-gents` to a single programming + > language, which might not be ideal. + +* For the Spec-mode, still not released, we needed to be able to test as we + normally do (`QuickCheck`), but without any I/O effects. Therefore, a + standalone library, [quickcheck-silent][quickcheck-silent], was created and + published to `Hackage`. It will be used when invoking the following command: + + ``` + /test u | Test TAIL or /atom GIT branches (uid) against specification + ``` + +* Updated local worktree naming convention + +* Parsed files are now trimmed (`trimLines` in `src/Agent/LLM.hs`) + +* Expanded GIT support with the following commands: + + ``` + /repo | List /atom created GIT branches, including description + /tail | Show (opt create) TAIL, based on origin/HEAD, as local storage + /diff u | Show GIT branch (uid) differences with TAIL or origin/HEAD + /disp | Dispose /atom failed branches or are behind/older than TAIL + /meld | Auto-merge branches with TAIL, if possible. See /disp above + /push | Create a remote branch, on origin, for TAIL + /pull | Retrieve latest snapshot of origin/HEAD. See /push above + /shed | Remove TAIL, if merged with origin/HEAD. See /pull above + ``` + +* Some scripts didn't work as expected after doing the suggestions from + [ShellCheck][shellcheck]. + +* The project now aims to ONLY support the `GHC` versions that are recommended + for use, see References in `shell.nix`. + +[shellcheck]: https://github.com/koalaman/shellcheck +[quickcheck-silent]: https://hackage.haskell.org/package/quickcheck-silent +[tdd]: https://en.wikipedia.org/wiki/Test-driven_development +[systemone]: https://systemonemodels.org/ +[openai-api]: https://developers.openai.com/api/reference/chat-completions/overview +[jev-api]: https://docs.typesafe.ai/concepts/system-one +[cabal-plan]: https://hackage.haskell.org/package/cabal-plan + ## 0.11.0.19 -- 2026-07-11 * Feature branch descriptions prefix tags for `Λ-gent` mode on success as done diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,7 @@ Λ-gent ====== -[![Hackage](https://img.shields.io/hackage/v/A-gent.svg)](https://hackage.haskell.org/package/A-gent) +[![Hackage](https://img.shields.io/hackage/v/A-gent.svg)][hackage-shield] `Λ-gent`, pronounced «_**a gent**_», where the **capital lambda** (`Λ`) is a replacement of the letter `A` in **agent** due to their similarities and [lambda @@ -16,6 +16,7 @@ > _«Polite, well **educated**, has excellent manners and **always** behaves > well»_ +[hackage-shield]: https://hackage.haskell.org/package/A-gent [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) @@ -30,57 +31,161 @@ ================= ```sh -|-- doc -|-- src -| |-- Agent -| | |-- Control -| | | |-- Concurrent.hs -| | | |-- IFC.hs -| | | `-- MAC.hs -| | |-- Data -| | | |-- ANSI -| | | | `-- EscapeCode.hs -| | | `-- JSON.hs -| | |-- IO -| | | |-- Effects.hs -| | | `-- Restricted.hs -| | |-- LLM -| | | |-- Action.hs -| | | `-- Message.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 -| | | `-- Action.hs -| | |-- LLM.hs -| | |-- RIO.hs -| | `-- Utils.hs -| `-- demo.hs -|-- uat -| `-- TODO.md -|-- A-gent.cabal -|-- CHANGELOG.md -|-- LICENSE.md -|-- LICENSE_AGPL-3.0-only.txt -|-- LICENSE_SML-2.0.txt -|-- LICENSE_SSPL-1.0.txt -|-- README.md -|-- Setup.hs -`-- todo.org +├── doc +├── src +│   ├── Agent +│   │   ├── Control +│   │   │   ├── Concurrent.hs +│   │   │   ├── IFC.hs +│   │   │   └── MAC.hs +│   │   ├── Data +│   │   │   ├── ANSI +│   │   │   │   └── EscapeCode.hs +│   │   │   └── JSON.hs +│   │   ├── IO +│   │   │   ├── Effects.hs +│   │   │   └── Restricted.hs +│   │   ├── LLM +│   │   │   ├── Action.hs +│   │   │   └── Message.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 +│   │   ├── Action.hs +│   │   └── SystemOne.hs +│   ├── LLM.hs +│   ├── RIO.hs +│   └── Utils.hs +├── uat +│   └── TODO.md +├── A-gent.cabal +├── CHANGELOG.md +├── LICENSE.md +├── LICENSE_AGPL-3.0-only.txt +├── LICENSE_SML-2.0.txt +├── LICENSE_SSPL-1.0.txt +├── README.md +├── Setup.hs +└── todo.org +``` + +Project dependencies +==================== + +## Tree + +``` +A-gent-0.11.0.20 + ├─ base-4.19.2.0 + │ ├─ ghc-bignum-1.3 + │ │ └─ ghc-prim-0.11.0 + │ │ └─ rts-1.0.2 + │ ├─ ghc-prim-0.11.0 ┄┄ + │ └─ rts-1.0.2 ┄┄ + ├─ containers-0.8 + │ ├─ array-0.5.8.0 + │ │ └─ base-4.19.2.0 ┄┄ + │ ├─ base-4.19.2.0 ┄┄ + │ ├─ deepseq-1.5.1.0 + │ │ ├─ base-4.19.2.0 ┄┄ + │ │ └─ ghc-prim-0.11.0 ┄┄ + │ └─ template-haskell-2.21.0.0 + │ ├─ base-4.19.2.0 ┄┄ + │ ├─ ghc-boot-th-9.8.4 + │ │ └─ base-4.19.2.0 ┄┄ + │ ├─ ghc-prim-0.11.0 ┄┄ + │ └─ pretty-1.1.3.6 + │ ├─ base-4.19.2.0 ┄┄ + │ ├─ deepseq-1.5.1.0 ┄┄ + │ └─ ghc-prim-0.11.0 ┄┄ + ├─ mtl-2.3.1 + │ ├─ base-4.19.2.0 ┄┄ + │ └─ transformers-0.6.1.0 + │ └─ base-4.19.2.0 ┄┄ + └─ process-1.6.25.0 + ├─ base-4.19.2.0 ┄┄ + ├─ deepseq-1.5.1.0 ┄┄ + ├─ directory-1.3.8.5 + │ ├─ base-4.19.2.0 ┄┄ + │ ├─ filepath-1.4.301.0 + │ │ ├─ base-4.19.2.0 ┄┄ + │ │ ├─ bytestring-0.12.1.0 + │ │ │ ├─ base-4.19.2.0 ┄┄ + │ │ │ ├─ deepseq-1.5.1.0 ┄┄ + │ │ │ ├─ ghc-prim-0.11.0 ┄┄ + │ │ │ └─ template-haskell-2.21.0.0 ┄┄ + │ │ ├─ deepseq-1.5.1.0 ┄┄ + │ │ ├─ exceptions-0.10.7 + │ │ │ ├─ base-4.19.2.0 ┄┄ + │ │ │ ├─ mtl-2.3.1 ┄┄ + │ │ │ ├─ stm-2.5.3.1 + │ │ │ │ ├─ array-0.5.8.0 ┄┄ + │ │ │ │ └─ base-4.19.2.0 ┄┄ + │ │ │ ├─ template-haskell-2.21.0.0 ┄┄ + │ │ │ └─ transformers-0.6.1.0 ┄┄ + │ │ └─ template-haskell-2.21.0.0 ┄┄ + │ ├─ time-1.12.2 + │ │ ├─ base-4.19.2.0 ┄┄ + │ │ └─ deepseq-1.5.1.0 ┄┄ + │ └─ unix-2.8.6.0 + │ ├─ base-4.19.2.0 ┄┄ + │ ├─ bytestring-0.12.1.0 ┄┄ + │ ├─ filepath-1.4.301.0 ┄┄ + │ └─ time-1.12.2 ┄┄ + ├─ filepath-1.4.301.0 ┄┄ + └─ unix-2.8.6.0 ┄┄ +``` + +## Direct deps + +``` +PkgId (PkgName "A-gent") (Ver [0,11,0,20]) +CompNameLib + base-4.19.2.0 + containers-0.8 + mtl-2.3.1 + process-1.6.25.0 +``` + +## Topological sort + +``` +A-gent-0.11.0.20 +process-1.6.25.0 +directory-1.3.8.5 +unix-2.8.6.0 +time-1.12.2 +filepath-1.4.301.0 +exceptions-0.10.7 +stm-2.5.3.1 +bytestring-0.12.1.0 +mtl-2.3.1 +transformers-0.6.1.0 +containers-0.8 +template-haskell-2.21.0.0 +pretty-1.1.3.6 +ghc-boot-th-9.8.4 +deepseq-1.5.1.0 +array-0.5.8.0 +base-4.19.2.0 +ghc-bignum-1.3 +ghc-prim-0.11.0 +rts-1.0.2 ``` Licenses diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -Wall -Werror #-} +{-# OPTIONS_GHC -Wall #-} -------------------------------------------------------------------------------- @@ -10,9 +10,7 @@ -------------------------------------------------------------------------------- -import Distribution.Simple - ( defaultMain - ) +import Distribution.Simple ( defaultMain ) -------------------------------------------------------------------------------- diff --git a/src/Agent/Control/Concurrent.hs b/src/Agent/Control/Concurrent.hs --- a/src/Agent/Control/Concurrent.hs +++ b/src/Agent/Control/Concurrent.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -Wall -Werror #-} +{-# OPTIONS_GHC -Wall #-} {-# LANGUAGE NoGeneralizedNewtypeDeriving #-} {-# LANGUAGE Safe #-} @@ -33,14 +33,11 @@ -------------------------------------------------------------------------------- -{- DEBUG - import Control.Concurrent ( ThreadId , forkFinally , getNumCapabilities , killThread - , threadDelay ) import Control.Concurrent.MVar @@ -51,33 +48,6 @@ , tryReadMVar ) -import GHC.Exception - ( SomeException - , errorCallException - , throw - ) - --} - -{- - --} - -import Control.Concurrent - ( ThreadId - , forkFinally - , getNumCapabilities - , killThread - ) - -import Control.Concurrent.MVar - ( MVar - , newEmptyMVar - , putMVar - , readMVar - , tryReadMVar - ) - import GHC.Exception ( SomeException, throw ) -------------------------------------------------------------------------------- @@ -187,12 +157,7 @@ forkFinally compute (finally var) >>= \ tid -> pure $ Task tid var $ get var where - finally v r = - -- DEBUG: sleep for 9 million microseconds, or 9 seconds - --threadDelay 9000000 >> - -- DEBUG: Force an exception - --put v (Left $ errorCallException "DEBUG") - put v r + finally = put wait (Task _ _ mval) = ( \case Right v -> v diff --git a/src/Agent/Control/IFC.hs b/src/Agent/Control/IFC.hs --- a/src/Agent/Control/IFC.hs +++ b/src/Agent/Control/IFC.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -Wall -Werror #-} +{-# OPTIONS_GHC -Wall #-} {-# LANGUAGE NoGeneralizedNewtypeDeriving #-} {-# LANGUAGE Safe #-} diff --git a/src/Agent/Control/MAC.hs b/src/Agent/Control/MAC.hs --- a/src/Agent/Control/MAC.hs +++ b/src/Agent/Control/MAC.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -Wall -Werror #-} +{-# OPTIONS_GHC -Wall #-} {-# LANGUAGE NoGeneralizedNewtypeDeriving #-} {-# LANGUAGE Safe #-} diff --git a/src/Agent/Data/ANSI/EscapeCode.hs b/src/Agent/Data/ANSI/EscapeCode.hs --- a/src/Agent/Data/ANSI/EscapeCode.hs +++ b/src/Agent/Data/ANSI/EscapeCode.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -Wall -Werror #-} +{-# OPTIONS_GHC -Wall #-} {-# LANGUAGE NoGeneralizedNewtypeDeriving #-} {-# LANGUAGE Safe #-} @@ -98,13 +98,13 @@ 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) ++ + cb bg ++ + cf fg ++ + fb bo ++ + ff fa ++ + fi it ++ + fu un ++ + bf bl ++ "m" ++ text ++ "\ESC[00m" diff --git a/src/Agent/Data/JSON.hs b/src/Agent/Data/JSON.hs --- a/src/Agent/Data/JSON.hs +++ b/src/Agent/Data/JSON.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -Wall -Werror #-} +{-# OPTIONS_GHC -Wall #-} {-# LANGUAGE NoGeneralizedNewtypeDeriving #-} {-# LANGUAGE Safe #-} @@ -40,8 +40,8 @@ -------------------------------------------------------------------------------- data DecodeError - = InvalidJSON - | DiffSchema + = InvalidJSON !String + | DiffSchema !String -------------------------------------------------------------------------------- @@ -57,8 +57,8 @@ -> Either DecodeError a decode json = case runGetJSON readJSValue json of - Left _ -> Left InvalidJSON + Left e -> (Left . InvalidJSON) e Right v -> case fromJSON v of - Error _ -> Left DiffSchema + Error e -> (Left . DiffSchema) e Ok a -> Right a diff --git a/src/Agent/IO/Effects.hs b/src/Agent/IO/Effects.hs --- a/src/Agent/IO/Effects.hs +++ b/src/Agent/IO/Effects.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -Wall -Werror #-} +{-# OPTIONS_GHC -Wall #-} {-# LANGUAGE NoGeneralizedNewtypeDeriving #-} {-# LANGUAGE Safe #-} @@ -17,15 +17,29 @@ ( -- * LLM (Config) LlmConf(llmPathCWD) -- * LLM (Chat) - , LlmChatConf(llmChatKey, llmChatAPI) + , LlmChatConf(llmChatAPI, llmChatKey) , LlmChatPost(llmChatWeb) + , -- * LLM (Repo) + LlmRepoRoot(llmRepoDir) + , LlmRepoAtom(llmRepoBrs) + , LlmRepoTail(llmRepoGet) + , LlmRepoDesc(llmRepoLab) + , LlmRepoDiff(llmRepoCmp) + , LlmRepoDisp(llmRepoRem) + , LlmRepoMeld(llmRepoAdd) + -- Additive changes. Once added, it can't be removed. Therefore, ONLY add + -- iif Spec test are passing for the local atomic branch + -- + -- Pull request and if success (when fetch / pull from origin) then REMove + -- the local TAIL branch. + , LlmRepoPull(llmRepoReq, llmRepoTug, llmRepoDel) , -- * LLM (Code) LlmCodeRoot(llmCodeDir) , LlmCodeMask(llmCodeMsk) , LlmCodeTmpl(llmCodeIns, llmCodeExa) - , LlmCodeRead(llmCodeSeq, llmCodeGet, llmCodeGit) + , LlmCodeRead(llmCodeSeq, llmCodeGet) , LlmCodeSave(llmCodePut) - , LlmCodeConf(llmCodeKey, llmCodeAPI) + , LlmCodeConf(llmCodeAPI, llmCodeKey) , LlmCodePost(llmCodeWeb) , -- * LLM (Plan) LlmPlanRoot(llmPlanDir) @@ -33,6 +47,16 @@ , LlmPlanRead(llmPlanSeq, llmPlanGet) , LlmPlanConf(llmPlanKey, llmPlanAPI) , LlmPlanPost(llmPlanWeb) + , -- * LLM (Spec) + LlmSpecConf(llmSpecLib, llmSpecDep, llmSpecMod, llmSpecFun, llmSpecOto) + , LlmSpecTest(llmSpecRun) + , -- * LLM (Hone) + LlmHoneRoot(llmHoneDir) + , LlmHoneMask(llmHoneMsk) + , LlmHoneRead(llmHoneSeq, llmHoneGet) + , LlmHoneSave(llmHonePut) + , LlmHoneConf(llmHoneSOM, llmHoneKey) + , LlmHonePost(llmHoneWeb) ) where @@ -75,6 +99,81 @@ -------------------------------------------------------------------------------- class + LlmConf m + => LlmRepoRoot m + where + llmRepoDir + :: m (Maybe LLM.Root) + +class + LlmRepoRoot m + => LlmRepoAtom m + where + llmRepoBrs + :: m (Either [String] LLM.Branches) + +class + LlmRepoRoot m + => LlmRepoTail m + where + llmRepoGet + :: m (Either String LLM.Branch) + +class + ( LlmRepoAtom m + , LlmRepoTail m + ) + => LlmRepoDesc m + where + llmRepoLab + :: LLM.UUID + -> LLM.Label + -> m (Either String String) + +class + ( LlmRepoAtom m + , LlmRepoTail m + ) + => LlmRepoDiff m + where + llmRepoCmp + :: LLM.UUID + -> m (Either String [String]) + +class + ( LlmRepoAtom m + , LlmRepoTail m + ) + => LlmRepoDisp m + where + llmRepoRem + :: Maybe LLM.UUID + -> m (Either String [String]) + +class + ( LlmRepoAtom m + , LlmRepoTail m + ) + => LlmRepoMeld m + where + llmRepoAdd + :: m (Either String [String]) + +class + LlmRepoTail m + => LlmRepoPull m + where + llmRepoReq + :: m (Either String [String]) + llmRepoTug + :: m (Either String [String]) + llmRepoDel + :: m (Either String [String]) + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +class Monad m => LlmCodeRoot m where @@ -97,7 +196,7 @@ => LlmCodeTmpl m where llmCodeIns - :: m [LLM.File] + :: m (Either [String] [LLM.File]) llmCodeExa :: m [LLM.File] @@ -105,6 +204,7 @@ class ( LlmConf m + , LlmRepoRoot m , LlmCodeRoot m , LlmCodeMask m ) @@ -116,19 +216,20 @@ llmCodeGet :: LLM.AbsoluteFilePath -> m (Either String LLM.File) - llmCodeGit - :: m (Either String String) -------------------------------------------------------------------------------- class ( LlmConf m + , LlmRepoRoot m , LlmCodeRoot m ) => LlmCodeSave m where llmCodePut - :: String + :: LLM.Context a + -> Maybe LLM.UUID + -> String -> LLM.Files -> m (Either String String) @@ -157,7 +258,7 @@ -------------------------------------------------------------------------------- class - Monad m + LlmConf m => LlmPlanRoot m where llmPlanDir @@ -203,12 +304,119 @@ -------------------------------------------------------------------------------- class - ( LlmConf m - , LlmPlanConf m - ) + LlmPlanConf m => LlmPlanPost m where llmPlanWeb + :: String + -> m (Either String String) + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +class + Monad m + => LlmSpecConf m + where + llmSpecLib + :: m String -- Ex: "spec" + llmSpecMod + :: m String -- Ex: "Spec.Core" + llmSpecFun + :: m String -- Ex: "testSuite" + llmSpecDep + :: m [ String ] -- Ex: [ "core", "common", "utils" ] + llmSpecOto + :: m (Maybe Int) -- Ex: Just 45 + +-------------------------------------------------------------------------------- + +class + ( LlmRepoAtom m + , LlmRepoTail m + , LlmCodeRoot m + , LlmSpecConf m + ) + => LlmSpecTest m + where + llmSpecRun + :: LLM.UUID + -> m (Either String LLM.TestCases) + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +class + LlmConf m + => LlmHoneRoot m + where + llmHoneDir + :: m (Maybe LLM.Root) + +-------------------------------------------------------------------------------- + +class + LlmCodeMask m + => LlmHoneMask m + where + llmHoneMsk + :: m LLM.Mask -- NOTE: Limited to: [ "*.hs" ] + +-------------------------------------------------------------------------------- + +class + ( LlmCodeRoot m + , LlmHoneRoot m + , LlmRepoTail m + , LlmHoneMask m + ) + => LlmHoneRead m + where + llmHoneSeq + :: Maybe LLM.Filter + -> m (Either [String] LLM.FilePaths) + llmHoneGet + {- + :: LLM.AbsoluteFilePaths + -> m (Either [String] LLM.Files) + -} + :: LLM.AbsoluteFilePath + -> m (Either String LLM.File) + +-------------------------------------------------------------------------------- + +class + ( LlmConf m + , LlmRepoTail m + , LlmCodeRoot m + , LlmHoneRoot m + ) + => LlmHoneSave m + where + llmHonePut + :: LLM.Context a + -> String + -> LLM.Files + -> m (Either String String) + +-------------------------------------------------------------------------------- + +class + Monad m + => LlmHoneConf m + where + llmHoneSOM + :: m (Maybe String) + llmHoneKey + :: m (Maybe String) + +-------------------------------------------------------------------------------- + +class + LlmHoneConf m + => LlmHonePost m + where + llmHoneWeb :: String -> m (Either String String) diff --git a/src/Agent/IO/Restricted.hs b/src/Agent/IO/Restricted.hs --- a/src/Agent/IO/Restricted.hs +++ b/src/Agent/IO/Restricted.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -Wall -Werror #-} +{-# OPTIONS_GHC -Wall #-} {-# LANGUAGE NoGeneralizedNewtypeDeriving #-} {-# LANGUAGE Safe #-} @@ -44,46 +44,70 @@ -- * LLM (Config) , llmPathCWD -- * LLM (Chat) - , llmChatKey, llmChatAPI + , llmChatAPI, llmChatKey , llmChatWeb + -- * LLM (Repo) + , llmRepoDir + , llmRepoBrs + , llmRepoGet + , llmRepoLab + , llmRepoCmp + , llmRepoRem + , llmRepoAdd + , llmRepoReq, llmRepoTug, llmRepoDel -- * LLM (Code) , llmCodeDir , llmCodeMsk , llmCodeIns, llmCodeExa - , llmCodeSeq, llmCodeGet, llmCodeGit + , llmCodeSeq, llmCodeGet , llmCodePut - , llmCodeKey, llmCodeAPI + , llmCodeAPI, llmCodeKey , llmCodeWeb -- * LLM (Plan) , llmPlanDir , llmPlanMsk , llmPlanSeq, llmPlanGet - , llmPlanKey, llmPlanAPI + , llmPlanAPI, llmPlanKey , llmPlanWeb + -- * LLM (Spec) + , llmSpecLib, llmSpecDep, llmSpecMod, llmSpecFun, llmSpecOto + , llmSpecRun + -- * LLM (Hone) + , llmHoneDir + , llmHoneMsk + , llmHoneSeq, llmHoneGet + , llmHonePut + , llmHoneSOM, llmHoneKey + , llmHoneWeb ) where -------------------------------------------------------------------------------- -import Internal.RIO ( RIO ) - -import Internal.RIO ( getEnvVar ) - import Internal.RIO - ( llmChatAPI + ( RIO + , getEnvVar + , llmChatAPI , llmChatKey , llmChatWeb , llmCodeAPI , llmCodeDir , llmCodeExa , llmCodeGet - , llmCodeGit , llmCodeIns , llmCodeKey , llmCodeMsk , llmCodePut , llmCodeSeq , llmCodeWeb + , llmHoneDir + , llmHoneGet + , llmHoneKey + , llmHoneMsk + , llmHonePut + , llmHoneSOM + , llmHoneSeq + , llmHoneWeb , llmPathCWD , llmPlanAPI , llmPlanDir @@ -92,4 +116,20 @@ , llmPlanMsk , llmPlanSeq , llmPlanWeb + , llmRepoAdd + , llmRepoBrs + , llmRepoCmp + , llmRepoDel + , llmRepoDir + , llmRepoGet + , llmRepoLab + , llmRepoRem + , llmRepoReq + , llmRepoTug + , llmSpecDep + , llmSpecFun + , llmSpecLib + , llmSpecMod + , llmSpecOto + , llmSpecRun ) diff --git a/src/Agent/LLM.hs b/src/Agent/LLM.hs --- a/src/Agent/LLM.hs +++ b/src/Agent/LLM.hs @@ -1,1029 +1,1908 @@ -{-# 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, 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 (..) - , Jobs - , Mask - , Mode (..) - , Root - , Template - , UUID - , modes - ) -import qualified Internal.LLM as INT -import Internal.LLM.Action ( Action (..) ) -import Internal.RIO - ( RIO (..) - , fork - , input - , output - , terr - , timestampUTC - , tkil - , tnum - , tval - , tvar - , wait - ) -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 - { mode :: !Mode - , load :: !(Load a) - , hist :: !History - , list :: !(Maybe Filter) - , pile :: !(Maybe FilePaths) - , ruck :: !(Maybe Files) - , jobs :: !(Maybe (Jobs (Context a))) - } - -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 mode' 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 >> pure () - Left err -> - putStrLn err >> hFlush stdout - where - ctx = - Context - { mode = mode' - , load = Nothing - , hist = - History - { chit = - Chit - { prev = [] - , next = [] - } - , chat = [] - } - , list = Nothing - , pile = Just $ INT.FilePaths [] - , ruck = Just $ INT.Files [] - , jobs = Just $ INT.Jobs [] - } - --------------------------------------------------------------------------------- - --- 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 - join . (:[]) <$> 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: /mode plan" - , ds - , "/h or /hist | View history (input & 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 & filter" - , "/p or /pile | Show stored list of files in pile. See /list above" - , "/f i or /file i | Show file with the provided index. See /pile above" - , "/n i or /nums i | Show file (idx) 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 above" - , "/a d or /atom d | Atomically save /ruck files to a GIT branch (+ description)" - , " /repo | List GIT branches, including description. See /atom above" - , ds - , "/t m or /task m | Fork /send m jobs for files. See /pile above" - , "/j or /jobs | Show info for executed jobs. See /task above" - , " /sync | Join contexts, if no errors. See /jobs above" - , " /stop | Kill or abort, current jobs. See /jobs above" - , ds - , " /exec | Execute the automated mode. See /mode auto" - , " /halt | Bring automation to a halt. See /mode auto" - , ds - ] - where - ds = replicate 80 '-' - ms = - foldl1 (\ x y -> x ++ "|" ++ y) $ map (map toLower . show) modes - --------------------------------------------------------------------------------- - -loop - :: Context a - -> Eval a - -> RIO (Context a) -loop ctx eval = - print prompt >> - read hps hns >>= \ txt -> - printLn [ ] >> - timestampUTC >>= \ outs -> - loopHelper (prv txt ctx) eval (action ctx txt) outs - where - - -- TODO: Refactoring needed - his = hist ctx - chi = chit his - hps = prev chi - hns = next chi - - -- TODO: Refactoring needed - prv p c = - c - { hist = - h - { chit = - (chit $ hist c) - { prev = p : hps - } - } - } - where - h = hist c - - -- TODO: Refactoring needed - prompt = - (show . AEC.bold . AEC.sgr) - ("Λ-" ++ (map toLower . show . mode) ctx ++ "> ") - read = input - -loopHelper - :: Context a - -> Eval a - -> Action - -> Maybe String - -> RIO (Context a) -loopHelper ctx eval act_ outs = - case act_ of - -- TODO: Refactoring needed - - -- Nested -- Start - None -> - loop ctx eval - File _ -> - loop ctx eval - Template _ _ _ _ -> - loop ctx eval - -- Nested -- Stop - - Exit -> caseExit - Help -> caseHelp - Drop -> caseDrop - Hist (chits, chats) -> caseHist chits chats - Mode c cs -> caseMode c cs - Paths (INT.FilePaths fps) -> casePaths fps - Pile -> casePile - Ruck mdix -> caseRuck mdix - Wipe -> caseWipe - UnknownCmd cmd -> caseUnknownCmd cmd - - Branch msg fs -> - eval ctx (MSG.Atom msg fs) >>= \ (upd, act) -> - case act of - Message (MSG.Text cs) -> - printLn cs >> - loop (nxt upd (Just cs)) eval - None -> - loop (nxt upd Nothing) eval - _________________________ -> - -- NOTE: Unexpected error - printLn "Unexpected error" >> - loop (nxt upd (Just [])) eval - - Prompt msg -> - - eval ctx (MSG.Tmpl afps) >>= \ (upd0, act0) -> - case act0 of - Template p is es fs -> - - eval upd0 (MSG.Send xml) >>= \ (upd1, act1) -> - case act1 of - Message (MSG.Text cs) -> - printLn cs >> - loop - ( nxt - ( upd1 { ruck = Just $ pfs } - ) - ( Just cs - ) - ) eval - where - pfs = - case (map INT.File . p) cs of - [] -> INT.Files [] - xs -> INT.Files xs - None -> - loop (nxt upd1 Nothing) eval - _________________________ -> - -- NOTE: Unexpected error - printLn "Unexpected error" >> - loop (nxt 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 upd0 (Just cs)) eval - None -> - loop (nxt upd0 Nothing) eval - _________________________ -> - -- NOTE: Unexpected error - printLn "Unexpected error" >> - loop (nxt upd0 (Just [])) eval - where - afps = - ( \ (INT.FilePaths fps) -> map INT.AbsoluteFilePath fps - ) - <$> pile ctx - - Batch msg -> - case (null ejs, outs) of - ( True, Just uts) -> - ( eval ctx (MSG.Tmpl aps) >>= \ (upd0, act0) -> - case act0 of - Template p is es fs -> - let - ils = map ( \ (INT.File (_, ls)) -> unlines ls) is - els = map ( \ (INT.File (_, ls)) -> unlines ls) es - in - mapM - ( \ f -> - let - tpl = INT.Template msg ils els [f] - xml = INT.tpl2xmls tpl - in - fork - ( eval upd0 ( MSG.Send xml ) >>= \ (upd1, act1) -> - case act1 of - Message (MSG.Text cs) -> - pure - ( nxt - ( upd1 - { ruck = Just $ pfs - } - ) - ( Just cs - ) - ) - where - pfs = - case (map INT.File . p) cs of - [] -> INT.Files [] - xs -> INT.Files xs - _____________________ -> - pure upd1 - ) - ) - fs - ___________________ -> - pure [] - ) >>= \ js -> - printLn ("Batched tasks unique identifier: " ++ uts) >> - loop ctx { jobs = Just (njs (INT.UUID uts) js) } eval - ( False, _) -> - printLn "Current batch is unsynchronized. See /help for info" >> - loop ctx eval - ( _, Nothing) -> - printLn "Missing unique identifier UTC-timestamp." >> - loop ctx eval - where - - aps = - ( \ (INT.FilePaths fps) -> map INT.AbsoluteFilePath fps - ) - <$> pile ctx - - ojs = jobs ctx - ejs = - case ojs of - Nothing -> [] - Just (INT.Jobs js) -> js - - njs uuid js = - INT.Jobs $ zip (repeat uuid) js - - Status -> - mapM - ( \ (INT.UUID uid, j) -> - tnum j >>= \ num -> - tvar j >>= \ var -> - if not var then - pure (uid, num, "RUNNING") - else - tval j >>= \ val -> - case val of - Nothing -> - terr j >>= \ err -> - pure (uid, num, "FAILURE" ++ " | " ++ (fromMaybe [] err)) - Just __ -> - pure (uid, num, "STOPPED") - ) njs >>= \ logs -> - mapM_ - ( \ (uid, tid, status) -> - printLn $ uid ++ " | " ++ tid ++ " | " ++ status - ) logs >> - loop ctx eval - where - njs = - case jobs ctx of - Nothing -> [] - Just (INT.Jobs js) -> js - - Sync -> - mapM - ( \ (_, j) -> - tvar j >>= \ var -> - if not var then - pure var - else - tval j >>= \ val -> - case val of - Nothing -> pure $ var && False - Just __ -> pure $ var && True - ) njs >>= \ succeeded -> - if all id succeeded then - mapM (wait . snd) njs >>= \ ctxs -> - let - (skipped, merged) = - foldl - ( \ (bs, a) x -> - let - ars = - case ruck a of - Just (INT.Files rs) -> rs - Nothing -> [] - xrs = - case ruck x of - Just (INT.Files rs) -> rs - Nothing -> [] - in - ( bs ++ [null xrs] - , a { ruck = Just $ INT.Files $ ars ++ xrs} - ) - ) - ( [] - , ctx { jobs = Just $ INT.Jobs [] } - ) - ctxs - in - mapM - ( \ ((INT.UUID uid, j), skip) -> - tnum j >>= \ num -> - if skip then - pure (uid, num, "SKIPPED") - else - pure (uid, num, "BLENDED") - ) (zip njs skipped) >>= \ logs -> - mapM_ - ( \ (uid, tid, status) -> - printLn $ uid ++ " | " ++ tid ++ " | " ++ status - ) logs >> - loop merged eval - else - loopHelper ctx eval Status outs - where - njs = - case jobs ctx of - Nothing -> [] - Just (INT.Jobs js) -> js - - Stop -> - mapM - ( \ (INT.UUID uid, j) -> - tvar j >>= \ var -> - if not var then - tkil j >>= \ num -> - pure (uid, num, "STOPPED") - else - tnum j >>= \ num -> - pure (uid, num, "SKIPPED") - ) njs >>= \ logs -> - mapM_ - ( \ (uid, tid, status) -> - printLn $ uid ++ " | " ++ tid ++ " | " ++ status - ) logs >> - loop ctx { jobs = Just $ INT.Jobs [] } eval - where - njs = - case jobs ctx of - Nothing -> [] - Just (INT.Jobs js) -> js - - Message (MSG.Path ns afp) -> - eval ctx (MSG.Path ns afp) >>= \ (upd, act) -> - case act of - File (INT.File (_,ls)) -> - caseFile ns ls - Message (MSG.Text cs) -> - printLn cs >> - loop (nxt upd (Just cs)) eval - None -> - loop (nxt upd Nothing) eval - _________________________ -> - -- NOTE: Unexpected error - printLn "Unexpected error" >> - loop (nxt upd (Just [])) eval - - Message (MSG.List fil) -> - eval ctx (MSG.List fil) >>= \ (upd, act) -> - case act of - Paths (INT.FilePaths fps) -> - casePaths fps - Message (MSG.Text cs) -> - printLn cs >> - loop (nxt upd (Just cs)) eval - None -> - loop (nxt upd Nothing) eval - _________________________ -> - -- NOTE: Unexpected error - printLn "Unexpected error" >> - loop (nxt upd (Just [])) eval - - Message MSG.Repo -> - eval ctx MSG.Repo >>= \ (upd, act) -> - case act of - Message (MSG.Text cs) -> - printLn cs >> - loop (nxt upd (Just cs)) eval - None -> - loop (nxt upd Nothing) eval - _________________________ -> - -- NOTE: Unexpected error - printLn "Unexpected error" >> - loop (nxt upd (Just [])) eval - - Message msg -> - eval ctx msg >>= \ (upd, act) -> - case act of - Message (MSG.Text cs) -> - printLn cs >> - loop (nxt upd (Just cs)) eval - None -> - loop (nxt upd Nothing) eval - _________________________ -> - -- NOTE: Unexpected error - printLn "Unexpected error" >> - loop (nxt upd (Just [])) eval - where - - -- TODO: Refactoring needed - nxt c o = - c - { hist = - h - { chat = - case o of - Nothing -> chat $ hist c - Just r -> (r:) $ chat $ hist c - } - } - where - h = hist c - - caseExit = - printLn "Λ-gent will shutdown" >> - return ctx - - caseDrop = - printLn ("Dropping end-user data load") >> - loop - ( ctx - { load = Nothing - } - ) eval - - -- TODO: Refactoring needed - caseMode c cs = - case mmod of - Just mode' -> - printLn ("Changed to " ++ low ++ "-mode") >> - loop - ( ctx - { mode = mode' - , pile = Just $ INT.FilePaths [] - , ruck = Just $ INT.Files [] - } - ) eval - where - low = map toLower $ show mode' - Nothing -> - printLn ("Invalid mode: " ++ c:cs) >> - loop ctx eval - where - mmod = readMaybe (toUpper c : map toLower cs) :: Maybe INT.Mode - - caseHist 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 ctx eval - - caseFile ns ls = - ( mapM_ printLn . - UTL.combine . - UTL.file ns - ) (unlines ls) >> - loop ctx eval - caseHelp = - printLn help >> - loop ctx eval - - casePaths fps = - eval ctx MSG.Root >>= \ (upd, act) -> - case act 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 upd Nothing) - { pile = Just $ INT.FilePaths fps - } - ) eval - Message (MSG.Text cs) -> - printLn cs >> - loop (nxt upd (Just cs)) eval - None -> - loop (nxt upd Nothing) eval - _________________________ -> - -- NOTE: Unexpected error - printLn "Unexpected error" >> - loop (nxt upd (Just [])) eval - - casePile = - eval ctx MSG.Root >>= \ (upd, act) -> - case act 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 upd Nothing) eval - Message (MSG.Text cs) -> - printLn cs >> - loop (nxt upd (Just cs)) eval - None -> - loop (nxt upd Nothing) eval - _________________________ -> - -- NOTE: Unexpected error - printLn "Unexpected error" >> - loop (nxt upd (Just [])) eval - - caseRuck 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 ctx 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 = - printLn clear >> - loop ctx eval - - caseUnknownCmd cmd = - printLn msg >> - loop ctx eval - where - msg = "Command not recognized: " ++ cmd - - -- NOTE: Clear screen & Move top-left - clear = "\^[[H\^[[2J" -- NOTE: See `infocmp -x` - -print - :: String - -> RIO () -print = - output . show . AEC.faint . AEC.sgr - -printLn - :: String - -> RIO () -printLn x = - print $ x ++ "\n" - -{- -printLn - :: Bool - -> String - -> RIO () -printLn n x = - if not n then - print $ x ++ "\n" - else - pure () --} - -action - :: Context a - -> String - -> Action -action ctx 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 - - '/':'t':'a':'s':'k':' ':mesg -> Batch mesg - '/':'t' :' ':mesg -> Batch mesg - - '/':'j':'o':'b':'s':[ ] -> Status - '/':'j' :[ ] -> Status - - '/':'s':'y':'n':'c':[ ] -> Sync - - '/':'s':'t':'o':'p':[ ] -> Stop - - '/':'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) - - --------------------------------------------------------------------------------- - -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 +{-# OPTIONS_GHC -Wall #-} + +{-# 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 +-- +-- 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 qualified Prelude as PRE + +import Control.Monad ( void ) +import Data.Char ( toLower, toUpper ) +import Data.Foldable ( foldlM ) +import Data.List ( isPrefixOf, nub, sort ) +import Data.Maybe ( fromMaybe ) +import GHC.IO.Encoding ( setLocaleEncoding ) +import Numeric ( showFFloat ) +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 (..) + , Context (..) + , File + , FileLine + , FilePaths + , Files + , Filter + , History (..) + , Load + , Mask + , Mode (..) + , Root + , Template + , UUID + , modes + ) +import qualified Internal.LLM as INT +import Internal.LLM.Action ( Action (..) ) +import qualified Internal.LLM.SystemOne as SOM +import Internal.RIO + ( RIO (..) + , fork + , input + , output + , terr + , timeout + , timestampUTC + , tkil + , tnum + , tval + , tvar + , typedHolesDev + , wait + ) +import qualified Internal.Utils as UTL + +import qualified Agent.Data.ANSI.EscapeCode as AEC +import qualified Agent.LLM.Message as MSG + +import Agent.LLM.Message ( Message ) + +-------------------------------------------------------------------------------- + +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 mode_ 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 cls >> hFlush stdout + putStrLn head >> hFlush stdout + void $ run $ loop ctx proc + Left err -> + putStrLn err >> hFlush stdout + where + -- NOTE: `cls` and `clear` SHOULD be only defined once !!! + cls = "\^[[H\^[[2J" -- NOTE: See `infocmp -x` + ctx = + Context + { quit = INT.Quit False + , mode = mode_ + , load = Nothing + , hist = + History + { chit = + Chit + { prev = [] + , next = [] + } + , chat = [] + } + , list = Nothing + , pile = Just $ INT.FilePaths [] + , ruck = Just $ INT.Files [] + , jobs = Just $ INT.Jobs [] + , flow = INT.Flow False + , wrap = INT.Wrap False + } + +-------------------------------------------------------------------------------- + +-- 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 + join . (:[]) <$> 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 (CTRL + L)" + , ds + , "/m m or /mode m | Change {" ++ ms ++ "}. Ex: /m plan" + , ds + , "/h or /hist | View history (input and output)" + , " /chit | View history (only input) " + , " /chat | View history (only output)" + , ds + , "/d or /drop | Drop end-user data load" + , ds + , "/l f or /list f | List of files, limited by mode, file masks and filter" + , "/p or /pile | Show stored list of files in pile. See /list above" + , "/f i or /file i | Show file with the provided index. See /pile above" + , "/n i or /nums i | Show file (idx) with line numbers. See /file above" + , ds + , "/s m or /send m | Sending /pile to LLM as context to the message" + , ds + , "/r or /ruck o | View files (opt index) from LLM responses. See /send or /fill" + , ds + , "/a d or /atom d | Atomically save /ruck files to a GIT branch (+ description)" + , ds + , " /repo | List /atom created GIT branches, including description" + , " /tail | Show (opt create) TAIL, based on origin/HEAD, as local storage" + , " /diff u | Show GIT branch (uid) differences with TAIL or origin/HEAD" + , " /disp | Dispose /atom failed branches or are behind/older than TAIL" + , " /meld | Auto-merge branches with TAIL, if possible. See /disp above" + , " /push | Create a remote branch, on origin, for TAIL" + , " /pull | Retrieve latest snapshot of origin/HEAD. See /push above" + , " /shed | Remove TAIL, if merged with origin/HEAD. See /pull above" + , ds + , "/t m or /task m | Fork /send m jobs for files. See /pile above" + , "/j or /jobs | Show info for executed jobs. See /task above" + , " /sync | Join contexts, if no errors. See /jobs above" + , " /stop | Kill or abort, current jobs. See /jobs above" + , ds + , " /disc | Discover files with typed-holes and store them in /pile" + , " /hole i | Show file (idx) typed-holes, if any. See /pile above" + , " /fill | Send /pile to LLM, to fill typed-holes with best suggestions" + , ds + , " /test u | Test TAIL or /atom GIT branches (uid) against specification" + , ds + , " /exec | Execute the automated mode. Limited by /mode auto" + , " /halt | Bring automation to a halt. Limited by /mode auto" + , ds + ] + where + ds = replicate 80 '-' + ms = + foldl1 (\ x y -> x ++ "|" ++ y) $ map (map toLower . show) modes + +-------------------------------------------------------------------------------- + +timeoutSecs :: Int +timeoutSecs = 3 + +loop + :: Context a + -> Eval a + -> RIO (Context a) +loop ctx eval = + print prompt >> + ( if Auto == mod && flw then + ( \case + Just "/halt" -> "/halt" + ____________ -> "/exec" + ) + <$> timeout timeoutSecs (read hps hns) + else + read hps hns + ) >>= \ txt -> + printLn mtd [ ] >> + timestampUTC >>= \ outs -> + loopHelper mtd (action ctx txt) outs eval (prv txt ctx) >>= \ ctx_ -> + case ctx_ of + Context { quit = INT.Quit True } -> pure ctx_ + ________________________________ -> loop ctx_ eval + where + mtd = False + + (INT.Flow flw) = flow ctx + mod = mode ctx + + -- TODO: Refactoring needed + his = hist ctx + chi = chit his + hps = prev chi + hns = next chi + + -- TODO: Refactoring needed + prv p c = + c + { hist = + h + { chit = + (chit $ hist c) + { prev = p : hps + } + } + } + where + h = hist c + + -- TODO: Refactoring needed + prompt = + (show . AEC.bold . AEC.sgr) + ("Λ-" ++ (map toLower . show . mode) ctx ++ "> ") + read = input + +loopHelper + :: Bool + -> Action + -> Maybe String + -> Eval a + -> Context a + -> RIO (Context a) +loopHelper mtd act_ outs eval ctx = + case act_ of + -- TODO: Refactoring needed + + -- Nested -- Start + None -> + pure ctx + File _ -> + pure ctx + Files _ -> + pure ctx + Template {} -> + pure ctx + -- Nested -- Stop + + Exit -> caseExit + Help -> caseHelp + Drop -> caseDrop + Hist (chits, chats) -> caseHist chits chats + Mode c cs -> caseMode c cs + Paths (INT.FilePaths fps) -> casePaths fps + Branches (INT.Branches bs) -> caseBranches bs + Pile -> casePile + Ruck midx -> caseRuck midx + Wipe -> caseWipe + UnknownCmd cmd -> caseUnknownCmd cmd + + Discover -> caseDisc + + Hole mfp -> caseHole mfp + + Refine -> + -- TODO: Refeactor cos it works, but it's horrible !!! + case oafps of + Nothing -> + printLn mtd "No files in pile" >> + pure ctx + Just [ ] -> + printLn mtd "No files in pile" >> + pure ctx + Just afps -> + eval ctx MSG.Root >>= \ (upd0, act0) -> + case act0 of + Paths (INT.FilePaths rfps) -> + ( case rfps of + [cwd] -> + eval upd0 MSG.Tail >>= \ (upd1, act1) -> + case act1 of + Branches (INT.Branches [INT.Branch uuid@(INT.UUID tid) _ _]) -> + typedHolesDev (Just uuid) cwd >>= \ case + Right ths_ -> + -- case INT.ghces2ths cwd Nothing ths_ of + case INT.ghces2ths tap Nothing ths_ of + Right ths -> + -- + let + ds = + ( nub . sort ) + $ map + ( \ (INT.Hole (INT.Location p _ _) _ _ _ _ _ _) -> + p + ) + ths + ij = + filter + ( \ (INT.AbsoluteFilePath afp) -> afp `elem` ds + ) + afps + ps = + map + ( \ (INT.AbsoluteFilePath afp) -> afp + ) + afps + -- NOTE: We need to filer files that doesn't + -- have any TH. Once we have done that, we + -- need to filter away all the TH that aren't + -- in /pile files + kl = + filter + ( \ (INT.Hole (INT.Location p _ _) _ _ _ _ _ _) -> + p `elem` ps + ) + ths + in + if null ij then + printLn mtd nmsg >> + pure (nxt upd0 Nothing) + else + eval ctx ((MSG.Fill . Just) ij) >>= \ (upd2, act2) -> + case act2 of + Files (INT.Files fs) -> + acc >>= \ acc_ -> + pure (nxt acc_ Nothing) + where + len = length cwd + lhs = + map + ( \ (INT.Hole (INT.Location lp ll lc) hs hd hbs hcs hfs hrs) -> + let + np = drop len lp + in + INT.Hole (INT.Location np ll lc) hs hd hbs hcs hfs hrs + ) + kl + acc = + -- NOTE: We need to have the files + -- from TAIL branch + foldlM + ( \ u req -> + eval u (MSG.Send [SOM.encode req]) >>= \ (u_, a_) -> + case a_ of + Message (MSG.Text cs) -> + case edec of + Right res -> + printLn mtd "# Fil/refine typed-holes" >> + ( mapM_ + ( \ (q,a) -> + let + ai = PRE.read (SOM.choice a) :: Int + qc = SOM.criteria q !! ai + in + print "* " >> + ( printLn mtd + . SOM.instructions + ) q >> + print " - choice: " >> + ( printLn mtd . SOM.val + ) (snd qc) >> + print " - confidence: " >> + ( printLn mtd + . show . SOM.confidence + ) a + ) + $ zip (map snd qs) (map snd as) + ) >> + print "> Used tokens: " >> + print (show ut) >> + print " and elapsed time (ms): " >> + printLn mtd (show ul) >> + pure + ( nxt + ( u_ { ruck = Just rs } + ) + ( Just cs + ) + ) + where + rs = + case ruck u_ of + Nothing -> + INT.Files + [ SOM.replaceHoles req res + ] + Just (INT.Files fs_) -> + INT.Files + ( fs_ ++ + [ SOM.replaceHoles req res + ] + ) + qs = SOM.questions req + as = SOM.answers res + ut = (SOM.input_tokens . SOM.usage) res + ul = (SOM.latency_ms . SOM.usage) res + Left err -> + printLn mtd err >> + pure (nxt u_ Nothing) + where + edec = SOM.decode cs + None -> + pure (nxt u_ Nothing) + _________________________ -> + -- NOTE: Unexpected error + printLn mtd "Unexpected error" >> + pure (nxt u_ (Just [])) + ) (upd2 { ruck = Nothing } ) + $ map + ( \ f@(INT.File (fp, _)) -> + let + hs = + filter + ( \ (INT.Hole (INT.Location p _ _) _ _ _ _ _ _) -> + fp `isPrefixOf` p + ) + lhs + in + SOM.request f hs + ) + fs + Message (MSG.Text cs) -> + printLn mtd cs >> + pure (nxt upd2 (Just cs)) + None -> + pure (nxt upd2 Nothing) + _________________________ -> + -- NOTE: Unexpected error + printLn mtd "Unexpected error" >> + pure (nxt upd2 (Just [])) + where + nmsg = + "No files in pile with typed-holes" + Left es -> + mapM_ (printLn mtd . show) es >> + pure (nxt upd0 Nothing) + where + tmp = cwd ++ "tmp" + lid = (++ "_") $ map toLower tid + tap = tmp ++ "/" ++ lid ++ "/" + Left es -> + mapM_ (printLn mtd) es >> + pure (nxt upd0 Nothing) + Message (MSG.Text cs) -> + printLn mtd cs >> + pure (nxt upd1 (Just cs)) + None -> + pure (nxt upd1 Nothing) + _________________________ -> + -- NOTE: Unexpected error + printLn mtd "Unexpected error" >> + pure (nxt upd1 (Just [])) + _____ -> + printLn mtd "Missing root path" >> + pure (nxt upd0 Nothing) + ) + Message (MSG.Text cs) -> + printLn mtd cs >> + pure (nxt upd0 (Just cs)) + None -> + pure (nxt upd0 Nothing) + _________________________ -> + -- NOTE: Unexpected error + printLn mtd "Unexpected error" >> + pure (nxt upd0 (Just [])) + where + oafps = + ( \ (INT.FilePaths fps) -> map INT.AbsoluteFilePath fps + ) + <$> pile ctx + + Branch msg fs -> + eval ctx (MSG.Atom msg fs) >>= \ (upd, act) -> + case act of + Message (MSG.Text cs) -> + printLn mtd cs >> + pure (nxt upd (Just cs)) + None -> + pure (nxt upd Nothing) + _________________________ -> + -- NOTE: Unexpected error + printLn mtd "Unexpected error" >> + pure (nxt upd (Just [])) + + Prompt msg -> + case oafps of + Nothing -> + printLn mtd "No files in pile" >> + pure ctx + Just [ ] -> + printLn mtd "No files in pile" >> + pure ctx + Just aps -> + -- TODO: Refactor + eval ctx (MSG.Tmpl $ Just aps) >>= \ (upd0, act0) -> + case act0 of + Template p is es fs -> + eval upd0 (MSG.Send xml) >>= \ (upd1, act1) -> + case act1 of + Message (MSG.Text cs) -> + case epfs of + Right pfs -> + printLn mtd cs >> + pure + ( nxt + ( upd1 { ruck = Just pfs } + ) + ( Just cs + ) + ) + Left es_ -> + ( mapM_ ( \(i, x) -> printLn mtd $ i ++ ": " ++ x) + $ UTL.linesOptNums [] [] True 0 es_ + ) >> + pure (nxt upd1 (Just cs)) + where + epfs = + case p cs of + Right fs_ -> + Right + $ INT.Files + $ map + ( \ (fp, ls) -> + INT.File (fp, trimLines ls) + ) + fs_ + Left es_ -> + Left es_ + None -> + pure (nxt upd1 Nothing) + _________________________ -> + -- NOTE: Unexpected error + printLn mtd "Unexpected error" >> + pure (nxt upd1 (Just [])) + where + ils = concatMap ( \ (INT.File (_, ls)) -> 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 mtd cs >> + pure (nxt upd0 (Just cs)) + None -> + pure (nxt upd0 Nothing) + _________________________ -> + -- NOTE: Unexpected error + printLn mtd "Unexpected error" >> + pure (nxt upd0 (Just [])) + where + oafps = + ( \ (INT.FilePaths fps) -> map INT.AbsoluteFilePath fps + ) + <$> pile ctx + + Batch msg -> + -- TODO: Refactor + case (null eps, null ejs, outs) of + ( False, True, Just uts) -> + ( eval ctx (MSG.Tmpl aps) >>= \ (upd0, act0) -> + case act0 of + Template p is es fs -> + let + ils = concatMap ( \ (INT.File (_, ls)) -> ls) is + els = map ( \ (INT.File (_, ls)) -> unlines ls) es + in + mapM + ( \ f -> + let + tpl = INT.Template msg ils els [f] + xml = INT.tpl2xmls tpl ([], []) + in + fork + -- NOTE: Chats MUST be empty for each job as otherwise + -- we end up adding the previous history n times + ( eval + ( ( upd0 + { hist = + (hist upd0) { chat = [] } + } + ) + ) ( MSG.Send xml ) >>= \ (upd1, act1) -> + case act1 of + Message (MSG.Text cs) -> + case epfs of + Right pfs -> + pure + ( nxt + ( upd1 + { ruck = Just pfs + } + ) + ( Just cs + ) + ) + Left ___ -> + pure + ( nxt upd1 (Just cs) + ) + where + epfs = + case p cs of + Right fs_ -> + Right + $ INT.Files + $ map + ( \ (fp, ls) -> + INT.File (fp, trimLines ls) + ) + fs_ + Left es_ -> + Left es_ + _____________________ -> + pure upd1 + ) + ) + fs + Message (MSG.Text cs) -> + sequence + [ fork + ( pure + ( upd0 + { hist = + (hist upd0) { chat = [ cs ] } + } + ) + ) + ] + None -> + sequence + [ fork + ( pure + ( upd0 + { hist = + (hist upd0) { chat = [] } + } + ) + ) + ] + _____________________ -> + -- NOTE: Unexpected error + sequence + [ fork + ( pure + ( upd0 + { hist = + (hist upd0) { chat = [ "Unexpected error" ] } + } + ) + ) + ] + ) >>= \ js -> + printLn mtd ("Batched tasks unique identifier: " ++ uts) >> + pure ctx { jobs = Just (njs (INT.UUID uts) js) } + ( True, _, _) -> + printLn mtd "There are no files in the pile. See /help for info" >> + pure ctx + ( _, False, _) -> + printLn mtd "Current batch is unsynchronized. See /help for info" >> + pure ctx + ( _, _, Nothing) -> + printLn mtd "Missing unique identifier UTC-timestamp." >> + pure ctx + where + aps = + ( \ (INT.FilePaths fps) -> map INT.AbsoluteFilePath fps + ) + <$> pile ctx + eps = fromMaybe [] aps + ojs = jobs ctx + ejs = + case ojs of + Nothing -> [] + Just (INT.Jobs js) -> js + njs uuid js = + INT.Jobs $ zip (repeat uuid) js + + Status -> + mapM + ( \ (INT.UUID uid, j) -> + tnum j >>= \ num -> + tvar j >>= \ var -> + if not var then + pure (uid, num, show INT.Running) + else + tval j >>= \ val -> + case val of + Nothing -> + terr j >>= \ err -> + pure (uid, num, show INT.Failure_ ++ " | " ++ fromMaybe [] err) + Just __ -> + pure (uid, num, show INT.Stopped) + ) njs >>= \ logs -> + mapM_ + ( \ (uid, tid, status) -> + printLn mtd $ uid ++ " | " ++ tid ++ " | " ++ status + ) logs >> + pure ctx + where + njs = + case jobs ctx of + Nothing -> [] + Just (INT.Jobs js) -> js + + Sync -> + mapM + ( \ (_, j) -> + tvar j >>= \ var -> + if not var then + pure var + else + tval j >>= \ case + Nothing -> pure $ var && False + Just __ -> pure $ var && True + ) njs >>= \ succeeded -> + if and succeeded then + mapM (wait . snd) njs >>= \ ctxs -> + let + (skipped, merged) = + foldl + ( \ (bs, a) x -> + let + ars = + case ruck a of + Just (INT.Files rs) -> rs + Nothing -> [] + xrs = + case ruck x of + Just (INT.Files rs) -> rs + Nothing -> [] + ah = hist a + acs = chat ah + xcs = chat $ hist x + in + ( bs ++ [null xrs] + , a + { ruck = Just $ INT.Files $ ars ++ xrs + , hist = ah { chat = acs ++ xcs } + } + ) + ) + ( [] + , ctx { jobs = Just $ INT.Jobs [] } + ) + ctxs + in + mapM + ( \ ((INT.UUID uid, j), skip) -> + tnum j >>= \ num -> + if skip then + pure (uid, num, show INT.Skipped) + else + pure (uid, num, show INT.Blended) + ) (zip njs skipped) >>= \ logs -> + mapM_ + ( \ (uid, tid, status) -> + printLn mtd $ uid ++ " | " ++ tid ++ " | " ++ status + ) logs >> + pure merged + else + loopHelper mtd Status outs eval ctx + where + njs = + case jobs ctx of + Nothing -> [] + Just (INT.Jobs js) -> js + + Stop -> + mapM + ( \ (INT.UUID uid, j) -> + tvar j >>= \ var -> + if not var then + tkil j >>= \ num -> + pure (uid, num, show INT.Stopped) + else + tnum j >>= \ num -> + pure (uid, num, show INT.Skipped) + ) njs >>= \ logs -> + mapM_ + ( \ (uid, tid, status) -> + printLn mtd $ uid ++ " | " ++ tid ++ " | " ++ status + ) logs >> + pure ctx { jobs = Just $ INT.Jobs [] } + where + njs = + case jobs ctx of + Nothing -> [] + Just (INT.Jobs js) -> js + + Tests _ -> + -- HERE: How do we use this??? + printLn mtd "DEBUG:" >> + pure ctx + + Exec -> + if Auto == mod then + if w then + printLn mtd "Automation has successfully halted" >> + pure (ctx { flow = INT.Flow False, wrap = INT.Wrap False }) + else + let + flw = ctx { flow = INT.Flow True } + in + printLn mtd "> Discover and fill/refine Typed-Holes" >> + loopHelper mtd (Message MSG.Tail) outs eval flw >>= + loopHelper mtd Discover outs eval >>= \ dis -> + loopHelper mtd Refine outs eval dis >>= \ ref -> + let + (INT.FilePaths fps) = fromMaybe (INT.FilePaths []) (pile dis) + rfs = fromMaybe (INT.Files []) (ruck ref) + msg = "Automated atomic branch creation" + in + if null fps then + -- NOTE: If no files with TH, we stop automation + loopHelper mtd Halt outs eval ref + else + printLn mtd "> Create atomic branches, test, meld and clean-up" >> + loopHelper mtd (Branch msg rfs) outs eval ref >>= \ bch -> + eval bch MSG.Repo >>= \ (rep, act) -> + let + us = + case act of + Branches (INT.Branches bs) -> + map + ( \ (INT.Branch uuid _ _) -> uuid + ) + bs + __________________________ -> [] + in + printLn mtd "> Differences with TAIL" >> + foldlM + ( \ acc uuid -> + loopHelper mtd (Message (MSG.Diff uuid)) outs eval acc + ) rep + us + >>= \ dif -> + printLn mtd "> Evaluating against the specification " >> + foldlM + ( \ acc uuid -> + loopHelper mtd (Message (MSG.Test uuid)) outs eval acc + ) dif + us + >>= \ tst -> + printLn mtd "> Melding with TAIL" >> + loopHelper mtd (Message MSG.Meld) outs eval tst >>= + loopHelper mtd (Message MSG.Disp) outs eval >>= \ lst -> + printLn mtd tom >> + pure lst + else + printLn mtd "/exec is only available in Auto-mode" >> + pure ctx + where + (INT.Wrap w) = wrap ctx + mod = mode ctx + tom = + "> NOTE: Type /halt to stop automated execution (timeout is: " ++ + show timeoutSecs ++ + " seconds)" + + Halt -> + if Auto == mod then + ( case (f, w) of + (False, ____) -> printLn mtd "No automation is running" + (True, True) -> printLn mtd "Wrap it up has already been requested" + _____________ -> printLn mtd "Request to wrap it up" + ) >> + pure (ctx { wrap = INT.Wrap True }) + else + printLn mtd "/halt is only available in Auto-mode" >> + pure ctx + where + (INT.Flow f) = flow ctx + (INT.Wrap w) = wrap ctx + mod = mode ctx + + Message (MSG.Path ns afp) -> + eval ctx (MSG.Path ns afp) >>= \ (upd, act) -> + case act of + File (INT.File (_,ls)) -> + caseFile ns ls + Message (MSG.Text cs) -> + printLn mtd cs >> + pure (nxt upd (Just cs)) + None -> + pure (nxt upd Nothing) + _________________________ -> + -- NOTE: Unexpected error + printLn mtd "Unexpected error" >> + pure (nxt upd (Just [])) + + Message (MSG.List fil) -> + eval ctx (MSG.List fil) >>= \ (upd, act) -> + case act of + Paths (INT.FilePaths fps) -> + casePaths fps + Message (MSG.Text cs) -> + printLn mtd cs >> + pure (nxt upd (Just cs)) + None -> + pure (nxt upd Nothing) + _________________________ -> + -- NOTE: Unexpected error + printLn mtd "Unexpected error" >> + pure (nxt upd (Just [])) + + Message MSG.Repo -> + eval ctx MSG.Repo >>= \ (upd, act) -> + case act of + Branches (INT.Branches bs) -> + caseBranches bs + Message (MSG.Text cs) -> + printLn mtd cs >> + pure (nxt upd (Just cs)) + None -> + pure (nxt upd Nothing) + _________________________ -> + -- NOTE: Unexpected error + printLn mtd "Unexpected error" >> + pure (nxt upd (Just [])) + + Message MSG.Tail -> + eval ctx MSG.Tail >>= \ (upd, act) -> + case act of + Branches (INT.Branches bs) -> + caseBranches bs + Message (MSG.Text cs) -> + printLn mtd cs >> + pure (nxt upd (Just cs)) + None -> + pure (nxt upd Nothing) + _________________________ -> + -- NOTE: Unexpected error + printLn mtd "Unexpected error" >> + pure (nxt upd (Just [])) + + Message MSG.Disp -> + eval ctx MSG.Disp >>= \ (upd, act) -> + case act of + Message (MSG.Text cs) -> + printLn mtd cs >> + pure (nxt upd (Just cs)) + None -> + pure (nxt upd Nothing) + _________________________ -> + -- NOTE: Unexpected error + printLn mtd "Unexpected error" >> + pure (nxt upd (Just [])) + + Message MSG.Meld -> + eval ctx MSG.Meld >>= \ (upd, act) -> + case act of + Message (MSG.Text cs) -> + printLn mtd cs >> + pure (nxt upd (Just cs)) + None -> + pure (nxt upd Nothing) + _________________________ -> + -- NOTE: Unexpected error + printLn mtd "Unexpected error" >> + pure (nxt upd (Just [])) + + Message MSG.Push -> + eval ctx MSG.Push >>= \ (upd, act) -> + case act of + Message (MSG.Text cs) -> + printLn mtd cs >> + pure (nxt upd (Just cs)) + None -> + pure (nxt upd Nothing) + _________________________ -> + -- NOTE: Unexpected error + printLn mtd "Unexpected error" >> + pure (nxt upd (Just [])) + + Message MSG.Pull -> + eval ctx MSG.Pull >>= \ (upd, act) -> + case act of + Message (MSG.Text cs) -> + printLn mtd cs >> + pure (nxt upd (Just cs)) + None -> + pure (nxt upd Nothing) + _________________________ -> + -- NOTE: Unexpected error + printLn mtd "Unexpected error" >> + pure (nxt upd (Just [])) + + Message MSG.Shed -> + eval ctx MSG.Shed >>= \ (upd, act) -> + case act of + Message (MSG.Text cs) -> + printLn mtd cs >> + pure (nxt upd (Just cs)) + None -> + pure (nxt upd Nothing) + _________________________ -> + -- NOTE: Unexpected error + printLn mtd "Unexpected error" >> + pure (nxt upd (Just [])) + + Message (MSG.Test uuid) -> + eval ctx (MSG.Test uuid) >>= \ (upd0, act0) -> + case act0 of + Tests (INT.TestCases tcs) -> + ( if null tcs then + let + msg = "[FAIL] There are no test cases" + lab = INT.Label msg + in + eval ctx (MSG.Desc uuid lab) >>= \ (upd1, act1) -> + case act1 of + Message (MSG.Text cs) -> + printLn mtd ("# " ++ msg) >> + pure (nxt upd1 (Just cs)) + None -> + pure (nxt upd1 Nothing) + _________________________ -> + -- NOTE: Unexpected error + printLn mtd "Unexpected error DEBUG:" >> + pure (nxt upd1 (Just [])) + else + let + msg = "[FAIL] Not all test cases are meldable" + lab = INT.Label msg + in + ( if eam then + printLn mtd "# Test cases" + else + printLn mtd ("# " ++ msg) + ) >> + printLn mtd ("* All succeeded .....: " ++ show eas) >> + printLn mtd ("* All meldable ......: " ++ show eam) >> + mapM_ + ( \ ( INT.TestCase l + ( INT.TestResult + { INT.status = s + , INT.output = o + -- + , INT.numTests = m + , INT.usedSize = n + , INT.reason = r + , INT.theException = e + } + ) + ) -> + printLn mtd ("## " ++ l) >> + printLn mtd ("* Status ............: " ++ show s) >> + if INT.Failure == s then + let + m_ = if null e then r else e + in + printLn mtd ("* Tests size ........: " ++ show m) >> + printLn mtd ("* Tests performed ...: " ++ show n) >> + printLn mtd ("* Result ............:\n" ++ o) >> + printLn mtd ("* Reason ............:\n" ++ m_) + else + printLn mtd ("* Result ............:\n" ++ o) + ) + tcs + >> + ( if not eam then + eval ctx (MSG.Desc uuid lab) >>= \ (upd1, act1) -> + case act1 of + Message (MSG.Text cs) -> + pure (nxt upd1 (Just cs)) + None -> + pure (nxt upd1 Nothing) + _________________________ -> + -- NOTE: Unexpected error + printLn mtd "Unexpected error DEBUG:" >> + pure (nxt upd1 (Just [])) + else + pure (nxt upd0 Nothing) + ) + ) + where + eas = not (null tcs) && all INT.isSuccess tcs + eam = not (null tcs) && all INT.isMeldable tcs + Message (MSG.Text cs) -> + printLn mtd cs >> + pure (nxt upd0 (Just cs)) + None -> + pure (nxt upd0 Nothing) + _________________________ -> + -- NOTE: Unexpected error + printLn mtd "Unexpected error DEBUG:" >> + pure (nxt upd0 (Just [])) + + Message msg -> + eval ctx msg >>= \ (upd, act) -> + case act of + Message (MSG.Text cs) -> + printLn mtd cs >> + pure (nxt upd (Just cs)) + None -> + pure (nxt upd Nothing) + _________________________ -> + -- NOTE: Unexpected error + printLn mtd "Unexpected error" >> + pure (nxt upd (Just [])) + + where + -- TODO: Refactoring needed + nxt c o = + c + { hist = + h + { chat = + case o of + Nothing -> chat h + Just r -> (r:) $ chat h + } + } + where + h = hist c + + caseExit = + printLn mtd "Λ-gent will shutdown" >> + pure ctx_ + where + ctx_ = ctx { quit = INT.Quit True } + + caseDrop = + printLn mtd "Dropping end-user data load" >> + pure + ( ctx + { load = Nothing + } + ) + + -- TODO: Refactoring needed + caseMode c cs = + case mmod of + Just mode_ -> + printLn mtd ("Changed to " ++ low ++ "-mode") >> + pure + ( ctx + { mode = mode_ + , pile = Just $ INT.FilePaths [] + , ruck = Just $ INT.Files [] + } + ) + where + low = map toLower $ show mode_ + Nothing -> + printLn mtd ("Invalid mode: " ++ c:cs) >> + pure ctx + where + mmod = readMaybe (toUpper c : map toLower cs) :: Maybe INT.Mode + + caseHist chits chats = + ( if chits then + printLn mtd "* Chits:" >> + ( mapM_ (printLn mtd) . UTL.combine False . UTL.chits True . prev . chit . hist + ) ctx + else + pure () + ) >> + ( if chats then + printLn mtd "* Chats:" >> + ( mapM_ (printLn mtd) . UTL.combine False . UTL.chats True . chat . hist + ) ctx + else + pure () + ) >> + pure ctx + + caseFile ns ls = + ( mapM_ (printLn mtd) . + UTL.combine False . + UTL.file ns + ) (unlines ls) >> + pure ctx + + caseHelp = + printLn mtd help >> + pure ctx + + casePaths fps = + eval ctx MSG.Root >>= \ (upd, act) -> + case act of + Paths (INT.FilePaths rfps) -> + ( case rfps of + [cwd] -> + mapM_ (printLn mtd) . + UTL.combine False . + UTL.files [] True . + -- NOTE: Show relative paths + map (drop (length cwd)) $ + fps + _____ -> + printLn mtd "Missing root path" + ) >> + pure + ( (nxt upd Nothing) + { pile = Just $ INT.FilePaths fps + } + ) + Message (MSG.Text cs) -> + printLn mtd cs >> + pure (nxt upd (Just cs)) + None -> + pure (nxt upd Nothing) + _________________________ -> + -- NOTE: Unexpected error + printLn mtd "Unexpected error" >> + pure (nxt upd (Just [])) + + caseBranches bs = + if null bs then + printLn mtd "There are no local branches" >> + pure (nxt ctx Nothing) + else + mapM_ (printLn mtd) ls >> + pure (nxt ctx Nothing) + where + ls = + UTL.combine False . + UTL.files [] False . + map + ( \ (INT.Branch (INT.UUID uid) emof des) -> + let + mod = + case emof of + Left _ -> "[FAIL]" + Right m -> "[" ++ map toUpper (show m) ++ "]" + in + uid ++ ": " ++ mod ++ " " ++ des + ) $ + bs + + casePile = + eval ctx MSG.Root >>= \ (upd, act) -> + case act of + Paths (INT.FilePaths fps) -> + ( case fps of + [cwd] -> + mapM_ (printLn mtd) . + UTL.combine False . + UTL.files [] True . + -- NOTE: Show relative paths + map (drop (length cwd)) . + concatMap INT.filePaths . + pile $ + upd + _____ -> + printLn mtd "Missing root path" + ) >> + pure (nxt upd Nothing) + Message (MSG.Text cs) -> + printLn mtd cs >> + pure (nxt upd (Just cs)) + None -> + pure (nxt upd Nothing) + _________________________ -> + -- NOTE: Unexpected error + printLn mtd "Unexpected error" >> + pure (nxt upd (Just [])) + + caseRuck midx = + ( case idx of + Right i -> + if 0 <= i && i < len then + ( mapM_ (printLn mtd) . + UTL.combine False . + UTL.file True . + concatMap f . + ruck + ) ctx + else + let + m = "Index (" ++ show i ++ ") is out of bounds." + in + printLn mtd m + where + f (INT.Files fs) = + case fs !! i of + INT.File (_,ls) -> unlines ls + Left [] -> + -- NOTE: If no optional index provided, show only paths + ( mapM_ (printLn mtd) . + UTL.combine False . + UTL.files [] True . + concatMap fps . + ruck + ) ctx + Left es -> + (printLn mtd . unlines) es + ) >> + pure ctx + where + idx = + case midx of + [ ] -> + Left [] + ' ':cs -> + maybe + ( Left + [ "Invalid index. Type /help for more info" + ] + ) + Right + ( readMaybe cs :: Maybe Int + ) + ______ -> + Left + [ "Invalid use of /r or /ruck. Use space between cmd and index" + ] + len = + case ruck ctx of + Just (INT.Files fs) -> length fs + Nothing -> 0 + fps (INT.Files fs) = + map ( \ (INT.File (p,_)) -> p) fs + + caseDisc = + + -- TODO: Refactor + eval ctx MSG.Root >>= \ (upd0, act0) -> + case act0 of + Paths (INT.FilePaths rfps) -> + ( case rfps of + [cwd] -> + eval upd0 MSG.Tail >>= \ (upd1, act1) -> + case act1 of + Branches (INT.Branches [INT.Branch uuid@(INT.UUID tid) _ _]) -> + typedHolesDev (Just uuid) cwd >>= \ eths -> + case eths of + Right ths_ -> + -- case INT.ghces2ths cwd Nothing ths_ of + case INT.ghces2ths tap Nothing ths_ of + Right ths -> + ( mapM_ + ( \ ( i + , INT.Hole (INT.Location p l c) (INT.Signature hn s) d _ _ _ _ + ) -> + let + rp = drop (length cwd) p + in + ( printLn mtd + $ show i ++ ": " ++ + rp ++ ":" ++ + show l ++ ":" ++ + show c + ) >> + (printLn mtd " # Hole") >> + (printLn mtd $ " (" ++ hn ++ " :: " ++ s ++ ")") >> + (printLn mtd " # Description") >> + (mapM_ (printLn mtd . (" - " ++)) d) + ) + $ zip [0 :: Int ..] ths + ) >> + pure + ( (nxt upd0 Nothing) + { pile = + Just + $ INT.FilePaths + $ ( nub . sort ) + $ map + ( \ (INT.Hole (INT.Location p _ _) _ _ _ _ _ _) -> + p + ) + ths + } + ) + Left es -> + mapM_ (printLn mtd . show) es >> + pure (nxt upd1 Nothing) + where + tmp = cwd ++ "tmp" + lid = (++ "_") $ map toLower tid + tap = tmp ++ "/" ++ lid ++ "/" + Left es -> + mapM_ (printLn mtd) es >> + pure (nxt upd1 Nothing) + Message (MSG.Text cs) -> + printLn mtd cs >> + pure (nxt upd1 (Just cs)) + None -> + pure (nxt upd1 Nothing) + _________________________ -> + -- NOTE: Unexpected error + printLn mtd "Unexpected error" >> + pure (nxt upd1 (Just [])) + _____ -> + printLn mtd "Missing root path" >> + pure (nxt upd0 Nothing) + ) + Message (MSG.Text cs) -> + printLn mtd cs >> + pure (nxt upd0 (Just cs)) + None -> + pure (nxt upd0 Nothing) + _________________________ -> + -- NOTE: Unexpected error + printLn mtd "Unexpected error" >> + pure (nxt upd0 (Just [])) + + caseHole mfp = + + -- TODO: Refact0or + case mfp of + Just (INT.AbsoluteFilePath afp) -> + eval ctx MSG.Root >>= \ (upd0, act0) -> + case act0 of + Paths (INT.FilePaths rfps) -> + ( case rfps of + [cwd] -> + eval upd0 MSG.Tail >>= \ (upd1, act1) -> + case act1 of + Branches (INT.Branches [INT.Branch uuid@(INT.UUID tid) _ _]) -> + typedHolesDev (Just uuid) cwd >>= \ case + Right ths_ -> + -- case INT.ghces2ths cwd Nothing ths_ of + case INT.ghces2ths tap Nothing ths_ of + Right ths -> + ( mapM_ + ( \ ( i + , INT.Hole (INT.Location p l c) (INT.Signature hn s) d bs cs fs rs_ + ) -> + let + rp = drop (length cwd) p + dc n = showFFloat (Just 10) n "" + in + ( printLn mtd + $ show i ++ ": " ++ + rp ++ ":" ++ + show l ++ ":" ++ show c + ) >> + (printLn mtd " # Hole") >> + ( printLn mtd + $ " (" ++ hn ++ " :: " ++ s ++ ")" + ) >> + (printLn mtd " # Description") >> + ( mapM_ (printLn mtd . (" - " ++)) d + ) >> + (printLn mtd " # Bindings") >> + ( mapM_ + ( \(n,s_) -> + printLn mtd + $ " - " ++ n ++ " :: " ++ s_ + ) + bs + ) >> + (printLn mtd " # Constraints") >> + ( mapM_ + ( \(n,p_) -> + printLn mtd + $ " - " ++ n ++ " " ++ p_ + ) + cs + ) >> + (printLn mtd " # Fits") >> + (mapM_ + ( \(n,s_,l_) -> + printLn mtd + $ " - " ++ n ++ + " :: " ++ s_ ++ + " (likelihood: " ++ dc l_ ++ ")" + ) fs + ) >> + (printLn mtd " # Refinements") >> + ( mapM_ + ( \(n,c_,s_) -> + printLn mtd + $ " - " ++ n ++ c_ ++ " where " ++ s_ + ) + rs_ + ) + ) + $ zip [0 :: Int ..] + $ filter + ( \ (INT.Hole (INT.Location p _ _) _ _ _ _ _ _) -> + p == afp + ) + ths + ) >> + pure (nxt upd1 Nothing) + Left es -> + mapM_ (printLn mtd . show) es >> + pure (nxt upd1 Nothing) + where + tmp = cwd ++ "tmp" + lid = (++ "_") $ map toLower tid + tap = tmp ++ "/" ++ lid ++ "/" + Left es -> + mapM_ (printLn mtd) es >> + pure (nxt upd1 Nothing) + Message (MSG.Text cs) -> + printLn mtd cs >> + pure (nxt upd1 (Just cs)) + None -> + pure (nxt upd1 Nothing) + _________________________ -> + -- NOTE: Unexpected error + printLn mtd "Unexpected error" >> + pure (nxt upd1 (Just [])) + + _____ -> + printLn mtd "Missing root path" >> + pure (nxt upd0 Nothing) + ) + Message (MSG.Text cs) -> + printLn mtd cs >> + pure (nxt upd0 (Just cs)) + None -> + pure (nxt upd0 Nothing) + _________________________ -> + -- NOTE: Unexpected error + printLn mtd "Unexpected error" >> + pure (nxt upd0 (Just [])) + + Nothing -> + printLn mtd "Invalid index, see /pile. Type /help for more info" >> + pure (nxt ctx Nothing) + + caseWipe = + printLn mtd clear >> + pure ctx + + caseUnknownCmd cmd = + printLn mtd msg >> + pure ctx + where + msg = "Command not recognized: " ++ show ("/" ++ cmd) + + -- NOTE: Clear screen & Move top-left + clear = "\^[[H\^[[2J" -- NOTE: See `infocmp -x` + +print + :: String + -> RIO () +print = + output . show . AEC.faint . AEC.sgr + +printLn + :: Bool + -> String + -> RIO () +printLn mtd x = + if mtd then + pure () + else + print $ x ++ "\n" + +action + :: Context a + -> String + -> Action +action ctx 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 + + '/':'t':'a':'s':'k':' ':mesg -> Batch mesg + '/':'t' :' ':mesg -> Batch mesg + + ['/','j','o','b','s'] -> Status + ['/','j' ] -> Status + + ['/','s','y','n','c'] -> Sync + + ['/','s','t','o','p'] -> Stop + + + ['/','d','i','s','c'] -> Discover + + '/':'h':'o':'l':'e' :midx -> + -- TODO: DRY + case oidx of + Nothing -> + Hole Nothing + Just idx -> + if 0 <= idx && idx < length pfs then + Hole $ Just $ INT.AbsoluteFilePath $ pfs !! idx + else + Hole Nothing + where + pfs = concatMap INT.filePaths $ pile ctx + where + oidx = + case midx of + [] -> Nothing + cs -> readMaybe cs :: Maybe Int + + ['/','f','i','l','l'] -> Refine + + '/':'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 + ['/','t','a','i','l'] -> Message MSG.Tail + '/':'d':'i':'f':'f' :muid -> + -- TODO: Fix, doesn't seem to work + case ouid of + Nothing -> + Message (MSG.Text "No valid uniqued identifier was provided") + Just u -> + Message (MSG.Diff (INT.UUID u)) + where + ouid = + case muid of + [ ] -> Nothing + ' ':cs -> Just cs + ______ -> Nothing + ['/','d','i','s','p'] -> Message MSG.Disp + ['/','m','e','l','d'] -> Message MSG.Meld + ['/','p','u','s','h'] -> Message MSG.Push + ['/','p','u','l','l'] -> Message MSG.Pull + ['/','s','h','e','d'] -> Message MSG.Shed + + '/':'t':'e':'s':'t' :muid -> + case ouid of + Nothing -> + Message (MSG.Text "No valid uniqued identifier was provided") + Just u -> + Message (MSG.Test (INT.UUID u)) + where + ouid = + case muid of + [ ] -> Nothing + ' ':cs -> Just cs + ______ -> Nothing + + ['/','e','x','e','c'] -> Exec + ['/','h','a','l','t'] -> Halt + + '/':'r':'u':'c':'k' :midx -> Ruck midx + ['/','r'] -> Ruck [ ] + + "/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) + +-------------------------------------------------------------------------------- + +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 = concat $ 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 + +-------------------------------------------------------------------------------- + +trimLines + :: [String] + -> [String] +trimLines [ ] = [ ] +trimLines ls@(x:xs) = if null x then trimLines xs else aux (reverse ls) + where + aux [ ] = [ ] + aux rls@(y:ys) = if null y then aux ys else reverse rls diff --git a/src/Agent/LLM/Action.hs b/src/Agent/LLM/Action.hs --- a/src/Agent/LLM/Action.hs +++ b/src/Agent/LLM/Action.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -Wall -Werror #-} +{-# OPTIONS_GHC -Wall #-} {-# LANGUAGE NoGeneralizedNewtypeDeriving #-} {-# LANGUAGE Safe #-} @@ -22,16 +22,27 @@ , none , exit , file + , files , paths + , branch + , branches , root , template + , tests , text ) where -------------------------------------------------------------------------------- -import Internal.LLM ( File, FilePaths, Root ) +import Internal.LLM + ( Branch + , Branches + , File + , FilePaths + , Root + , TestCases + ) import qualified Internal.LLM as INT import Internal.LLM.Action ( Action, TextToFile ) import qualified Internal.LLM.Action as ACT @@ -52,10 +63,22 @@ file = ACT.File +files :: [File] -> Action +files = + ACT.Files . INT.Files + paths :: FilePaths -> Action paths = ACT.Paths +branch :: Branch -> Action +branch = + ACT.Branches . INT.Branches . (:[]) + +branches :: Branches -> Action +branches = + ACT.Branches + root :: Root -> Action root (INT.Root afp) = ACT.Paths $ INT.FilePaths [afp] @@ -68,6 +91,10 @@ -> Action template = ACT.Template + +tests :: TestCases -> Action +tests = + ACT.Tests text :: String -> Action text = diff --git a/src/Agent/LLM/Message.hs b/src/Agent/LLM/Message.hs --- a/src/Agent/LLM/Message.hs +++ b/src/Agent/LLM/Message.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -Wall -Werror #-} +{-# OPTIONS_GHC -Wall #-} {-# LANGUAGE NoGeneralizedNewtypeDeriving #-} {-# LANGUAGE Safe #-} @@ -23,7 +23,7 @@ -------------------------------------------------------------------------------- -import Internal.LLM ( AbsoluteFilePath, Files, Filter ) +import Internal.LLM ( AbsoluteFilePath, Files, Filter, Label, UUID ) -------------------------------------------------------------------------------- @@ -36,6 +36,16 @@ | Send ![String] | Text !String | Tmpl !(Maybe [AbsoluteFilePath]) + | Fill !(Maybe [AbsoluteFilePath]) + | Tail + | Desc !UUID !Label + | Diff !UUID + | Disp + | Meld + | Pull + | Push + | Shed + | Test !UUID instance Show Message where show (Atom _ _) = "Atom" @@ -46,3 +56,13 @@ show (Send _) = "Send" show (Text _) = "Text" show (Tmpl _) = "Tmpl" + show (Fill _) = "Fill" + show Tail = "Tail" + show (Desc _ _) = "Desc" + show (Diff _) = "Diff" + show Disp = "Disp" + show Meld = "Meld" + show Pull = "Pull" + show Push = "Push" + show Shed = "Shed" + show (Test _) = "Test" diff --git a/src/Internal/LLM.hs b/src/Internal/LLM.hs --- a/src/Internal/LLM.hs +++ b/src/Internal/LLM.hs @@ -1,199 +1,1184 @@ -{-# 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 (..) - , Jobs (..) - , AbsoluteFilePath (..) - , Template (..) - , modes - , tpl2xmls - ) -where - --------------------------------------------------------------------------------- - -import Agent.Control.Concurrent ( Task ) - --------------------------------------------------------------------------------- - -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 [] - --------------------------------------------------------------------------------- - -newtype Jobs a = Jobs [(UUID, Task a)] - --------------------------------------------------------------------------------- - -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 ++ "" ++ - "" +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE NoGeneralizedNewtypeDeriving #-} +{-# LANGUAGE Safe #-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RankNTypes #-} + +{-# LANGUAGE BangPatterns #-} + +{-# LANGUAGE LambdaCase #-} + +{-# LANGUAGE DuplicateRecordFields #-} + +-------------------------------------------------------------------------------- + +-- | +-- 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 (..) + , Quit (..) + , Mode (..) + , Chit (..) + , Chat + , History (..) + , Load + , Flow (..) + , Wrap (..) + , Context(..) + , Mask (..) + , File (..) + , Files (..) + , FileLine + , FilePaths (..) + -- + , Failure, ModeOrFailure, Description + , Label (..) + , Branch (..) + , Branches (..) + , Index (..) + -- + , Jobs (..) + , JobStatus (..) + -- + , Pattern (..) + -- + , AbsoluteFilePath (..) + , AbsoluteFilePaths (..) + -- + , Template (..) + , GhcError (..) + , Location (..) + -- , Content (..) + , Hole (..) + , Signature (..) + -- + , TestCase (..) + , TestCases (..) + , TestResult (..) + , TestStatus (..) + -- + , modes + -- + , ghcErrorHole + , getGhcErrorLocation + , setGhcErrorLocation + -- + , tpl2xmls + -- + , decodeJsonArray + -- + , txt2b + , txt2ghces + , ghces2ths + -- + , th2xml + , ths2xml + -- + , gd2fps + -- + , isSuccess + , isMeldable + , jsonl2tcs + ) +where + +-------------------------------------------------------------------------------- + +import Prelude hiding ( span ) + +import Control.Arrow ( first ) +import Control.Monad ( void ) +import Data.Char ( toLower, toUpper ) +import Data.Data ( Data ) +import Data.Either ( partitionEithers ) +import Data.List ( isPrefixOf, partition ) +import Data.Maybe ( fromMaybe, listToMaybe ) +import Numeric ( showFFloat ) +import Text.Read ( readMaybe ) + +import Text.ParserCombinators.ReadP + +import Internal.GaloisInc.Text.JSON.Generic + ( Result (Error, Ok) + , fromJSON + ) +import Internal.GaloisInc.Text.JSON.String + ( readJSValue + , runGetJSON + ) + +import Agent.Control.Concurrent ( Task ) + +import qualified Internal.Utils as UTL + +-------------------------------------------------------------------------------- + +newtype UUID = UUID String + +newtype Root = Root FilePath deriving Eq + +newtype Filter = Filter String + +newtype Quit = Quit Bool + +data Mode + = Auto + | Chat + | Code + | Docs + | Echo + | Hone + | Plan + | Spec + deriving (Bounded, Enum, Eq, Read, Show) + +data Chit = + Chit + { prev :: ![String] + , next :: ![String] + } + +type Chat = [String] + +data History = + History + { chit :: !Chit + , chat :: !Chat + } + +type Load a = + ( Data a + , Show a + ) + => Maybe a + +newtype Flow = Flow Bool + +newtype Wrap = Wrap Bool + +data Context a = + Context + { quit :: !Quit + , mode :: !Mode + , load :: !(Load a) + , hist :: !History + , list :: !(Maybe Filter) + , pile :: !(Maybe FilePaths) + , ruck :: !(Maybe Files) + , jobs :: !(Maybe (Jobs (Context a))) + , flow :: !Flow + , wrap :: !Wrap + } + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +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 + +newtype AbsoluteFilePaths = AbsoluteFilePaths [FilePath] + +-------------------------------------------------------------------------------- + +-- NOTE: Then use `mconcat` to combine + +newtype FilePaths = FilePaths { filePaths :: [FilePath] } + +instance Semigroup FilePaths where + FilePaths xs <> FilePaths ys = + FilePaths (xs ++ ys) + +instance Monoid FilePaths where + mempty = FilePaths [] + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +type Description = String + +newtype Label = Label Description + +type Failure = () +type ModeOrFailure = Either Failure Mode + +data Branch = Branch !UUID !ModeOrFailure !Description + +newtype Branches = Branches [Branch] + +newtype Index = Index Int + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +newtype Jobs a = Jobs [(UUID, Task a)] + +-------------------------------------------------------------------------------- + +data JobStatus + = Blended + | Failure_ + | Running + | Skipped + | Stopped + | Waiting + +instance Show JobStatus where + show status_ = + case status_ of + Blended -> "BLENDED" + Failure_ -> "FAILURE" + Running -> "RUNNING" + Skipped -> "SKIPPED" + Stopped -> "STOPPED" + Waiting -> "WAITING" + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +data Template = + Template + { purpose :: !String + , instructions :: ![String] + , examples :: ![Markdown] + , files :: ![File] + } + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +newtype Pattern = Pattern String + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +data DecodeError + = InvalidJSON !String + | DiffSchema !String + deriving Show + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +data ParseError + = Remaining !String + | Unparsed ![String] + | Unexpected ![String] + deriving Show + +-------------------------------------------------------------------------------- + +data GhcError = + GhcError + { location :: !(String,Int,Int) + , number :: !(Maybe Int) + , content :: ![String] + } deriving Show + +-------------------------------------------------------------------------------- + +data Location = + Location !String !Int !Int + deriving Show + +data Signature = + Signature !String !String + deriving Show + +data Hole = + Hole + { location :: !Location + , signature :: !Signature + , description :: ![String] + , bindings :: ![(String, String)] + , constraints :: ![(String, String)] + , fits :: ![(String, String, Double)] + , refinements :: ![(String, String, String)] + } deriving Show + +-------------------------------------------------------------------------------- + +data TestStatus + = Success + | Failure + | Desisted + | NoFailure + deriving (Eq, Data, Show) + +data TestResult = + TestResult + { status :: !TestStatus + , numTests :: !Int + , usedSize :: !Int + , output :: !String + , reason :: !String + , theException :: !String + } deriving (Data, Show) + +data TestCase = + TestCase + { label :: !String + , result :: !TestResult + } deriving (Data, Show) + +newtype TestCases = TestCases [TestCase] + +instance Semigroup TestCases where + TestCases xs <> TestCases ys = + TestCases (xs ++ ys) + +instance Monoid TestCases where + mempty = TestCases [] + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +modes :: [Mode] +modes = + [ minBound .. maxBound ] + +-------------------------------------------------------------------------------- + +tpl2xmls + :: Template + -> (String, [Hole]) + -> [String] +tpl2xmls tpl (cwd, ths) = + [ ( 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 ++ + "" + ) ++ + ths2xml cwd ths + ] + 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 -> "") + $ instructions tpl + tes = + concatMap (\ x -> "") + $ examples tpl + tfs = zip [0 :: Int ..] $ files tpl + aux (i, File (src, ls)) = + "" ++ + "" ++ src ++ "" ++ + "" ++ + "" + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +ghcErrorHole + :: GhcError + -> Bool +ghcErrorHole (GhcError { number = Just 88464, content = ms }) = + -- NOTE: If it's 'var not in scope', just skip + case isPrefixOf "Variable not in scope:" <$> listToMaybe ms of + Just True -> False + _________ -> True +ghcErrorHole ________________________________________________ = False + +getGhcErrorLocation + :: GhcError + -> (String,Int,Int) +getGhcErrorLocation (GhcError l _ _) = + l + +setGhcErrorLocation + :: (String,Int,Int) + -> GhcError + -> GhcError +setGhcErrorLocation loc (GhcError _ mec con) = + GhcError loc mec con + +-------------------------------------------------------------------------------- + +decodeJsonArray + :: String + -> Either DecodeError [FileLine] +decodeJsonArray json = + case runGetJSON readJSValue json of + Left e -> Left $ InvalidJSON e + Right v -> + case fromJSON v of + Error err -> Left $ DiffSchema err + Ok fls -> Right fls + +-------------------------------------------------------------------------------- + +txt2ghcesInitHlp + :: String + -> Either ParseError GhcError +txt2ghcesInitHlp txt = + case readP_to_S (errP <* eof) txt of + [(a, [])] -> Right a + [(_, cs)] -> (Left . Remaining) cs + _________ -> (Left . Unparsed) [txt] + where + errP = + ( \ _ fp l c _ _ oe -> + GhcError + { location = (fp, read l :: Int, read c :: Int) + , number = oe + , content = [] + } + ) + <$> skipSpaces + <*> manyTill anyChar (char ':') + <*> manyTill anyChar (char ':') + <*> manyTill anyChar (char ':') + <*> skipSpaces + -- NOTE: As we need to validate typed-hole filling from the LLM against + -- the specification, in order to be able to `-fdefer-typed-holes`, we + -- need to support warnings as well as errors. + <*> choice [ string "error:", string "warning:" ] + <*> choice + [ -- NOTE: "error:" + ( \ _ _ n _ -> Just (read n :: Int) + ) + <$> skipSpaces + <*> string "[GHC-" + <*> manyTill anyChar (char ']') + <*> endOfLine + , -- NOTE: "warning:" + ( \ _ _ n _ _ _ _ -> Just (read n :: Int) + ) + <$> skipSpaces + <*> string "[GHC-" + <*> manyTill anyChar (char ']') + -- NOTE: Added when refactored from "error:" to "warning:" + <*> skipSpaces + <*> char '[' + <*> manyTill anyChar (char ']') + <*> endOfLine + , -- NOTE: No extra info + Nothing <$ endOfLine + ] + +txt2ghcesLastHlp + :: GhcError + -> Either ParseError GhcError +txt2ghcesLastHlp (GhcError gel gemn gels) = + case readP_to_S (errP <* eof) txt of + [(a, [])] -> Right a + [(_, cs)] -> (Left . Remaining) cs + _________ -> (Left . Unparsed) [txt] + where + txt = unlines gels + errP = + ( \ b _ _ _ _ _ _ -> + let + ls = + filter (not . null) + $ map (drop 4) + $ lines b + in + GhcError gel gemn ls + ) + <$> manyTill anyChar (char '|') + <*> manyTill anyChar endOfLine + <*> manyTill anyChar (char '|') + <*> manyTill anyChar endOfLine + <*> manyTill anyChar (char '|') + <*> manyTill anyChar + ( choice + [ void endOfLine + , eof + ] + ) + <*> skipSpaces + +txt2ghces + :: [String] + -> Either [ParseError] [GhcError] +txt2ghces = + ( \ case + ([], rs) -> Right rs + (es, __) -> Left es + ) + <$> partitionEithers . aux nil + where + nil = Nothing + -- + aux Nothing [ ] = [ ] + aux (Just acc) [ ] = + [ case acc of + Right a -> txt2ghcesLastHlp a + Left e -> Left e + ] + -- + aux Nothing ([ ] : ls) = aux nil ls + aux (Just acc) ([ ] : ls) = + ( case acc of + Right a -> txt2ghcesLastHlp a + Left e -> Left e + ) : aux nil ls + -- + aux Nothing ( l : ls) = + aux (Just mghce) ls + where + mghce = txt2ghcesInitHlp (l ++ "\n") + aux (Just acc) ( l : ls) = + aux (Just mghce) ls + where + mghce = + case acc of + Right a -> + Right + ( a + { content = content a ++ [l] + } + ) + Left e -> + Left e + +ghces2ths + :: FilePath + -> Maybe Int + -> [GhcError] + -> Either [ParseError] [Hole] +ghces2ths cwd upper ghces = + if null ls then + Right rs + else + (Left . concat) ls + where + sub = substitute cwd [] + ehs = + ( map + ( \ (GhcError (lfp, ll, lc) _ ms) -> + -- NOTE: Scripts MUST be excuted with UTF-8 support: + -- + -- LLM_PATH_CWD= … LC_ALL=en_US.UTF-8 ./hone.lhs + -- + -- Otherwise they fallback to '*' instead of '•'. + case combine "•" ms of + [m1, m2, m3] -> + case msg1P $ unwords $ msgFix (-1) $ indentations m1 of + Right (hn, sig) -> + case msg3P m3bs m3cs m3fs m3rs of + Right (bs, cs, fs_, rs_) -> + Right $ + Hole + { location = Location lfp ll lc + , signature = Signature hn (sub sig) + , description = map sub $ msgFix 0 $ indentations m2 + , bindings = bs + , constraints = cs + , fits = + take mf + $ zipWith + ( \(n,s) d -> + let + -- NOTE: If name is in bindings, + -- there is a high probability + -- that it will fit the + -- hole. Otherwise, it might be + -- low and hereby look in + -- refinements, with the provided + -- order. + p = + if + n `elem` lh || + n `elem` ns || + is + then + 1.0 - 1.0 / 11.0 ** (10.0 - d) + else + 1.0 / 10.0 ** ( 1.0 + d) + in + ( n, s + , p + ) + ) + (hf ++ bf ++ ff) [0..] + , refinements = hr ++ rf + } + where + -- NOTE: If the typed-hole name, less the + -- underscore, matches, then we put it + -- in-front of the list. Otherwise, we order + -- accordingly to the bindings (local and + -- closest first). + !hf = filter ( \ (n,_) -> n `elem` lh) fs_ + !lf = map fst fs_ + -- NOTE: If only one fit (singleton), then + -- it's very likely to be the one + !is = + case lf of + [_] -> True + ___ -> False + !bf = + ( filter ( \ (n,_) -> n `elem` lf) + . filter ( \ (n,_) -> n `notElem` lh) + ) bs + !lb = map fst bf + !ff = + ( filter ( \ (n,_) -> n `notElem` lh) + . filter ( \ (n,_) -> n `notElem` lb) + ) fs_ + -- + !ns = map fst bs + -- + !rr = take mr rs_ + (!hr,!rf) = + partition ( \ (n,_,_) -> n `elem` lh) rr + -- + mr = fromMaybe 10 upper + mf = mr `div` 2 + Left errs -> + Left errs + where + m3is = indentations m3 + m3bs = + includes bsInclude + $ msgFix 2 $ relOrValidInclude bsInclude m3is + m3cs = + includes csInclude + $ msgFix 2 $ relOrValidInclude csInclude m3is + m3fs = + includes fsInclude + $ msgFix 2 $ relOrValidInclude fsInclude m3is + m3rs = + includes rsInclude + $ msgFix 2 $ relOrValidInclude rsInclude m3is + -- + lh = + -- NOTE: Drop the prefixing underscore + case hn of + [ ] -> [ ] + _:cs -> [cs] + Left err -> + Left [ err ] + __________ -> + Left + [ Unexpected [ "Three expected messages aren't present: " ] ] + ) + . filter ghcErrorHole + ) ghces + (ls, rs) = partitionEithers ehs + +-------------------------------------------------------------------------------- + +msg1P :: String -> Either ParseError (String, String) +msg1P l1 = + case readP_to_S (auxP <* eof) l1 of + [(a, [])] -> Right a + [(_, cs)] -> Left $ Remaining cs + [ ] -> Left $ Unparsed [ l1 ] + _________ -> Left $ Unexpected [ l1 ] + where + auxP = + ( \ _ _ n h -> (n, h) + ) + <$> string "Found hole:" + <*> skipSpaces + <*> manyTill anyChar (string " :: ") + <*> many anyChar + +msg3P + :: [String] + -> [String] + -> [String] + -> [String] + -> Either [ParseError] + ( [(String, String)] + , [(String, String)] + , [(String, String)] + , [(String, String, String)] + ) +msg3P bs cs fs rs = + let + (lbs, rbs) = + partitionEithers + $ map + ( \ b -> + case readP_to_S bP b of + [(a, [ ])] -> Right a + [(_, cs_)] -> Left $ Remaining cs_ + [ ] -> Left $ Unparsed bs + __________ -> Left $ Unexpected bs + ) bs + (lcs, rcs) = + partitionEithers + $ map + ( \ b -> + case readP_to_S cP b of + [(a, [ ])] -> Right a + [(_, cs_)] -> Left $ Remaining cs_ + [ ] -> Left $ Unparsed cs + __________ -> Left $ Unexpected cs + ) cs + (lfs, rfs) = + partitionEithers + $ map + ( \ f -> + case readP_to_S fP f of + [(a, [ ])] -> Right a + [(_, cs_)] -> Left $ Remaining cs_ + [ ] -> Left $ Unparsed fs + __________ -> Left $ Unexpected fs + ) fs + (lrs, rrs) = + partitionEithers + $ map + ( \ r -> + case readP_to_S rP r of + [(a, [ ])] -> Right a + [(_, cs_)] -> Left $ Remaining cs_ + [ ] -> Left $ Unparsed rs + __________ -> Left $ Unexpected rs + ) rs + in + case (lbs, lcs, lfs, lrs) of + ([], [], [], []) -> + Right + ( rbs + , rcs + , rfs + , rrs + ) + ____________ -> + Left $ lbs ++ lcs ++ lfs ++ lrs + where + bP = + ( \ n s _ _ -> + ( n + , s + ) + ) + <$> manyTill anyChar (string " :: ") + <*> manyTill anyChar (string " (bound at ") + <*> manyTill anyChar (char ')') + <*> eof + cP = + ( \ n p _ -> + ( n + , p + ) + ) + <$> manyTill anyChar (char ' ') + <*> manyTill anyChar (char ' ') + <*> manyTill anyChar eof + fP = + (,) + <$> manyTill anyChar (string " :: ") + <*> manyTill anyChar eof + rP = + ( \ n h s -> + ( n + , " (_ :: " ++ h + , s + ) + ) + <$> manyTill anyChar (string " (_ :: ") + <*> manyTill anyChar (string " where ") + <*> manyTill anyChar eof + +anyChar :: ReadP Char +anyChar = + satisfy (const True) + +newline :: ReadP Char +newline = + char '\n' + +crlf :: ReadP Char +crlf = + char '\r' *> char '\n' + +endOfLine :: ReadP Char +endOfLine = + choice [ newline, crlf ] + +bsInclude :: String +bsInclude = "Relevant bindings include" + +csInclude :: String +csInclude = "Constraints include" + +fsInclude :: String +fsInclude = "Valid hole fits include" + +rsInclude :: String +rsInclude = "Valid refinement hole fits include" + +combine + :: String + -> [String] + -> [[String]] +combine pat = + map (map (drop 2)) . filter (not . null) . aux [] + where + aux acc ls = + case ls of + [ ] -> [acc] + (x:xs) -> + if pat `isPrefixOf` x then + acc : aux [x] xs + else + aux (acc ++ [x]) xs + +indentations :: [String] -> [(Int, String)] +indentations = + map (first length . break (/= ' ')) + +msgFix :: Int -> [(Int, String)] -> [String] +msgFix ident ls = + case ls of + [ ] -> [ ] + [(_,x) ] -> [x] + ((_,x):(i,y):rs) -> + if ident < i then + msgFix ident ((i, UTL.trim x ++ " " ++ UTL.trim y) : rs) + else + x : msgFix ident ((i, y) : rs) + +relOrValidInclude + :: String + -> [(Int, String)] + -> [(Int, String)] +relOrValidInclude pat xs = + case ys of + [ ] -> [ ] + [y ] -> [y] + (y:rs) -> y : takeWhile (\(i, _) -> 0 < i) rs + where + ys = + dropWhile + ( \(_,l) -> not (pat `isPrefixOf` l) + ) xs + +includes + :: String + -> [String] + -> [String] +includes pat xs = + case xs of + [ ] -> [] + [x ] -> [UTL.trim $ drop (length pat) x] + (_:rs) -> rs + +-------------------------------------------------------------------------------- + +substitute + :: String + -> String + -> String + -> String +substitute pat sub txt = + aux 0 ids txt + where + len = length pat + ids = findIndices pat txt + aux _ ______ [] = [] + aux _ [ ] cs = cs + aux o (i:is) cs = + take j cs ++ sub ++ aux n is r + where + j = i - o + k = j + len + n = k + o + r = drop k cs + +findIndices + :: Eq a + => [a] + -> [a] + -> [Int] +findIndices [ ] = const [] +findIndices pat = + aux 0 0 pat + where + aux o i [] xs = i : aux o o pat xs + aux _ _ __ [] = [ ] + aux o i (p:ps) (x:xs) = + if p == x then + aux (o+1) i ps xs + else + aux (o+1) (o+1) pat xs + +-------------------------------------------------------------------------------- + +txt2b + :: String + -> Either ParseError Branch +txt2b txt = + case readP_to_S (auxP <* eof) txt of + [(a, [])] -> Right a + [(_, cs)] -> Left $ Remaining cs + [ ] -> Left $ Unparsed [ txt ] + _________ -> Left $ Unexpected [ txt ] + where + -- NOTE: Sample + -- branch.20260811-075012-747631762.description [HONE] text_goes_here + auxP = + ( \ _ _ uid _ _ _ mof _ des -> + let + emof = + case mof of + [ ] -> Left ( ) + (c:cs) -> + case readMaybe (toUpper c : map toLower cs) :: Maybe Mode of + Nothing -> Left ( ) + Just m -> Right m + in + Branch (UUID uid) emof des + ) + <$> string "branch" + <*> char '.' + <*> manyTill anyChar (char '.') + <*> string "description" + <*> skipSpaces + <*> char '[' + <*> manyTill anyChar (char ']') + <*> skipSpaces + <*> manyTill anyChar eof + +-------------------------------------------------------------------------------- + +th2xml + :: String + -> Hole + -> String +th2xml cwd + ( Hole (Location p l o) (Signature hn s) d bs cs fs rs ) = + "" ++ + "" ++ + (frp ++ ":" ++ show l ++ ":" ++ show o) ++ + "" ++ + "" ++ + "" ++ + "" ++ + (concatMap b . zip [0 :: Int ..]) bs ++ + "" ++ + "" ++ + (concatMap c . zip [0 :: Int ..]) cs ++ + "" ++ + "" ++ + (concatMap f . zip [0 :: Int ..]) fs ++ + "" ++ + "" ++ + (concatMap r . zip [0 :: Int ..]) rs ++ + "" ++ + "" + where + dec n = showFFloat (Just 10) n "" + frp = drop (length cwd) p + b (i, (n, s_)) = + "" + c (i, (n, p_)) = + "" + f (i, (c_, s_, l_)) = + "" ++ + "" ++ + "" ++ + "" + where + -- lc = map toLower $ show l_ + _ = dec l_ + r (i, (n, c_, s_)) = + "" ++ + "" ++ + "" ++ + "" + +ths2xml + :: String + -> [Hole] + -> String +ths2xml cwd ths = + if null ths then + [] + else + "" ++ + concatMap (th2xml cwd) ths ++ + "" + +-------------------------------------------------------------------------------- + +gd2fps :: String -> Either ParseError [FilePath] +gd2fps txt = + case readP_to_S (many auxP <* eof) txt of + [(a, [])] -> Right a + [(_, cs)] -> Left $ Remaining cs + [ ] -> Left $ Unparsed [ txt ] + _________ -> Left $ Unexpected [ txt ] + where + auxP = + ( \ _ _ fp -> fp + ) + <$> choice + [ char 'A' + , char 'M' + ] + <*> skipSpaces + <*> manyTill anyChar endOfLine + +-------------------------------------------------------------------------------- + +isSuccess + :: TestCase + -> Bool +isSuccess TestCase { result = TestResult { status = Success } } = True +isSuccess _____________________________________________________ = False + +isMeldable + :: TestCase + -> Bool +isMeldable + TestCase { result = TestResult { status = Success } } = + True +isMeldable + TestCase { result = TestResult { status = Failure, theException = e } } = + -- NOTE: Now, this SHOULD go really fast as we JUST need to check if ALL + -- errors are typed-holes: Just 88464 (no parsing what-so-ever) and ensure + -- first line in description shows is not a 'var not in scope' + case txt2ghces els of + Right es -> all ghcErrorHole es + Left __ -> False + where + suf = "|\n|\n|\n" + els = lines (e ++ suf) +isMeldable + _______________________________________________________________________ = + False + +-------------------------------------------------------------------------------- + +decodeJsonlTestCases + :: [String] + -> Either [DecodeError] [TestCase] +decodeJsonlTestCases jsonl = + case partitionEithers aux of + ([], rs) -> Right rs + (ls, __) -> Left ls + where + aux = + map + ( \ json -> + case runGetJSON readJSValue json of + Left e -> Left $ InvalidJSON e + Right v -> + case fromJSON v of + Error err -> Left $ DiffSchema err + Ok fls -> Right fls + ) + jsonl + +jsonl2tcs + :: FilePath + -> [String] + -> Either [DecodeError] TestCases +jsonl2tcs cwd js = + case decodeJsonlTestCases js of + Right tcs -> (Right . TestCases) tcf + where + -- NOTE: Remove reason from output + tcf = + map + ( \ tc@(TestCase _ res) -> + let + o = output res + r = reason res + e = theException res + in + tc + { result = + res + { output = UTL.trim (substitute r [] o) + , theException = UTL.trim (substitute cwd [] e) + } + } + ) + tcs + Left des -> Left des diff --git a/src/Internal/LLM/Action.hs b/src/Internal/LLM/Action.hs --- a/src/Internal/LLM/Action.hs +++ b/src/Internal/LLM/Action.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -Wall -Werror #-} +{-# OPTIONS_GHC -Wall #-} {-# LANGUAGE NoGeneralizedNewtypeDeriving #-} {-# LANGUAGE Safe #-} @@ -27,26 +27,40 @@ -------------------------------------------------------------------------------- -type TextToFile = String -> [(FilePath, [INT.FileLine])] +type TextToFile = String -> Either [String] [(FilePath, [INT.FileLine])] data Action = None | Branch !String !INT.Files | Exit | Drop - | File !INT.File + | File !INT.File + | Files !INT.Files | Help - | Hist !(Bool, Bool) + | Hist !(Bool, Bool) | Message !MSG.Message - | Mode !Char !String - | Paths !INT.FilePaths + | Mode !Char !String + | Paths !INT.FilePaths | Pile + -- + | Branches !INT.Branches + -- | Prompt !String - | Batch !String + | Batch !String | Status | Sync | Stop - | Ruck !String - | Template !TextToFile ![INT.File] ![INT.File] ![INT.File] + -- + | Discover + | Hole !(Maybe INT.AbsoluteFilePath) + | Refine + -- + | Ruck !String + | Template !TextToFile ![INT.File] ![INT.File] ![INT.File] | UnknownCmd !String | Wipe + -- + | Tests !INT.TestCases + -- + | Exec + | Halt diff --git a/src/Internal/LLM/SystemOne.hs b/src/Internal/LLM/SystemOne.hs new file mode 100644 --- /dev/null +++ b/src/Internal/LLM/SystemOne.hs @@ -0,0 +1,638 @@ +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE NoGeneralizedNewtypeDeriving #-} +{-# LANGUAGE Safe #-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DuplicateRecordFields #-} + +{-# LANGUAGE LambdaCase #-} + +-------------------------------------------------------------------------------- + +-- | +-- Copyright : (c) 2026 SPISE MISU ApS +-- License : SSPL-1.0 OR AGPL-3.0-only +-- Maintainer : SPISE MISU +-- Stability : experimental + +-------------------------------------------------------------------------------- + + +module Internal.LLM.SystemOne + ( -- + RequestChoice(..) + , State(..) + , TypedHole(..) + , Question(..) + , Criteria(..) + -- + , ResponseChoice(..) + , Answer(..) + , Probability(..) + , Usage(..) + -- + , request + , response + -- + , encode + , decode + -- + , replaceHoles + ) +where + +-------------------------------------------------------------------------------- + +import Prelude hiding ( lines ) + +import Data.Bifunctor ( bimap ) +import Data.Data ( Data ) +import Data.Either ( partitionEithers ) +import Data.List + ( groupBy + , nub + , sort + , sortOn + ) +import Data.Maybe ( fromMaybe, isJust ) +import Text.Read ( readMaybe ) + + +import Internal.GaloisInc.Text.JSON + ( JSON + , readJSON + , showJSON + , showJSValue + ) +import Internal.GaloisInc.Text.JSON.Generic + ( Result (Error, Ok) + , fromJSON + , toJSON + ) +import Internal.GaloisInc.Text.JSON.String + ( readJSValue + , runGetJSON + ) +import Internal.GaloisInc.Text.JSON.Types + ( JSObject (..) + , JSString (..) + , JSValue (..) + , fromJSString + , toJSObject + , toJSString + ) + +import qualified Internal.LLM as LLM + +-------------------------------------------------------------------------------- + +{- Sample: + +{ + "state": { + "filepath": "src/Foo.hs", + "lines": [ + … + ], + "typedholes": [ + { + "line": 38, + "column": 15, + "hole": "_x", + "details": "_x :: Char Or perhaps ‘_x’ is mis-spelled, or not in scope", + "description": [ + "In an equation for ‘foo’: foo (Foo x) = _x" + ], + "bindings": [ + "x :: Char", + "foo :: Foo -> Char" + ], + "constraints": [], + "mostLikely": [ + "x" + ] + } + ] + }, + "questions": { + "0": { + "type": "choice", + "instructions": "Substitute the 'typed-hole' from src/Foo.hs at line 38 and column 15 with? (hint: 'mostLikely' value, if any)", + "criteria": { + "0": { + "sig": "x :: Char", + "val": "x" + }, + "1": { + "sig": "foo :: Foo -> Char", + "val": "(foo (_ :: Foo))" + } + } + } + } +} + +-} + +data RequestChoice = RequestChoice + { state :: !State + , questions :: ![(Int, Question)] + } deriving Show + +data State = State + { filepath :: !FilePath + , lines :: ![String] + , typedholes :: ![TypedHole] + } deriving (Data, Show) + +data TypedHole = TypedHole + { line :: !Int + , column :: !Int + , hole :: !String + , details :: !String + , description :: ![String] + , bindings :: ![String] + , constraints :: ![String] + , mostLikely :: ![String] + } deriving (Data, Show) + +data Question = Question + { type_ :: !String + , instructions :: !String + , criteria :: ![(Int, Criteria)] + } deriving Show + +data Criteria = Criteria + { sig :: !String + , val :: !String + } deriving Show + +-------------------------------------------------------------------------------- + +{- Sample: + +{ + "model": "sm-mockup", + "answers": { + "0": { + "type": "choice", + "choice": "0", + "confidence": 0.9651, + "probabilities": { + "0": 0.9651, + "1": 0.0182, + "2": 0.0112, + "3": 0.0055 + } + } + }, + "usage": { + "input_tokens": 0, + "output_tokens": 0, + "latency_ms": 1000 + } +} + +-} + +data ResponseChoice = ResponseChoice + { model :: !String + , answers :: ![(Int, Answer)] + , usage :: !Usage + } deriving Show + +data Answer = Answer + { type_ :: !String + , choice :: !String + , confidence :: !Double + , probabilities :: ![(Int, Probability)] + } deriving Show + +newtype Probability = Probability Double + deriving Show + +data Usage = Usage + { input_tokens :: !Int + , output_tokens :: !Int + , latency_ms :: !Double + } deriving (Data, Show) + +-------------------------------------------------------------------------------- + +instance JSON RequestChoice where + readJSON (JSObject o) = + case sortOn fst (fromJsobject o) of + [ ( "questions", JSObject q ) + , ( "state", s ) ] -> + case (res2either . fromJSON) s of + Right sv -> + if null ls && all isJust os then + Ok $ RequestChoice sv (zip is rs) + else + Error "Unable to read RequestChoice" + ________ -> + Error "Unable to read RequestChoice" + where + ms = fromJsobject q + ks = map fst ms + os = map (readMaybe :: String -> Maybe Int) ks + is = map (fromMaybe 0) os + vs = map snd ms + (ls,rs) = partitionEithers $ map (res2either . readJSON) vs + _____________________________________ -> + Error "Unable to read RequestChoice" + readJSON _________________ = + Error "Unable to read RequestChoice" + + showJSON (RequestChoice s qs) = + toJsobject + [ ( "state", toJSON s ) + , ( "questions", (toJsobject . map (bimap show showJSON)) qs ) + ] + +instance JSON Question where + readJSON (JSObject o) = + case sortOn fst (fromJsobject o) of + [ ( "criteria", JSObject c ) + , ( "instructions", JSString i ) + , ( "type", JSString t ) ] -> + if null ls && all isJust os then + Ok + $ Question + (fromJsstring t) + (fromJsstring i) + (zip is rs) + else + Error "Unable to read Question" + where + ms = fromJsobject c + ks = map fst ms + os = map (readMaybe :: String -> Maybe Int) ks + is = map (fromMaybe 0) os + vs = map snd ms + (ls,rs) = partitionEithers $ map (res2either . readJSON) vs + _____________________________________ -> + Error "Unable to read Question" + readJSON _________________ = + Error "Unable to read Question" + + showJSON (Question t i cs) = + toJsobject + [ ( "type", toJsstring t ) + , ( "instructions", toJsstring i ) + , ( "criteria", (toJsobject . map (bimap show showJSON)) cs ) + ] + +instance JSON Criteria where + readJSON (JSObject o) = + case sortOn fst (fromJsobject o) of + [ ( "sig", JSString s ) + , ( "val", JSString v ) ] -> + Ok $ Criteria { sig = fromJsstring s, val = fromJsstring v } + _____________________________________ -> + Error "Unable to read Criteria" + readJSON _________________ = + Error "Unable to read Criteria" + + showJSON (Criteria { sig = s, val = v }) = + toJsobject + [ ( "sig", toJsstring s ) + , ( "val", toJsstring v ) + ] + +-------------------------------------------------------------------------------- + +instance JSON ResponseChoice where + readJSON (JSObject o) = + case sortOn fst (fromJsobject o) of + [ ( "answers", JSObject a ) + , ( "model", JSString m ) + , ( "usage", u ) ] -> + case (res2either . fromJSON) u of + Right uv -> + if null ls && all isJust os then + Ok + $ ResponseChoice + (fromJsstring m) + (zip is rs) uv + else + Error "Unable to read ResponseChoice" + ________ -> + Error "Unable to read ResponseChoice" + where + ms = fromJsobject a + ks = map fst ms + os = map (readMaybe :: String -> Maybe Int) ks + is = map (fromMaybe 0) os + vs = map snd ms + (ls,rs) = partitionEithers $ map (res2either . readJSON) vs + _____________________________________ -> + Error "Unable to read ResponseChoice" + readJSON _________________ = + Error "Unable to read ResponseChoice" + + showJSON (ResponseChoice m as u) = + toJsobject + [ ( "model", toJsstring m ) + , ( "answers", (toJsobject . map (bimap show showJSON)) as ) + , ( "usage", toJSON u ) + ] + +instance JSON Answer where + readJSON (JSObject o) = + case sortOn fst (fromJsobject o) of + [ ( "choice", JSString ch ) + , ( "confidence", JSRational _ co ) + , ( "probabilities", JSObject ps ) + , ( "type", JSString t ) ] -> + if null ls && all isJust os then + Ok + $ Answer + (fromJsstring t) + (fromJsstring ch) + (rat2double co) + (zip is rs) + else + Error "Unable to read Answer" + where + ms = fromJsobject ps + ks = map fst ms + os = map (readMaybe :: String -> Maybe Int) ks + is = map (fromMaybe 0) os + vs = map snd ms + (ls,rs) = partitionEithers $ map (res2either . readJSON) vs + _____________________________________ -> + Error "Unable to read Answer" + readJSON _________________ = + Error "Unable to read Answer" + + showJSON (Answer t ch co ps) = + toJsobject + [ ( "type", toJsstring t ) + , ( "choice", toJsstring ch ) + , ( "confidence", (toJsrational . double2rat) co ) + , ( "probabilities", (toJsobject . map (bimap show showJSON)) ps ) + ] + +instance JSON Probability where + readJSON (JSRational _ r) = + (Ok . Probability . rat2double) r + readJSON _____________________ = + Error "Unable to read Probability" + + showJSON (Probability r) = + (toJsrational . double2rat) r + +-------------------------------------------------------------------------------- + +toJsobject :: [(String, JSValue)] -> JSValue +toJsobject = JSObject . toJSObject + +toJsrational :: Rational -> JSValue +toJsrational = JSRational True + +toJsstring :: String -> JSValue +toJsstring = JSString . toJSString + +fromJsobject :: JSObject e -> [(String, e)] +fromJsobject = fromJSObject + +fromJsstring :: JSString -> String +fromJsstring = fromJSString + +-------------------------------------------------------------------------------- + +rat2double :: Rational -> Double +rat2double = fromRational + +double2rat :: Double -> Rational +double2rat = toRational + +-------------------------------------------------------------------------------- + +res2either :: Result a -> Either String a +res2either (Error e) = Left e +res2either (Ok a) = Right a + +-------------------------------------------------------------------------------- + +encodeHlp :: JSON a => a -> String +encodeHlp = flip showJSValue [] . showJSON + +decodeHlp :: JSON a => String -> Result a +decodeHlp s = + case runGetJSON readJSValue s of + Right a -> readJSON a + Left err -> Error err + +-------------------------------------------------------------------------------- + +request :: LLM.File -> [LLM.Hole] -> RequestChoice +request (LLM.File (fp, ls)) hs = + RequestChoice s (zip [0..] qs) + where + s = + State + { filepath = fp + , lines = ls + , typedholes = + sortOn + ( \ TypedHole { line = l, column = c} -> (l, c) + ) + $ map + ( \ ( LLM.Hole (LLM.Location _ l c) (LLM.Signature hn hs_) d bs cs fs rs + ) -> + let + h = hn ++ " :: " ++ hs_ + u = + case hn of + [ ] -> [] + ['_'] -> [] + __:xs -> xs + in + TypedHole + { line = l + , column = c + , hole = hn + , details = h + , description = d + , mostLikely = + ( nub + . sort + . filter (u ==) + ) + ( map (\ (n,_,_) -> n) fs ++ map (\ (n,_,_) -> n) rs + ) + , bindings = + map + ( \ (n, s_) -> + n ++ " :: " ++ s_ + ) + $ filter ((u ==) . fst) bs ++ filter ((u /=) . fst) bs + , constraints = + map + ( \ (n, s_) -> + n ++ " :: " ++ s_ + ) + cs + } + ) + hs + } + qs = + map + ( \ ( LLM.Hole (LLM.Location fp_ l c) _ _ _ _ fs rs + ) -> + let + is = + -- "With what do we replace the typed-hole from " ++ fp_ ++ + -- "What should go instead of the typed-hole from " ++ fp_ ++ + -- "How do we substitute the typed-hole from " ++ fp_ ++ + "Substitute the 'typed-hole' from " ++ fp_ ++ + " at line " ++ show l ++ + " and column " ++ show c ++ + -- " with? (have in mind the value from 'mostLikely', if any)" + " with? (hint: 'mostLikely' value, if any)" + in + Question + { type_ = "choice" + , instructions = is + , criteria = + let + -- NOTE: Sometimes a typed-hole can show up both as a fit + -- and a refinement. It's the same logic, however, with + -- point-free-style, functions can be called without + -- (apparent) arguments + fs_ = + map + ( \ (c_, s_, _) -> + Criteria + { sig = c_ ++ " :: " ++ s_ + , val = c_ + } + ) + fs + rs_ = + map + ( \ (n, c_, s_) -> + Criteria + { sig = s_ + , val = "(" ++ n ++ c_ ++ ")" + } + ) + rs + in + zip [0..] (fs_ ++ rs_) + } + ) + hs + +response :: ResponseChoice -> [(Int, Int, Double)] +response res = + map + ( \ (i, a) -> + let + j = (read . choice) a :: Int + p = confidence a + in + (i, j, p) + ) + as + where + as = answers res + +-------------------------------------------------------------------------------- + +encode :: RequestChoice -> String +encode = + encodeHlp + +decode :: String -> Either String ResponseChoice +decode = + ( \ case + Ok a -> Right a + Error e -> Left e + ) + <$> decodeHlp + +-------------------------------------------------------------------------------- + +replaceHolesHlp + :: [String] + -> [(String, Int, Int)] + -> [[String]] + -> [Int] + -> [String] +replaceHolesHlp lines_ holes_ questions_ answers_ = + lin 1 lines_ gbl + where + hqa = zip3 holes_ questions_ answers_ + -- NOTE: Assuming holes_ are sorted ascending by lines + gbl = groupBy (\ ((_,i,_),_,_) ((_,j,_),_,_) -> i == j) hqa + -- + lin _ [] ______ = [] + lin _ ls [ ] = ls + lin m ls (b:bs) = + case b of + [ ] -> ls + (((_,i,_),_,_):_) -> + case ds of + [ ] -> ts + (l:rs) -> ts ++ col 1 0 b l : lin j rs bs + where + j = i + 1 + -- + k = i - m + -- + ts = take k ls + ds = drop k ls + -- + col _ _ [ ] cs = cs + col _ _ ___________________ [] = [] + col n o (((h,_,i),qs,a):rs) cs = t ++ v ++ col i l rs d + where + v = qs !! a + -- + k = i - n - o + -- + l = length h + -- + t = take k cs + d = drop (k + l) cs + +replaceHoles + :: RequestChoice + -> ResponseChoice + -> LLM.File +replaceHoles req@(RequestChoice s@(State fp ls _) _) res = + LLM.File + ( fp + , replaceHolesHlp ls hs qs as + ) + where + hs = + ( map + ( \ (TypedHole l c h _ _ _ _ _) -> + (h, l, c) + ) + . typedholes + ) s + qs = + ( map + ( \ (_, Question _ _ cs) -> + map + ( \ (_, Criteria { val = v }) -> + v + ) + cs + ) + . questions + ) req + as = + ( map + ( \ (_, Answer _ c _ _) -> + read c :: Int + ) + . answers + ) res diff --git a/src/Internal/RIO.hs b/src/Internal/RIO.hs --- a/src/Internal/RIO.hs +++ b/src/Internal/RIO.hs @@ -1,1680 +1,3218 @@ -{-# 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 - -- * Timestamps - , timestampUTC - -- * MultiThreading - , fork - , wait - , join - , tmax - , ttid - , tkil - , tnum - , tvar - , tval - , terr - -- * 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 Prelude hiding ( mod ) - -import Control.Concurrent ( ThreadId ) - -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 - -import Agent.Control.Concurrent ( Task ) -import qualified Agent.Control.Concurrent as CON - --------------------------------------------------------------------------------- - -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 MultiThreading m where - fork :: m a -> m (Task a) - wait :: Task a -> m a - join :: [ Task a ] -> m ( ) - -- - tmax :: m Int - ttid :: Task a -> m ThreadId - tkil :: Task a -> m String - tnum :: Task a -> m String - tvar :: Task a -> m Bool - tval :: Task a -> m (Maybe a) - terr :: Task a -> m (Maybe String) - --------------------------------------------------------------------------------- - -instance MultiThreading RIO where - fork (RestrictedIO io) = RestrictedIO $ CON.fork io - wait = RestrictedIO . CON.wait - join = RestrictedIO . CON.join - -- - tmax = RestrictedIO $ CON.tmax - ttid = pure . CON.ttid - tkil = RestrictedIO . CON.tkil - tnum = pure . CON.tnum - tvar = RestrictedIO . CON.tvar - tval = RestrictedIO . CON.tval - terr = RestrictedIO . CON.terr - --------------------------------------------------------------------------------- --------------------------------------------------------------------------------- - -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 mod >>= \ 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 - where - mod = "[CODE] " ++ txt - ( _, (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 $ map (++ "\n") es - , "## Adding files:" - , fromLeft "No error" ewaf - , "## Committing:" - , fromLeft "No error" ewcf - , "## Removing:" - , fromLeft "No error" ewrf - ] - Left e -> pure $ Left e - where - err = "[FAIL] " ++ 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 } +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE NoGeneralizedNewtypeDeriving #-} +{-# LANGUAGE Safe #-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# LANGUAGE LambdaCase #-} + +{-# LANGUAGE NumericUnderscores #-} + +-------------------------------------------------------------------------------- + +-- | +-- 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 + -- * Timestamps + , timestampUTC + -- * MultiThreading + , fork + , wait + , join + , tmax + , ttid + , tkil + , tnum + , tvar + , tval + , terr + -- * LLM (Config) + , llmPathCWD + -- * LLM (Chat) + , llmChatAPI, llmChatKey + , llmChatWeb + -- * LLM (Repo) + , llmRepoDir + , llmRepoBrs + , llmRepoGet + , llmRepoLab + , llmRepoCmp + , llmRepoRem + , llmRepoAdd + , llmRepoReq, llmRepoTug, llmRepoDel + -- * LLM (Code) + , llmCodeDir + , llmCodeMsk + , llmCodeIns, llmCodeExa + , llmCodeSeq, llmCodeGet + , llmCodePut + , llmCodeAPI, llmCodeKey + , llmCodeWeb + -- * LLM (Plan) + , llmPlanDir + , llmPlanMsk + , llmPlanSeq, llmPlanGet + , llmPlanAPI, llmPlanKey + , llmPlanWeb + -- * LLM (Spec) + , llmSpecLib, llmSpecDep, llmSpecMod, llmSpecFun, llmSpecRun, llmSpecOto + -- * LLM (Hone) + , llmHoneDir + , llmHoneMsk + , llmHoneSeq, llmHoneGet + , llmHonePut + , llmHoneSOM, llmHoneKey + , llmHoneWeb + -- + , typedHolesDev + , timeout + ) +where + +-------------------------------------------------------------------------------- + +import Prelude hiding ( abs, mod, span ) + +import Control.Concurrent ( ThreadId ) + +import Control.Exception ( SomeException, try ) +import Data.Char ( isDigit, toLower, toUpper ) +import Data.Either ( fromLeft, lefts, partitionEithers ) +import Data.List + ( isInfixOf + , isPrefixOf + , isSuffixOf + , partition + , sortBy + ) +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 qualified System.Process as SP +import System.Process + ( CreateProcess (std_err, std_in, std_out) + , StdStream (CreatePipe) + , createProcess + , proc + , readCreateProcessWithExitCode + , readProcessWithExitCode + , waitForProcess + ) +import qualified System.Timeout as ST +import Text.Read ( readMaybe ) + +import qualified Internal.LLM as LLM +import qualified Internal.Utils as UTL + +import qualified Agent.IO.Effects as EFF + +import Agent.Control.Concurrent ( Task ) + +import qualified Agent.Control.Concurrent as CON + +-------------------------------------------------------------------------------- + +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 MultiThreading m where + fork :: m a -> m (Task a) + wait :: Task a -> m a + join :: [ Task a ] -> m ( ) + -- + tmax :: m Int + ttid :: Task a -> m ThreadId + tkil :: Task a -> m String + tnum :: Task a -> m String + tvar :: Task a -> m Bool + tval :: Task a -> m (Maybe a) + terr :: Task a -> m (Maybe String) + +-------------------------------------------------------------------------------- + +instance MultiThreading RIO where + fork (RestrictedIO io) = RestrictedIO $ CON.fork io + wait = RestrictedIO . CON.wait + join = RestrictedIO . CON.join + -- + tmax = RestrictedIO CON.tmax + ttid = pure . CON.ttid + tkil = RestrictedIO . CON.tkil + tnum = pure . CON.tnum + tvar = RestrictedIO . CON.tvar + tval = RestrictedIO . CON.tval + terr = RestrictedIO . CON.terr + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +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 = 32_767 :: 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 -> + llmCurlChatCompletions json mapi mkey + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +class + EFF.LlmConf m + => LlmRepoRoot m + where + llmRepoDir + :: m (Maybe LLM.Root) + +instance + EFF.LlmConf RIO + => LlmRepoRoot RIO + where + llmRepoDir = EFF.llmPathCWD + +-------------------------------------------------------------------------------- + +class + EFF.LlmRepoRoot m + => LlmRepoAtom m + where + llmRepoBrs + :: m (Either [String] LLM.Branches) + +instance + EFF.LlmRepoRoot RIO + => LlmRepoAtom RIO + where + llmRepoBrs = + EFF.llmRepoDir >>= \ case + Just (LLM.Root root) -> + realPath root root >>= \ case + -- TODO: DRY + Right fap -> + gitExist fap >>= \ case + True -> + gitBranchesDesc fap >>= \ case + Left e -> pure $ Left [e] + Right bs -> + if null lbs then + pure + $ Right + $ LLM.Branches + $ sortBy + ( \ (LLM.Branch (LLM.UUID uid1) _ _) + (LLM.Branch (LLM.UUID uid2) _ _) -> + compare uid1 uid2 + ) + abs + else + pure + $ Left + $ map show lbs + where + (lbs, rbs) = partitionEithers $ map LLM.txt2b bs + atl = "_TL" + abs = + -- NOTE: Show all non-TAIL branches + filter + ( \ (LLM.Branch (LLM.UUID uid) _ _) -> + not (atl `isSuffixOf` uid) + ) rbs + False -> + pure $ Left [ "No GIT repo initialized" ] + Left err -> + pure $ Left [ err ] + Nothing -> + pure $ Left [ noLlmConf ] + +-------------------------------------------------------------------------------- + +class + EFF.LlmRepoRoot m + => LlmRepoTail m + where + llmRepoGet + :: m (Either String LLM.Branch) + +instance + EFF.LlmRepoRoot RIO + => LlmRepoTail RIO + where + llmRepoGet = + EFF.llmRepoDir >>= \ case + Just (LLM.Root root) -> + realPath root root >>= \ case + -- TODO: DRY + Right fap -> + gitExist fap >>= \ case + True -> + gitBranchesDesc fap >>= \ case + Left e -> pure $ Left e + Right bs -> + if null lbs then + case tbs of + [t] -> pure $ Right t + [ ] -> + timestampUTC >>= \ case + Just ts -> + gitBranch fap tid ohd >>= \ case + Right _ -> + gitBranchDescUpdate fap tid msg >>= \ case + Right _ -> + pure + $ Right + $ LLM.Branch + (LLM.UUID tid) + (Right LLM.Hone) + (drop ((+ 1) $ length hmt) msg) + Left e -> + pure $ Left e + Left e -> + pure $ Left e + where + len = length atl + tid = dropLastN len ts ++ atl + ohd = "origin/HEAD" + hmt = "[HONE]" + msg = + hmt ++ " Local TAIL branch" ++ + ", based on origin/HEAD" ++ + ", as local storage" + _______ -> + pure $ Left "No timestamp" + ___ -> + pure $ Left "Too many TAIL branches" + else + ( pure + . Left + . concatMap ((++ "\n") . show) + ) lbs + where + (lbs, rbs) = partitionEithers $ map LLM.txt2b bs + atl = "_TL" + tbs = + -- NOTE: Show only TAIL branches + filter + ( \ (LLM.Branch (LLM.UUID uid) _ _) -> + atl `isSuffixOf` uid + ) rbs + False -> + pure $ Left "No GIT repo initialized" + Left err -> + pure $ Left err + Nothing -> + pure $ Left noLlmConf + +-------------------------------------------------------------------------------- + +class + ( EFF.LlmRepoAtom m + , EFF.LlmRepoTail m + ) + => LlmRepoDesc m + where + llmRepoLab + :: LLM.UUID + -> LLM.Label + -> m (Either String String) + +instance + ( EFF.LlmRepoAtom RIO + , EFF.LlmRepoTail RIO + ) + => LlmRepoDesc RIO + where + llmRepoLab (LLM.UUID uid) (LLM.Label lab) = + EFF.llmRepoDir >>= \ case + Just (LLM.Root root) -> + realPath root root >>= \ case + -- TODO: DRY + Right fap -> + EFF.llmRepoGet >>= \ case + Right (LLM.Branch (LLM.UUID tid) _ _) -> + if tid == uid then + gitBranchDescUpdate fap tid lab + else + EFF.llmRepoBrs >>= \ case + Right (LLM.Branches bs) -> + ( \ (ls, rs) -> + -- NOTE: We assume only ONE instance + if null ls then + Right $ concat rs + else + Left $ concat ls + ) + <$> eb + where + fb = + filter + ( \ (LLM.Branch (LLM.UUID bid) _ _) -> + bid == uid + ) bs + eb = + partitionEithers + <$> mapM + ( \ (LLM.Branch (LLM.UUID bid) _ _) -> + gitBranchDescUpdate fap bid lab + ) fb + Left es -> + pure $ Left $ unlines es + Left e -> + pure $ Left e + Left err -> + pure $ Left err + Nothing -> + pure $ Left noLlmConf + +-------------------------------------------------------------------------------- + +class + ( EFF.LlmRepoAtom m + , EFF.LlmRepoTail m + ) + => LlmRepoDiff m + where + llmRepoCmp + :: LLM.UUID + -> m (Either String [String]) + +instance + ( EFF.LlmRepoAtom RIO + , EFF.LlmRepoTail RIO + ) + => LlmRepoDiff RIO + where + llmRepoCmp (LLM.UUID uid) = + EFF.llmRepoDir >>= \ case + Just (LLM.Root root) -> + realPath root root >>= \ case + -- TODO: DRY + Right fap -> + EFF.llmRepoGet >>= \ case + Right (LLM.Branch (LLM.UUID tid) _ _) -> + if tid == uid then + ( \case + Right r -> Right r + Left e -> Left $ unlines e + ) + <$> gitDiff fap ohd tid + else + EFF.llmRepoBrs >>= \ case + Right (LLM.Branches bs) -> + ( \ (ls, rs) -> + -- NOTE: We assume only ONE instance + if null ls then + Right $ concat rs + else + Left $ unlines $ concat ls + ) + <$> eb + where + fb = + filter + ( \ (LLM.Branch (LLM.UUID bid) _ _) -> + bid == uid + ) bs + eb = + partitionEithers + <$> mapM + ( \ (LLM.Branch (LLM.UUID bid) _ _) -> + gitDiff fap tid bid -- "src" + ) fb + Left es -> + pure $ Left $ unlines es + Left e -> + pure $ Left e + Left err -> + pure $ Left err + Nothing -> + pure $ Left noLlmConf + where + ohd = "origin/HEAD" + +-------------------------------------------------------------------------------- + +class + ( EFF.LlmRepoAtom m + , EFF.LlmRepoTail m + ) + => LlmRepoDisp m + where + llmRepoRem + :: Maybe LLM.UUID + -> m (Either String [String]) + +instance + ( EFF.LlmRepoAtom RIO + , EFF.LlmRepoTail RIO + ) + => LlmRepoDisp RIO + where + llmRepoRem ouid = + EFF.llmRepoDir >>= \ case + Just (LLM.Root root) -> + realPath root root >>= \ case + -- TODO: DRY + Right fap -> + EFF.llmRepoGet >>= \ case + Right (LLM.Branch (LLM.UUID tid) _ _) -> + EFF.llmRepoBrs >>= \ case + Right (LLM.Branches bs) -> + ( \ (ls, rs) -> + if null ls then + Right rs + else + Left $ unlines ls + ) + <$> eb + where + (ds,ms) = + partition + ( \ (LLM.Branch (LLM.UUID bid) emof _) -> + case emof of + Left _ -> True + Right _ -> tid > bid + ) bs + mo = + -- NOTE: Delete outdated (all except ahead of parent) + ( \ abs -> + map fst + $ filter ((GT /=) . snd) + $ map + ( \(b, ean) -> + case ean of + Right n -> (b, n) + --Left _ -> (b, 0) + Left _ -> (b, LT) + ) + abs + ) + <$> zip ms + <$> mapM + ( \ (LLM.Branch (LLM.UUID bid) _ _) -> + gitBranchAheadParent fap bid tid + ) ms + eb = + mo >>= \ os -> + partitionEithers + <$> mapM + ( \ (LLM.Branch (LLM.UUID bid) _ _) -> + gitBranchRemove True fap bid + ) (ds ++ os) + Left es -> + pure $ Left $ unlines es + Left e -> + pure $ Left e + Left err -> + pure $ Left err + Nothing -> + pure $ Left noLlmConf + where + -- NOTE: Use this for when we delete _TL after successfully merged to + -- origin/HEAD and pulled + _ {- uids -} = maybeToList ouid + +-------------------------------------------------------------------------------- + +class + ( EFF.LlmRepoAtom m + , EFF.LlmRepoTail m + ) + => LlmRepoMeld m + where + llmRepoAdd + :: m (Either String [String]) + +instance + ( EFF.LlmRepoAtom RIO + , EFF.LlmRepoTail RIO + ) + => LlmRepoMeld RIO + where + llmRepoAdd = + EFF.llmRepoDir >>= \ case + Just (LLM.Root root) -> + realPath root root >>= \ efap -> + realPath root "tmp" >>= \ etmp -> + case (efap, etmp) of + -- TODO: DRY + (Right fap, Right tmp) -> + EFF.llmRepoGet >>= \ case + Right (LLM.Branch pid@(LLM.UUID tid) _ _) -> + EFF.llmRepoBrs >>= \ case + Right (LLM.Branches bs) -> + gitWorktreeAdd fap lid tap (Just pid) >>= \ case + Right _ -> + eb >>= \ baz -> + gitWorktreeMer tap baz >>= \ emb -> + gitFetchMerge tap lid tid >>= \ emg -> + case (emb, emg) of + (Right mb, Right mg) -> + -- NOTE: Ensure worktree branch is always removed + gitWorktreeRem fap tap >> + gitBranchRemove True fap lid >> + (pure . Right) [ mb, mg ] + (other1, other2) -> + -- NOTE: Ensure worktree branch is always removed + gitWorktreeRem fap tap >> + gitBranchRemove True fap lid >> + (pure . Left . unlines . lefts) [other1, other2] + where + ms = + filter + ( \ (LLM.Branch (LLM.UUID bid) emof _) -> + case emof of + Left _ -> False + Right _ -> tid <= bid + ) bs + mo = + -- NOTE: Not outdated (parent is behind) + ( \ abs -> + map fst + $ filter ((GT ==) . snd) + $ map + ( \(b, eac) -> + case eac of + Right c -> (b, c) + Left _ -> (b, EQ) + ) + abs + ) + <$> zip ms + <$> mapM + ( \ (LLM.Branch (LLM.UUID bid) _ _) -> + gitBranchAheadParent fap bid tid + ) ms + eb = + map (\ (LLM.Branch uuid _ _) -> uuid) <$> mo + Left err -> + pure $ Left err + where + lid = (++ "_") $ map toLower tid + tap = tmp ++ "/" ++ lid ++ "/" + Left es -> + pure $ Left $ unlines es + Left e -> + pure $ Left e + (other1, other2) -> + pure $ Left $ unlines $ lefts [other1, other2] + Nothing -> + pure $ Left noLlmConf + +-------------------------------------------------------------------------------- + +class + EFF.LlmRepoTail m + => LlmRepoPull m + where + llmRepoReq + :: m (Either String [String]) + llmRepoTug + :: m (Either String [String]) + llmRepoDel + :: m (Either String [String]) + +instance + EFF.LlmRepoTail RIO + => LlmRepoPull RIO + where + llmRepoReq = + EFF.llmRepoDir >>= \ case + Just (LLM.Root root) -> + realPath root root >>= \ case + -- TODO: DRY + Right fap -> + EFF.llmRepoGet >>= \ case + Right (LLM.Branch (LLM.UUID tid) _ _) -> + ( \case + Right txt -> (Right . lines) txt + Left err -> Left err + ) + <$> gitBranchPushOrigin fap tid + Left e -> + pure $ Left e + Left err -> + pure $ Left err + Nothing -> + pure $ Left noLlmConf + + llmRepoTug = + EFF.llmRepoDir >>= \ case + Just (LLM.Root root) -> + realPath root root >>= \ case + Right fap -> + ( \case + Right txt -> (Right . lines) txt + Left err -> Left err + ) + <$> gitBranchPullOrigin fap + Left err -> + pure $ Left err + Nothing -> + pure $ Left noLlmConf + + llmRepoDel = + EFF.llmRepoDir >>= \ case + Just (LLM.Root root) -> + realPath root root >>= \ case + -- TODO: DRY + Right fap -> + EFF.llmRepoGet >>= \ case + Right (LLM.Branch (LLM.UUID tid) _ _) -> + ( \case + Right txt -> (Right . lines) txt + Left err -> Left err + ) + <$> gitBranchRemove False fap tid + Left e -> + pure $ Left e + Left err -> + pure $ Left err + Nothing -> + pure $ Left noLlmConf + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +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 (Either [String] [LLM.File]) + llmCodeExa + :: m [LLM.File] + +instance + ( EFF.LlmConf RIO + , EFF.LlmCodeTmpl RIO + ) + => LlmCodeTmpl RIO + where + llmCodeIns = + -- NOTE: No instructions are not an error as such + EFF.llmPathCWD >>= \ case + Just (LLM.Root root) -> + realPath root "llm" >>= \ case + -- TODO: DRY + Right fap -> + findFiles fap "*code_instructions_*.json" >>= \ case + Right afps -> + let + dfs = + mapM + ( \ abspath -> + ( \ json -> + case LLM.decodeJsonArray json of + Left err -> Left err + Right fls -> Right $ LLM.File (abspath, fls) + ) + <$> readFileStrict abspath + ) afps + in + dfs >>= \ fs -> + case partitionEithers fs of + ([], rs) -> pure $ Right rs + (ls, __) -> pure $ Left $ map show ls + Left __ -> + pure $ Right [ ] + Left ____ -> + pure $ Right [ ] + Nothing -> + pure $ Right [ ] + + llmCodeExa = + EFF.llmPathCWD >>= \ case + Just (LLM.Root root) -> + realPath root "llm" >>= \ case + -- TODO: DRY + Right fap -> + findFiles fap "*code_examples_*.md" >>= \ case + Right afps -> + mapM + ( \ abspath -> + LLM.File . (,) abspath . lines + <$> readFileStrict abspath + ) afps + Left __ -> + pure [] + Left ____ -> + pure [] + Nothing -> + pure [] + +-------------------------------------------------------------------------------- + +class + ( EFF.LlmConf m + , EFF.LlmRepoRoot 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) + +instance + ( EFF.LlmConf RIO + , EFF.LlmRepoRoot RIO + , EFF.LlmCodeRoot RIO + , EFF.LlmCodeMask RIO + ) + => LlmCodeRead RIO + where + llmCodeSeq mfilter = + EFF.llmPathCWD >>= \ case + Just (LLM.Root root) -> + EFF.llmCodeDir >>= \ cdir -> + EFF.llmCodeMsk >>= \ cmsk -> + realPath root cdir >>= \ case + -- 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 >>= \ case + 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 + +-------------------------------------------------------------------------------- + +class + ( EFF.LlmConf m + , EFF.LlmRepoRoot m + , EFF.LlmCodeRoot m + ) + => LlmCodeSave m + where + llmCodePut + :: LLM.Context a + -> Maybe LLM.UUID + -> String + -> LLM.Files + -> m (Either String String) + +instance + ( EFF.LlmConf RIO + , EFF.LlmRepoRoot 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 ctx ouid txt (LLM.Files fs) = + EFF.llmRepoDir >>= \ ocwd -> + EFF.llmCodeDir >>= \ cdir -> + case ocwd of + Just (LLM.Root root) -> + realPath root root >>= \ case + Right fap -> + gitExist fap >>= \ igit -> + gitignoreTmp fap >>= \ itmp -> + case (igit, itmp) of + (True, True) -> + timestampUTC >>= \ case + Just ts -> + realPath root "tmp" >>= \ case + Right tmp -> + gitWorktreeAdd fap ts tap ouid >>= \ 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:" + , drop len efp + , "* Writing file to folder:" + , drop len 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 -> + gitAddCommit tap txt >>= \ ewcf -> + gitWorktreeRem fap tap >>= \ ewrf -> + case + ( ewta + , partitionEithers ewfs + , ewcf + , ewrf + ) + of + ( Right wta + , ( [] + , xs + ) + , Right wcf + , Right wrf + ) -> + gitBranchDescUpdate fap ts pfx >>= \ case + 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 + where + pfx = "[" ++ mod ++ "] " ++ txt + mod = map toUpper $ show $ LLM.mode ctx + ( _, (es,__), _, _) -> + gitBranchDescUpdate fap 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:" + , unlines es + , "## Committing:" + , fromLeft "No error" ewcf + , "## Removing:" + , fromLeft "No error" ewrf + ] + Left e -> pure $ Left e + where + err = "[FAIL] " ++ 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 -> + llmCurlChatCompletions json mapi mkey + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +class + EFF.LlmPlanRoot m + => LlmPlanRoot m + where + llmPlanDir + :: m String + +instance + EFF.LlmPlanRoot RIO + => LlmPlanRoot RIO + where + llmPlanDir = pure "." + +-------------------------------------------------------------------------------- + +class + EFF.LlmPlanMask m + => LlmPlanMask m + where + llmPlanMsk + :: m [String] + +instance + 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 >>= \ case + Just (LLM.Root root) -> + EFF.llmPlanDir >>= \ pdir -> + EFF.llmPlanMsk >>= \ pmsk -> + realPath root pdir >>= \ case + -- 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 >>= \ case + 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.LlmPlanConf m + => LlmPlanConf m + where + llmPlanAPI + :: m (Maybe String) + llmPlanKey + :: m (Maybe String) + +instance + EFF.LlmPlanConf RIO + => LlmPlanConf RIO + where + llmPlanAPI = getEnvVar "LLM_PLAN_LOCALHOST_API" + llmPlanKey = pure Nothing + +-------------------------------------------------------------------------------- + +class + EFF.LlmPlanConf m + => LlmPlanPost m + where + llmPlanWeb + :: String + -> m (Either String String) + +instance + EFF.LlmPlanConf RIO + => LlmPlanPost RIO + where + llmPlanWeb json = + EFF.llmPlanAPI >>= \ mapi -> + EFF.llmPlanKey >>= \ mkey -> + llmCurlChatCompletions json mapi mkey + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +class + EFF.LlmSpecConf m + => LlmSpecConf m + where + llmSpecLib + :: m String + llmSpecMod + :: m String + llmSpecFun + :: m String + llmSpecDep + :: m [ String ] + llmSpecOto + :: m (Maybe Int) + +instance + EFF.LlmSpecConf RIO + => LlmSpecConf RIO + where + llmSpecLib = pure "spec" + llmSpecMod = pure "Spec.Core" + llmSpecFun = pure "testSuite" + llmSpecDep = pure [ "core", "common", "utils" ] + llmSpecOto = pure Nothing + +-------------------------------------------------------------------------------- + +class + ( EFF.LlmRepoAtom m + , EFF.LlmRepoTail m + , EFF.LlmCodeRoot m + , EFF.LlmSpecConf m + ) + => LlmSpecTest m + where + llmSpecRun + :: LLM.UUID + -> m (Either String LLM.TestCases) + +instance + ( EFF.LlmRepoAtom RIO + , EFF.LlmRepoTail RIO + , EFF.LlmCodeRoot RIO + , EFF.LlmSpecConf RIO + ) + => LlmSpecTest RIO + where + llmSpecRun (LLM.UUID uid) = + EFF.llmRepoDir >>= \ case + Just (LLM.Root root) -> + realPath root root >>= \ case + -- TODO: DRY + Right fap -> + EFF.llmRepoGet >>= \ case + Right (LLM.Branch pid@(LLM.UUID tid) _ _) -> + EFF.llmSpecLib >>= \ lib -> + EFF.llmSpecMod >>= \ mod -> + EFF.llmSpecFun >>= \ fun -> + EFF.llmSpecDep >>= \ dep -> + EFF.llmSpecOto >>= \ oto -> + EFF.llmCodeDir >>= \ dir -> + if tid == uid then + gitDiffFilesChanged fap ohd tid dir >>= \ efps -> + let + len = + -- NOTE: "src/" + length dir + 1 + fsp = + case efps of + Right fps -> fps + Left ___ -> [] + pts = + map + ( ("Test." ++) . + map ( \c -> if c == '/' then '.' else c) . + takeWhile (/= '.') . + drop len + ) + fsp + in + ( \case + Right r -> Right r + Left e -> Left $ unlines e + ) + <$> quickCheckSpec pid fap lib mod fun dep oto sep pts + else + EFF.llmRepoBrs >>= \ case + Right (LLM.Branches bs) -> + ( \ (ls, rs) -> + if null ls then + Right $ foldl (<>) et rs + else + Left $ unlines $ concat ls + ) + <$> eb + where + et = LLM.TestCases [] + fb = + filter + ( \ (LLM.Branch (LLM.UUID bid) _ _) -> + bid == uid + ) bs + eb = + partitionEithers + <$> mapM + ( \ (LLM.Branch bid@(LLM.UUID uid_) _ _) -> + gitDiffFilesChanged fap tid uid_ dir >>= \ efps -> + let + len = + -- NOTE: "src/" + length dir + 1 + fsp = + case efps of + Right fps -> fps + Left ___ -> [] + pts = + map + ( ("Test." ++) . + map ( \c -> if c == '/' then '.' else c) . + takeWhile (/= '.') . + drop len + ) + fsp + in + quickCheckSpec bid fap lib mod fun dep oto sep pts + ) fb + Left es -> + pure $ Left $ unlines es + Left e -> + pure $ Left e + Left err -> + pure $ Left err + Nothing -> + pure $ Left noLlmConf + where + ohd = "origin/HEAD" + sep = '.' + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +class + EFF.LlmConf m + => LlmHoneRoot m + where + llmHoneDir + :: m (Maybe LLM.Root) + +instance + ( EFF.LlmConf RIO + , EFF.LlmHoneRoot RIO + ) + => LlmHoneRoot RIO + where + llmHoneDir = + EFF.llmPathCWD >>= \ ocwd -> + case ocwd of + Just (LLM.Root root) -> + realPath root root >>= \ case + -- TODO: DRY + Right fap -> + -- NOTE: There MUST be only a single .cabal file in root (cwd) + findFiles fap "*.cabal" >>= \ case + Right fs -> + if 1 == length fs then + pure ocwd + else + pure Nothing + Left __ -> + pure Nothing + Left ____ -> + pure Nothing + Nothing -> + pure Nothing + +-------------------------------------------------------------------------------- + +class + EFF.LlmHoneMask m + => LlmHoneMask m + where + llmHoneMsk + :: m LLM.Mask + +instance + ( EFF.LlmConf RIO + , EFF.LlmHoneMask RIO + ) + => LlmHoneMask RIO + where + llmHoneMsk = + LLM.Mask . filter ( \ m -> "*.hs" == m || "*.lhs" == m ) + <$> EFF.llmCodeMsk + +-------------------------------------------------------------------------------- + +class + ( EFF.LlmCodeRoot m + , EFF.LlmHoneRoot m + , EFF.LlmRepoTail m + , EFF.LlmHoneMask m + ) + => LlmHoneRead m + where + llmHoneSeq + :: Maybe LLM.Filter + -> m (Either [String] LLM.FilePaths) + llmHoneGet + :: LLM.AbsoluteFilePath + -> m (Either String LLM.File) + +instance + ( EFF.LlmCodeRoot RIO + , EFF.LlmHoneRoot RIO + , EFF.LlmRepoTail RIO + , EFF.LlmHoneMask RIO + ) + => LlmHoneRead RIO + where + llmHoneSeq mfilter = + EFF.llmCodeDir >>= \ cdir -> + EFF.llmHoneMsk >>= \ (LLM.Mask hmsk) -> + EFF.llmHoneDir >>= \ case + Just (LLM.Root cwd) -> + -- + EFF.llmRepoGet >>= \ case + Right (LLM.Branch uid@(LLM.UUID tid) _ _) -> + -- + realPath cwd cwd >>= \ efap -> + realPath cwd "tmp" >>= \ etmp -> + case (efap, etmp) of + (Right fap, Right tmp) -> + gitWorktreeAdd fap lid tap (Just uid) >>= \ case + Right _ -> + mapM + (\ msk -> + findFiles cap ("*" ++ fil ++ "*" ++ msk) + ) hmsk >>= \ efs -> + case partitionEithers efs of + ([], rs) -> + gitWorktreeRem fap tap >> + gitBranchRemove True fap lid >> + ( pure + . Right + . LLM.FilePaths + . map + ( \ filepath -> + fap ++ "/" ++ (drop . length) tap filepath + ) + . mconcat + ) rs + (ls, __) -> + gitWorktreeRem fap tap >> + gitBranchRemove True fap lid >> + (pure . Left) ls + Left e -> + -- NOTE: Ensure worktree branch is always removed + gitWorktreeRem fap tap >> + gitBranchRemove True fap lid >> + (pure . Left . lines) e + where + lid = (++ "_") $ map toLower tid + tap = tmp ++ "/" ++ lid ++ "/" + cap = tap ++ cdir ++ "/" + fil = + case mfilter of + Just (LLM.Filter f) -> f + Nothing -> [ ] + (other1, other2) -> + (pure . Left . lefts) [other1, other2] + -- + Left e -> (pure . Left) [e] + -- + Nothing -> + pure $ Left [noLlmConf] + + llmHoneGet (LLM.AbsoluteFilePath abspath) = + EFF.llmHoneDir >>= \ case + Just (LLM.Root cwd) -> + -- + EFF.llmRepoGet >>= \ case + Right (LLM.Branch uid@(LLM.UUID tid) _ _) -> + -- + realPath cwd cwd >>= \ efap -> + realPath cwd "tmp" >>= \ etmp -> + case (efap, etmp) of + (Right fap, Right tmp) -> + gitWorktreeAdd fap lid tap (Just uid) >>= \ case + Right _ -> + -- + readFileStrict tap_ >>= \ txt -> + if tap `isPrefixOf` tap_ then + -- NOTE: Ensure worktree branch is always removed + gitWorktreeRem fap tap >> + gitBranchRemove True fap lid >> + -- NOTE: Root relative path + ( pure + . Right + . LLM.File + . (,) (drop len abspath) + . lines + ) txt + else + -- NOTE: Ensure worktree branch is always removed + gitWorktreeRem fap tap >> + gitBranchRemove True fap lid >> + ( pure + . Left + ) (notPrefixRootAndMode fap abspath LLM.Hone) + Left e -> + -- NOTE: Ensure worktree branch is always removed + gitWorktreeRem fap tap >> + gitBranchRemove True fap lid >> + (pure . Left) e + where + lid = (++ "_") $ map toLower tid + tap = tmp ++ "/" ++ lid ++ "/" + tap_ = tap ++ drop (length cwd) abspath + len = length cwd + (other1, other2) -> + ( pure + . Left + ) ( (show . length) other1 ++ (show . length) other2 + ) + -- + Left e -> (pure . Left) e + -- + Nothing -> + pure $ Left noLlmConf + +-------------------------------------------------------------------------------- + +class + ( EFF.LlmConf m + , EFF.LlmRepoTail m + , EFF.LlmCodeRoot m + , EFF.LlmHoneRoot m + ) + => LlmHoneSave m + where + llmHonePut + :: LLM.Context a + -> String + -> LLM.Files + -> m (Either String String) + +instance + ( EFF.LlmConf RIO + , EFF.LlmRepoTail RIO + , EFF.LlmCodeRoot RIO + , EFF.LlmHoneRoot RIO + ) + => LlmHoneSave RIO + where + llmHonePut ctx txt fs = + EFF.llmRepoGet >>= \ case + Right (LLM.Branch uid _ _) -> + EFF.llmHoneDir >>= + ( \case + Just __ -> llmCodePut ctx (Just uid) txt fs + Nothing -> (pure . Left) err + ) + Left e -> pure $ Left e + where + -- TODO: DRY + err = "There MUST be only a single .cabal file in root (cwd)" + +-------------------------------------------------------------------------------- + +class + ( EFF.LlmConf m + , EFF.LlmHoneConf m + ) + => LlmHoneConf m + where + llmHoneSOM + :: m (Maybe String) + llmHoneKey + :: m (Maybe String) + +instance + ( EFF.LlmConf RIO + , EFF.LlmHoneConf RIO + ) + => LlmHoneConf RIO + where + llmHoneSOM = getEnvVar "LLM_HSOM_LOCALHOST_SOM" + llmHoneKey = pure Nothing + +-------------------------------------------------------------------------------- + +class + ( EFF.LlmConf m + , EFF.LlmHoneConf m + ) + => LlmHonePost m + where + llmHoneWeb + :: String + -> m (Either String String) + +instance + ( EFF.LlmConf RIO + , EFF.LlmHoneConf RIO + ) + => LlmHonePost RIO + where + llmHoneWeb json = + EFF.llmHoneSOM >>= \ msom -> + EFF.llmHoneKey >>= \ mkey -> + llmCurlSystemOne json msom mkey + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +-- HELPERS (public) + +getEnvVar + :: String + -> RIO (Maybe String) +getEnvVar = + RestrictedIO . ENV.getEnv + +-------------------------------------------------------------------------------- + +-- HELPERS (private) + +timeout + :: Int + -> RIO a + -> RIO (Maybe a) +timeout secs rio = + RestrictedIO (ST.timeout (secs * 1_000_000) io) + where + (RestrictedIO io) = rio + +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 = + elem "/tmp/" . lines + <$> readFileStrict gi + where + gi = path ++ "/.gitignore" + +gitWorktreeAdd + :: FilePath + -> String + -> FilePath + -> Maybe LLM.UUID + -> RIO (Either String String) +gitWorktreeAdd root ts path ouid = + withExitCodeCwd root "git" + ( [ "worktree" + , "add" + , path + ] + ++ maybe [] ( \ (LLM.UUID uid) -> [uid]) ouid ++ + [ "-b", ts + ] + ) + +gitAddCommit + :: FilePath + -> String + -> RIO (Either String String) +gitAddCommit root mesg = + withExitCodeCwd root "git" + [ "commit" + , "-a" + , "-m" + , mesg + ] + +gitWorktreeRem + :: FilePath + -> FilePath + -> RIO (Either String String) +gitWorktreeRem root path = + withExitCodeCwd root "git" + [ "worktree" + , "remove" + , path + ] + +gitWorktreeMer + :: FilePath + -> [LLM.UUID] + -> RIO (Either String String) +gitWorktreeMer root bids = + if null bids then + (pure . Left) "No non-failing branches are provided to merge" + else + withExitCodeCwd root "git" + ( [ "merge" + , "--no-edit" + , "-s", "octopus" + ] + ++ map ( \ (LLM.UUID uid) -> uid) bids + ) + +gitFetchMerge + :: FilePath + -> String + -> String + -> RIO (Either String String) +gitFetchMerge root ts origin = + withExitCodeCwd root "git" + [ "fetch" + , "." + , ts ++ ":" ++ origin + ] + +gitDiff + :: FilePath + -> String + -> String + -> RIO (Either [String] [String]) +gitDiff root origin ts {- dir -} = + ( \ es eds ecs epa -> + case (es, eds, ecs, epa) of + (Right sf, Right sd, Right cs, Right c) -> + Right + $ lines + $ bs ++ "\n" ++ fs ++ "\n" ++ ds ++ "\n" ++ ms ++ "\n" ++ am + where + bs = "# Diff between: '" ++ ts ++ "' and '" ++ origin ++ "'" + fs = "## Files:\n" ++ sf + ds = "## Directories:\n" ++ sd + ms = "## Commits:\n" ++ cs + am = "## Merging:\n" ++ + ( case c of + LT -> + " Parent: '" ++ origin ++ + "' is ahead of child: '" ++ ts ++ "'\n" ++ + " and therefore, it can't be auto-merged." + EQ -> + " Parent: '" ++ origin ++ + "' is the same as child: '" ++ ts ++ "'\n" ++ + " and therefore, it makes no sense to merge." + GT -> + " Parent: '" ++ origin ++ + "' isn't ahead of child: '" ++ ts ++ "'\n" ++ + " and therefore, it can be auto-merged." + ) + _______________________________________ -> + Left $ lefts [es, eds, ecs ] ++ lefts [ epa ] + ) + <$> withExitCodeCwd root "git" + [ "diff" + , "--stat" + , "--stat-graph-width", "80" + , origin + , ts + -- , dir + ] + <*> withExitCodeCwd root "git" + [ "diff" + , "--dirstat=files" + , origin + , ts + -- , dir + ] + <*> withExitCodeCwd root "git" + [ "cherry", "-v" + , origin + , ts + ] + <*> gitBranchAheadParent root ts origin + +gitDiffFilesChanged + :: FilePath + -> String + -> String + -> String + -> RIO (Either String [String]) +gitDiffFilesChanged root origin ts dir = + -- NOTE: «… Added (A), …, Modified (M) …» + -- https://git-scm.com/docs/git-diff#Documentation/git-diff.txt---diff-filterACDMRTUXB + ( \case + Right txt -> + case LLM.gd2fps txt of + Right fps -> + Right $ filter (dir `isPrefixOf`) fps + Left err -> + Left $ show err + Left err -> + Left err + ) + <$> withExitCodeCwd root "git" + [ "diff" + , "--name-status" + , "--diff-filter=AM" + , origin ++ ".." ++ ts + ] + +gitBranch + :: FilePath + -> String + -> String + -> RIO (Either String ()) +gitBranch root ts origin = + ( \case + Right _ -> Right () + Left err -> Left err + ) + <$> withExitCodeCwd root "git" + [ "branch" + , ts + , origin + ] + +gitBranchesDesc + :: FilePath + -> RIO (Either String [String]) +gitBranchesDesc root = + ( \case + Right txt -> (Right . lines) txt + Left err -> + -- NOTE: "Returns error code 1 if key is not present". + -- + -- https://git-scm.com/docs/git-config#Documentation/git-config.txt-get + if null err then + Right [] + else + Left err + ) + <$> withExitCodeCwd root "git" + [ "config" + , "--local" + , "--get-regexp" + , "branch.*.description" + ] + +gitBranchDescUpdate + :: FilePath + -> String + -> String + -> RIO (Either String String) +gitBranchDescUpdate path ts desc = + withExitCodeCwd path "git" + [ "config" + , "--local" + , "branch." ++ ts ++ ".description" + , desc + ] + +gitBranchAheadParent + :: FilePath + -> String + -> String + -> RIO (Either String Ordering) +gitBranchAheadParent root child parent = + ( \ eap ebp -> + case (eap, ebp) of + (Right ap, Right bp) -> + case (map_, mbp) of + (Just a, Just b) -> + case (a, b) of + -- NOTE: + -- a) If they are equal, they are the same + -- b) If it's not behind, it's ahead + -- c) If it's not ahead, it's behind + -- d) It can't be both ahead and behind (Unexpected error) + (0,0) -> Right EQ + (_,0) -> Right LT + (0,_) -> Right GT + _____ -> Left "Unexpected error" + _______________ -> Left "Unexpected error" + where + map_ = (readMaybe . UTL.trim) ap :: Maybe Int + mbp = (readMaybe . UTL.trim) bp :: Maybe Int + (other1, other2) -> + Left $ unlines $ lefts [other1, other2] + ) + <$> withExitCodeCwd root "git" + [ "rev-list", "--count" + , child ++ ".." ++ parent + ] + <*> withExitCodeCwd root "git" + [ "rev-list", "--count" + , parent ++ ".." ++ child + ] + +gitBranchRemove + :: Bool + -> FilePath + -> String + -> RIO (Either String String) +gitBranchRemove force root ts = + ( \case + Right txt -> + Right $ UTL.trim txt + Left err -> + Left err + ) + <$> withExitCodeCwd root "git" + [ "branch" + , if force then "-D" else "-d" + , ts + ] + +gitBranchPushOrigin + :: FilePath + -> String + -> RIO (Either String String) +gitBranchPushOrigin root ts = + ( \case + Right txt -> + Right $ UTL.trim txt + Left err -> + Left err + ) + <$> withExitCodeCwd root "git" + [ "push" + , "--set-upstream" + , "origin" + , ts + ] + +gitBranchPullOrigin + :: FilePath + -> RIO (Either String String) +gitBranchPullOrigin root = + ( \ ef ep -> + case (ef, ep) of + (Right f, Right p) -> + Right $ UTL.trim f ++ "\n" ++ UTL.trim p + (other1, other2) -> + (Left . unlines . lefts) [other1, other2] + ) + <$> withExitCodeCwd root "git" + [ "fetch" + , "origin" + , "--prune" + ] + <*> withExitCodeCwd root "git" + [ "pull" + ] + +{- + +gitBranchCreatedFrom + :: FilePath + -> String + -> RIO (Maybe String) +gitBranchCreatedFrom root ts = + ( \case + Right txt -> + case idxOf pat txt of + Just idx -> Just $ drop (len idx) txt + Nothing -> Nothing + where + pat = "@{0}: branch: " + len i = length pat + i + Left ___ -> Nothing + ) + <$> withExitCodeCwd root "git" + [ "reflog" + , "show" + , ts + ] + where + idxOf pat txt + | null pat = Just 0 + | otherwise = aux 0 txt + where + aux _ [ ] = Nothing + aux i cs@(_:rs) + | pat `isPrefixOf` cs = Just i + | otherwise = aux (i + 1) rs + +-} + +llmCurlChatCompletions + :: String + -> Maybe String + -> Maybe String + -> RIO (Either String String) +llmCurlChatCompletions json mapi mkey = + case (mapi, mkey) of + (Nothing, _ ) -> + RestrictedIO $ pure $ Left "No API address was provided" + (Just api, Nothing) -> + withExitCodeStdInOCwd + False + Nothing + "curl" + ( [ -- "--verbose" + "--silent" + , "--show-error" + ] + ++ hs ++ + [ -- NOTE: https://curl.se/docs/manpage.html#--json + "--json", "@-" + , api ++ "/chat/completions" + ] + ) + json + (Just api, Just key) -> + withExitCodeStdInOCwd + False + Nothing + "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" + ] + +llmCurlSystemOne + :: String + -> Maybe String + -> Maybe String + -> RIO (Either String String) +llmCurlSystemOne json msom mkey = + case (msom, mkey) of + (Nothing, _ ) -> + RestrictedIO $ pure $ Left "No SOM address was provided" + (Just som, Nothing) -> + withExitCodeStdInOCwd + False + Nothing + "curl" + ( [ -- "--verbose" + "--silent" + , "--show-error" + ] + ++ hs ++ + [ -- NOTE: https://curl.se/docs/manpage.html#--json + "--json", "@-" + , som ++ "/systemone" + ] + ) + json + (Just som, Just key) -> + withExitCodeStdInOCwd + False + Nothing + "curl" + ( [ --"--verbose" + "--silent" + , "--show-error" + , "--header", "Authorization: " ++ key + ] + ++ hs ++ + [ -- NOTE: https://curl.se/docs/manpage.html#--json + "--json", "@-" + , som ++ "/systemone" + ] + ) + 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" + ] + +typedHolesDev + :: Maybe LLM.UUID + -> FilePath + -> RIO (Either [String] [LLM.GhcError]) +typedHolesDev Nothing _ = + pure $ Left [ "No TAIL exists" ] +typedHolesDev mpid@(Just (LLM.UUID tid)) cwd = + -- NOTE: Filter out anything else than Typed-Hole errors + -- + -- https://errors.haskell.org/messages/GHC-88464/ + + -- TODO: DRY + realPath cwd cwd >>= \ efap -> + realPath cwd "tmp" >>= \ etmp -> + case (efap, etmp) of + (Right fap, Right tmp) -> + gitWorktreeAdd fap lid tap mpid >>= \ case + Right _ -> + aux tap >>= \ case + Right ts -> + fts >>= \ efts -> + let + (lfts, rfts) = partitionEithers efts + in + -- NOTE: Ensure worktree branch is always removed + gitWorktreeRem fap tap >> + gitBranchRemove True fap lid >> + ( if null lfts then + pure $ Right rfts + else + pure $ Left lfts + ) + where + fts = + mapM + ( \ ghcerr -> + let + (f, l, c) = LLM.getGhcErrorLocation ghcerr + in + realPath fap (drop len f) >>= \ case + Right f_ -> + pure $ Right $ LLM.setGhcErrorLocation (f_, l, c) ghcerr + Left l_ -> + pure $ Left l_ + ) + ts + Left l -> + -- NOTE: Ensure worktree branch is always removed + gitWorktreeRem fap tap >> + gitBranchRemove True fap lid >> + (pure . Left) l + Left e -> + pure $ Left $ lines e + where + lid = (++ "_") $ map toLower tid + tap = tmp ++ "/" ++ lid ++ "/" + len = length tap + (other1, other2) -> + pure $ Left $ lefts [other1, other2] + where + aux wcwd = + ( \case + Right txt -> + case LLM.txt2ghces $ lines $ cabalUpdateWarning txt of + Right rs -> Right $ filter LLM.ghcErrorHole rs + Left ls -> Left $ map show ls + Left err -> Left [err] + ) + <$> withExitCodeStdInOCwd + True -- NOTE: Only read from stderr + (Just wcwd) + "cabal" + [ "repl" + , "-O0" + , "--enable-multi-repl" + , "--repl-options=" ++ unwords rops + ] + quit + where + -- NOTE: It seems that if you pass `stdin` to `cabal repl` it will + -- automatically exit. Therefore, it doesn't seem necesary to pass ":q" + -- + -- NOTE: `-fdiagnostics-as-json` flag is introduced in ghc-9.10, + -- however, we support ghc-9.6.7 and ghc-9.8.4 as well, therefore, we + -- can't use it. + quit = [] + rops = + [ -- + "-ignore-dot-ghci" + -- NOTE: Limit number of typed-holes per file. Ideally it SHOULD be + -- by project, but for now, will take it + , "-fmax-errors=5" + -- + , "-fno-code" + -- NOTE: Avoid the `Some … suppressed` message + , "-fno-max-relevant-binds" + , "-fno-max-valid-hole-fits" + , "-fno-max-refinement-hole-fits" + -- NOTE: Try with n = 1, 2, 4 or 8 (n = number of args for a function) + , "-frefinement-level-hole-fits=8" + -- + , "-fsort-by-subsumption-hole-fits" + , "-funclutter-valid-hole-fits" + ] + +quickCheckSpec + :: LLM.UUID + -> FilePath + -> String + -> String + -> String + -> [String] + -> Maybe Int + -> Char + -> [String] + -> RIO (Either [String] LLM.TestCases) +quickCheckSpec pid@(LLM.UUID bid) cwd lib mod fun dep oto sep pts = + -- TODO: DRY + realPath cwd cwd >>= \ efap -> + realPath cwd "tmp" >>= \ etmp -> + case (efap, etmp) of + (Right fap, Right tmp) -> + gitWorktreeAdd fap lid tap (Just pid) >>= \ case + Right _ -> + aux tap >>= \ case + Right tcs -> + -- NOTE: Ensure worktree branch is always removed + gitWorktreeRem fap tap >> + gitBranchRemove True fap lid >> + (pure . Right) tcs + Left l -> + -- NOTE: Ensure worktree branch is always removed + gitWorktreeRem fap tap >> + gitBranchRemove True fap lid >> + (pure . Left) l + Left e -> + pure $ Left $ lines e + where + lid = (++ "_") $ map toLower bid + tap = tmp ++ "/" ++ lid ++ "/" + (other1, other2) -> + pure $ Left $ lefts [other1, other2] + where + aux wcwd = + if escs then + ( \case + Right txt -> + case etcs of + Right tcs -> Right tcs + Left des -> Left $ map show des + where + etcs = + LLM.jsonl2tcs wcwd + $ filter (isPrefixOf "{\"label\":\"Test") + $ lines + $ cabalUpdateWarning txt + Left err -> + Left [err] + ) + <$> withExitCodeStdInOCwd + False -- NOTE: Only read from stdout + (Just wcwd) + "cabal" + ( [ "repl" + , lib + ] ++ dep ++ + [ "-O0" + , "--enable-multi-repl" + , "--ghc-option=" ++ unwords gops + , "--repl-options=" ++ unwords rops + ] + ) + (unlines exec) + else + (pure . Left) + [ "The provided LlmSpecConf values: " ++ + "llmSpecLib, llmSpecMod, llmSpecFun and/or llmSpecDep, " ++ + "do not comply with the naming mask of: [azAZ-_]." + ] + where + -- NOTE: It seems that if you pass `stdin` to `cabal repl` it will + -- automatically exit. Therefore, it doesn't seem necesary to pass ":q" + exec = + [ ":set prompt \"\"" + , ":set prompt-cont \"\"" + , "import Data.Maybe (Maybe (Just, Nothing))" + , "import Prelude (mapM_, putStrLn, (>>=))" + , "import System.IO (hSetEncoding, stderr, stdout, utf8)" + , "import Test.QuickCheck.Silent (quickCheckSilentSuiteJSON)" + , "hSetEncoding stderr utf8" + , "hSetEncoding stdout utf8" + , "putStrLn []" + , "quickCheckSilentSuiteJSON" + ++ " " ++ t ++ " " ++ s ++ " " ++ p ++ " " ++ f ++ " " ++ m + ] + where + t = "(" ++ show oto ++ ")" + s = "'" ++ [sep] ++ "'" + p = "[" ++ csp ++ "]" + where + csp = + -- NOTE: `foldl1` throws an Exception on empty lists + case map ( \ p_ -> "\"" ++ p_ ++ "\"" ) pts of + [] -> [] + xs -> foldl1 ( \ x y -> x ++ "," ++ y) xs + f = " " ++ mod ++ [sep] ++ fun + m = ">>= mapM_ putStrLn" + gops = + [ "-package quickcheck-silent-0.11.0.17" + ] + rops = + [ -- NOTE: Since we don't use the `-fno-code` flag, this trick: + -- `--ghc-options "-osuf dyn_o -hisuf dyn_hi"` might be + -- relevant. More info: https://jade.fyi/blog/cabal-test-dev-trick/ + "-osuf dyn_o" + , "-hisuf dyn_hi" + -- + , "-ignore-dot-ghci" + -- NOTE: Limit number of typed-holes per file. Ideally it SHOULD be + -- by project, but for now, will take it + , "-fmax-errors=5" + -- NOTE: Allow for runtime typed-holes and ensure warnings + , "-Wwarn" + , "-fdefer-typed-holes" + -- NOTE: Only trust QC and dependencies + , "-fpackage-trust" + , "-trust=base" + , "-trust=QuickCheck" + , "-trust=array" + , "-trust=containers" + , "-trust=deepseq" + , "-trust=ghc-prim" + , "-trust=random" + , "-trust=splitmix" + ] + escs = + -- NOTE: Naive implementatoin of "Exploits of a Mom": + -- - https://xkcd.com/327/ (Little Bobby Tables) + all vcs lib && + all vcs mod && + all vcs fun && + ( all id . map (all vcs) + ) dep + where + vcs = + \ c -> + 'a' <= c && c <= 'z' || + 'A' <= c && c <= 'Z' || + c == '-' || + c == '_' + +cabalUpdateWarning + :: String + -> String +cabalUpdateWarning txt = + -- NOTE: Remove annoying warning from cabal: + -- + -- Warning: The package list for 'hackage.haskell.org' is 26 days old. + -- Run 'cabal update' to get the latest list of available packages. + unlines + $ filter ( not . (upd `isInfixOf`)) + $ filter + ( \ l -> + not (pre `isPrefixOf` l && suf `isSuffixOf` l) + ) + $ lines txt + where + pre = "Warning: The package list for 'hackage.haskell.org' is" + suf = "days old." + upd = "Run 'cabal update' to get the latest list of available packages." + +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 + -> FilePath + -> RIO (Either String String) +realPath cwd 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 + ) + <$> withExitCodeCwd cwd "realpath" + [ path + ] + +ensureFolderPath + :: FilePath + -> FilePath + -> RIO (Either String String) +ensureFolderPath root path = + withExitCodeCwd root "dirname" [ path ] >>= \ case + Right adp -> + ( \ case + Right _ -> Right sadp + Left e -> Left e + ) + <$> withExitCodeCwd root "mkdir" [ "-p", sadp ] + where + sadp = 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 + +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 { SP.cwd = Just path } + +withExitCodeStdInOCwd + :: Bool + -> Maybe String + -> String + -> [String] + -> String + -> RIO (Either String String) +withExitCodeStdInOCwd diag opath 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) + if diag then + pure $ Right err + else + pure $ Right out + ExitFailure _ -> + pure $ Left err + Left e -> pure $ Left $ show e + where + raw = proc cmd args + rcp = + raw + { SP.cwd = opath + , 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 + -- NOTE: Using strict version of `hGetContents` + out <- hGetContents' hout + err <- hGetContents' herr + exitcode <- waitForProcess ph + return (exitcode, out, err) + +dropLastN :: Int -> [a] -> [a] +dropLastN _ [] = [] +dropLastN 0 xs = xs +dropLastN n xs = dropLastN (n-1) (init xs) diff --git a/src/Internal/Utils.hs b/src/Internal/Utils.hs --- a/src/Internal/Utils.hs +++ b/src/Internal/Utils.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -Wall -Werror #-} +{-# OPTIONS_GHC -Wall #-} {-# LANGUAGE NoGeneralizedNewtypeDeriving #-} {-# LANGUAGE Safe #-} @@ -26,26 +26,30 @@ , index , split , linesOptNums + , trim ) where -------------------------------------------------------------------------------- -import Prelude hiding ( lines ) -import qualified Prelude as Prelude +import Data.Char ( isSpace ) -------------------------------------------------------------------------------- combine - :: [ (String, String) ] + :: Bool + -> [ (String, String) ] -> [ String ] -combine = +combine newline = map ( \ (x, y) -> if null x then y else - x ++ ": " ++ y + if newline then + x ++ ":\n" ++ y + else + x ++ ": " ++ y ) leftpad @@ -62,8 +66,8 @@ :: Int -> Int -> String -index rep idx = - leftpad '0' rep $ show idx +index rep = + leftpad '0' rep . show split :: Char @@ -84,15 +88,15 @@ -> Bool -> [ String ] -> [ (String, String) ] -files prefix nums fs = - linesOptNums prefix nums 0 fs +files prefix nums = + linesOptNums prefix [] nums 0 file :: Bool -> String -> [ (String, String) ] -file nums f = - linesOptNums [] nums 1 $ Prelude.lines f +file nums = + linesOptNums [] [] nums 1 . lines -------------------------------------------------------------------------------- @@ -100,15 +104,15 @@ :: Bool -> [ String ] -> [ (String, String) ] -chits nums fs = - linesOptNums [] nums 0 $ reverse fs +chits nums = + linesOptNums [] [] nums 0 . reverse chats :: Bool -> [ String ] -> [ (String, String) ] -chats nums fs = - linesOptNums [] nums 0 $ reverse fs +chats nums = + linesOptNums [] [] nums 0 . reverse -------------------------------------------------------------------------------- @@ -116,16 +120,23 @@ linesOptNums :: String + -> String -> Bool -> Int -> [ String ] -> [ (String, String) ] -linesOptNums prefix nums origo xs = - zipWith (\ idx rel -> (prefix ++ f idx, rel)) [origo..] xs +linesOptNums prefix postfix nums origo xs = + zipWith (\ idx rel -> (prefix ++ f idx ++ postfix, rel)) [origo..] xs where - len = length $ show $ length xs + len = (length . show . length) xs f i = if nums then index len i else [] + +trim :: String -> String +trim = + f . f + where + f = reverse . dropWhile isSpace