A-gent 0.11.0.19 → 0.11.0.20
raw patch · 19 files changed
+7612/−3075 lines, 19 filessetup-changedPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- Agent.IO.Effects: llmCodeGit :: LlmCodeRead m => m (Either String String)
- Agent.IO.Restricted: llmCodeGit :: LlmCodeRead m => m (Either String String)
- Agent.LLM: Test :: Mode
+ Agent.IO.Effects: class Monad m => LlmHoneConf (m :: Type -> Type)
+ Agent.IO.Effects: class LlmCodeMask m => LlmHoneMask (m :: Type -> Type)
+ Agent.IO.Effects: class LlmHoneConf m => LlmHonePost (m :: Type -> Type)
+ Agent.IO.Effects: class (LlmCodeRoot m, LlmHoneRoot m, LlmRepoTail m, LlmHoneMask m) => LlmHoneRead (m :: Type -> Type)
+ Agent.IO.Effects: class LlmConf m => LlmHoneRoot (m :: Type -> Type)
+ Agent.IO.Effects: class (LlmConf m, LlmRepoTail m, LlmCodeRoot m, LlmHoneRoot m) => LlmHoneSave (m :: Type -> Type)
+ Agent.IO.Effects: class LlmRepoRoot m => LlmRepoAtom (m :: Type -> Type)
+ Agent.IO.Effects: class (LlmRepoAtom m, LlmRepoTail m) => LlmRepoDesc (m :: Type -> Type)
+ Agent.IO.Effects: class (LlmRepoAtom m, LlmRepoTail m) => LlmRepoDiff (m :: Type -> Type)
+ Agent.IO.Effects: class (LlmRepoAtom m, LlmRepoTail m) => LlmRepoDisp (m :: Type -> Type)
+ Agent.IO.Effects: class (LlmRepoAtom m, LlmRepoTail m) => LlmRepoMeld (m :: Type -> Type)
+ Agent.IO.Effects: class LlmRepoTail m => LlmRepoPull (m :: Type -> Type)
+ Agent.IO.Effects: class LlmConf m => LlmRepoRoot (m :: Type -> Type)
+ Agent.IO.Effects: class LlmRepoRoot m => LlmRepoTail (m :: Type -> Type)
+ Agent.IO.Effects: class Monad m => LlmSpecConf (m :: Type -> Type)
+ Agent.IO.Effects: class (LlmRepoAtom m, LlmRepoTail m, LlmCodeRoot m, LlmSpecConf m) => LlmSpecTest (m :: Type -> Type)
+ Agent.IO.Effects: llmHoneDir :: LlmHoneRoot m => m (Maybe Root)
+ Agent.IO.Effects: llmHoneGet :: LlmHoneRead m => AbsoluteFilePath -> m (Either String File)
+ Agent.IO.Effects: llmHoneKey :: LlmHoneConf m => m (Maybe String)
+ Agent.IO.Effects: llmHoneMsk :: LlmHoneMask m => m Mask
+ Agent.IO.Effects: llmHonePut :: LlmHoneSave m => Context a -> String -> Files -> m (Either String String)
+ Agent.IO.Effects: llmHoneSOM :: LlmHoneConf m => m (Maybe String)
+ Agent.IO.Effects: llmHoneSeq :: LlmHoneRead m => Maybe Filter -> m (Either [String] FilePaths)
+ Agent.IO.Effects: llmHoneWeb :: LlmHonePost m => String -> m (Either String String)
+ Agent.IO.Effects: llmRepoAdd :: LlmRepoMeld m => m (Either String [String])
+ Agent.IO.Effects: llmRepoBrs :: LlmRepoAtom m => m (Either [String] Branches)
+ Agent.IO.Effects: llmRepoCmp :: LlmRepoDiff m => UUID -> m (Either String [String])
+ Agent.IO.Effects: llmRepoDel :: LlmRepoPull m => m (Either String [String])
+ Agent.IO.Effects: llmRepoDir :: LlmRepoRoot m => m (Maybe Root)
+ Agent.IO.Effects: llmRepoGet :: LlmRepoTail m => m (Either String Branch)
+ Agent.IO.Effects: llmRepoLab :: LlmRepoDesc m => UUID -> Label -> m (Either String String)
+ Agent.IO.Effects: llmRepoRem :: LlmRepoDisp m => Maybe UUID -> m (Either String [String])
+ Agent.IO.Effects: llmRepoReq :: LlmRepoPull m => m (Either String [String])
+ Agent.IO.Effects: llmRepoTug :: LlmRepoPull m => m (Either String [String])
+ Agent.IO.Effects: llmSpecDep :: LlmSpecConf m => m [String]
+ Agent.IO.Effects: llmSpecFun :: LlmSpecConf m => m String
+ Agent.IO.Effects: llmSpecLib :: LlmSpecConf m => m String
+ Agent.IO.Effects: llmSpecMod :: LlmSpecConf m => m String
+ Agent.IO.Effects: llmSpecOto :: LlmSpecConf m => m (Maybe Int)
+ Agent.IO.Effects: llmSpecRun :: LlmSpecTest m => UUID -> m (Either String TestCases)
+ Agent.IO.Restricted: llmHoneDir :: LlmHoneRoot m => m (Maybe Root)
+ Agent.IO.Restricted: llmHoneGet :: LlmHoneRead m => AbsoluteFilePath -> m (Either String File)
+ Agent.IO.Restricted: llmHoneKey :: LlmHoneConf m => m (Maybe String)
+ Agent.IO.Restricted: llmHoneMsk :: LlmHoneMask m => m Mask
+ Agent.IO.Restricted: llmHonePut :: LlmHoneSave m => Context a -> String -> Files -> m (Either String String)
+ Agent.IO.Restricted: llmHoneSOM :: LlmHoneConf m => m (Maybe String)
+ Agent.IO.Restricted: llmHoneSeq :: LlmHoneRead m => Maybe Filter -> m (Either [String] FilePaths)
+ Agent.IO.Restricted: llmHoneWeb :: LlmHonePost m => String -> m (Either String String)
+ Agent.IO.Restricted: llmRepoAdd :: LlmRepoMeld m => m (Either String [String])
+ Agent.IO.Restricted: llmRepoBrs :: LlmRepoAtom m => m (Either [String] Branches)
+ Agent.IO.Restricted: llmRepoCmp :: LlmRepoDiff m => UUID -> m (Either String [String])
+ Agent.IO.Restricted: llmRepoDel :: LlmRepoPull m => m (Either String [String])
+ Agent.IO.Restricted: llmRepoDir :: LlmRepoRoot m => m (Maybe Root)
+ Agent.IO.Restricted: llmRepoGet :: LlmRepoTail m => m (Either String Branch)
+ Agent.IO.Restricted: llmRepoLab :: LlmRepoDesc m => UUID -> Label -> m (Either String String)
+ Agent.IO.Restricted: llmRepoRem :: LlmRepoDisp m => Maybe UUID -> m (Either String [String])
+ Agent.IO.Restricted: llmRepoReq :: LlmRepoPull m => m (Either String [String])
+ Agent.IO.Restricted: llmRepoTug :: LlmRepoPull m => m (Either String [String])
+ Agent.IO.Restricted: llmSpecDep :: LlmSpecConf m => m [String]
+ Agent.IO.Restricted: llmSpecFun :: LlmSpecConf m => m String
+ Agent.IO.Restricted: llmSpecLib :: LlmSpecConf m => m String
+ Agent.IO.Restricted: llmSpecMod :: LlmSpecConf m => m String
+ Agent.IO.Restricted: llmSpecOto :: LlmSpecConf m => m (Maybe Int)
+ Agent.IO.Restricted: llmSpecRun :: LlmSpecTest m => UUID -> m (Either String TestCases)
+ Agent.LLM: Hone :: Mode
+ Agent.LLM: Spec :: Mode
+ Agent.LLM: [flow] :: Context a -> !Flow
+ Agent.LLM: [quit] :: Context a -> !Quit
+ Agent.LLM: [wrap] :: Context a -> !Wrap
+ Agent.LLM.Action: branch :: Branch -> Action
+ Agent.LLM.Action: branches :: Branches -> Action
+ Agent.LLM.Action: files :: [File] -> Action
+ Agent.LLM.Action: tests :: TestCases -> Action
+ Agent.LLM.Message: Desc :: !UUID -> !Label -> Message
+ Agent.LLM.Message: Diff :: !UUID -> Message
+ Agent.LLM.Message: Disp :: Message
+ Agent.LLM.Message: Fill :: !Maybe [AbsoluteFilePath] -> Message
+ Agent.LLM.Message: Meld :: Message
+ Agent.LLM.Message: Pull :: Message
+ Agent.LLM.Message: Push :: Message
+ Agent.LLM.Message: Shed :: Message
+ Agent.LLM.Message: Tail :: Message
+ Agent.LLM.Message: Test :: !UUID -> Message
- Agent.Data.JSON: DiffSchema :: DecodeError
+ Agent.Data.JSON: DiffSchema :: !String -> DecodeError
- Agent.Data.JSON: InvalidJSON :: DecodeError
+ Agent.Data.JSON: InvalidJSON :: !String -> DecodeError
- Agent.IO.Effects: class (LlmConf m, LlmCodeRoot m, LlmCodeMask m) => LlmCodeRead (m :: Type -> Type)
+ Agent.IO.Effects: class (LlmConf m, LlmRepoRoot m, LlmCodeRoot m, LlmCodeMask m) => LlmCodeRead (m :: Type -> Type)
- Agent.IO.Effects: class (LlmConf m, LlmCodeRoot m) => LlmCodeSave (m :: Type -> Type)
+ Agent.IO.Effects: class (LlmConf m, LlmRepoRoot m, LlmCodeRoot m) => LlmCodeSave (m :: Type -> Type)
- Agent.IO.Effects: class (LlmConf m, LlmPlanConf m) => LlmPlanPost (m :: Type -> Type)
+ Agent.IO.Effects: class LlmPlanConf m => LlmPlanPost (m :: Type -> Type)
- Agent.IO.Effects: class Monad m => LlmPlanRoot (m :: Type -> Type)
+ Agent.IO.Effects: class LlmConf m => LlmPlanRoot (m :: Type -> Type)
- Agent.IO.Effects: llmCodeIns :: LlmCodeTmpl m => m [File]
+ Agent.IO.Effects: llmCodeIns :: LlmCodeTmpl m => m (Either [String] [File])
- Agent.IO.Effects: llmCodePut :: LlmCodeSave m => String -> Files -> m (Either String String)
+ Agent.IO.Effects: llmCodePut :: LlmCodeSave m => Context a -> Maybe UUID -> String -> Files -> m (Either String String)
- Agent.IO.Restricted: llmCodeIns :: LlmCodeTmpl m => m [File]
+ Agent.IO.Restricted: llmCodeIns :: LlmCodeTmpl m => m (Either [String] [File])
- Agent.IO.Restricted: llmCodePut :: LlmCodeSave m => String -> Files -> m (Either String String)
+ Agent.IO.Restricted: llmCodePut :: LlmCodeSave m => Context a -> Maybe UUID -> String -> Files -> m (Either String String)
- Agent.LLM: Context :: !Mode -> !Load a -> !History -> !Maybe Filter -> !Maybe FilePaths -> !Maybe Files -> !Maybe (Jobs (Context a)) -> Context a
+ Agent.LLM: Context :: !Quit -> !Mode -> !Load a -> !History -> !Maybe Filter -> !Maybe FilePaths -> !Maybe Files -> !Maybe (Jobs (Context a)) -> !Flow -> !Wrap -> Context a
- Agent.LLM.Action: type TextToFile = String -> [(FilePath, [FileLine])]
+ Agent.LLM.Action: type TextToFile = String -> Either [String] [(FilePath, [FileLine])]
Files
- A-gent.cabal +10/−4
- CHANGELOG.md +103/−0
- README.md +157/−52
- Setup.hs +2/−4
- src/Agent/Control/Concurrent.hs +2/−37
- src/Agent/Control/IFC.hs +1/−1
- src/Agent/Control/MAC.hs +1/−1
- src/Agent/Data/ANSI/EscapeCode.hs +8/−8
- src/Agent/Data/JSON.hs +5/−5
- src/Agent/IO/Effects.hs +220/−12
- src/Agent/IO/Restricted.hs +51/−11
- src/Agent/LLM.hs +1908/−1029
- src/Agent/LLM/Action.hs +29/−2
- src/Agent/LLM/Message.hs +22/−2
- src/Internal/LLM.hs +1184/−199
- src/Internal/LLM/Action.hs +23/−9
- src/Internal/LLM/SystemOne.hs +638/−0
- src/Internal/RIO.hs +3218/−1680
- src/Internal/Utils.hs +30/−19
A-gent.cabal view
@@ -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:
CHANGELOG.md view
@@ -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
README.md view
@@ -1,7 +1,7 @@ Λ-gent ====== -[](https://hackage.haskell.org/package/A-gent)+[][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
Setup.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -Wall -Werror #-}+{-# OPTIONS_GHC -Wall #-} -------------------------------------------------------------------------------- @@ -10,9 +10,7 @@ -------------------------------------------------------------------------------- -import Distribution.Simple- ( defaultMain- )+import Distribution.Simple ( defaultMain ) --------------------------------------------------------------------------------
src/Agent/Control/Concurrent.hs view
@@ -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
src/Agent/Control/IFC.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -Wall -Werror #-}+{-# OPTIONS_GHC -Wall #-} {-# LANGUAGE NoGeneralizedNewtypeDeriving #-} {-# LANGUAGE Safe #-}
src/Agent/Control/MAC.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -Wall -Werror #-}+{-# OPTIONS_GHC -Wall #-} {-# LANGUAGE NoGeneralizedNewtypeDeriving #-} {-# LANGUAGE Safe #-}
src/Agent/Data/ANSI/EscapeCode.hs view
@@ -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"
src/Agent/Data/JSON.hs view
@@ -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
src/Agent/IO/Effects.hs view
@@ -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)
src/Agent/IO/Restricted.hs view
@@ -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 )
src/Agent/LLM.hs view
@@ -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 <mail+hackage@spisemisu.com>--- Stability : experimental------ Polite and well educated LLM agent with excellent manners that always behaves--- well.------------------------------------------------------------------------------------module Agent.LLM- ( -- * Modes- Mode(..)- -- * Context- , Context(..)- , AbsoluteFilePath- , Chat- , Chit- , File- , FileLine- , FilePaths- , Files- , Filter- , History- , Load- , Mask- , Root- , Template- , UUID- -- * Paramenters- , Eval- -- * Methods- , repl- , replWithMode- )-where------------------------------------------------------------------------------------import Prelude hiding ( head, 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 <mail+hackage@spisemisu.com>+-- Stability : experimental+--+-- Polite and well educated LLM agent with excellent manners that always behaves+-- well.++--------------------------------------------------------------------------------++module Agent.LLM+ ( -- * Modes+ Mode(..)+ -- * Context+ , Context(..)+ , AbsoluteFilePath+ , Chat+ , Chit+ , File+ , FileLine+ , FilePaths+ , Files+ , Filter+ , History+ , Load+ , Mask+ , Root+ , Template+ , UUID+ -- * Paramenters+ , Eval+ -- * Methods+ , repl+ , replWithMode+ )+where++--------------------------------------------------------------------------------++import Prelude hiding ( head, mod, print, read )+import 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
src/Agent/LLM/Action.hs view
@@ -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 =
src/Agent/LLM/Message.hs view
@@ -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"
src/Internal/LLM.hs view
@@ -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 <mail+hackage@spisemisu.com>--- 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- "<purpose>" ++ pur ++ "</purpose>"- ) ++- ( if eis then- []- else- "<instructions>" ++- tis ++- "</instructions>"- ) ++- ( if ees then- []- else- "<examples>" ++- tes ++- "</examples>"- ) ++- ( if efs then- []- else- "<files>" ++- concatMap aux tfs ++- "</files>"- )- ]- where- pur =- purpose tpl ++- ( if eis then- []- else- ". Follow the specified `instructions`"- ) ++- ( if ees then- []- else- ". Output MUST match scaffolding from provided `examples`"- ) ++- ( if efs then- []- else- ". Apply to each of the `files`"- )- eis = null tis- ees = null tes- efs = null tfs- tis =- concatMap (\ x -> "<instruction>" ++ x ++ "</instruction>")- $ instructions tpl- tes =- concatMap (\ x -> "<example>" ++ x ++ "</example>")- $ examples tpl- tfs = zip [0 :: Int ..] $ files tpl- aux (i, File (src, ls)) =- "<file index=\"" ++ show i ++ "\">" ++- "<source>" ++ src ++ "</source>" ++- "<content>" ++ unlines ls ++ "</content>" ++- "</file>"+{-# 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 <mail+hackage@spisemisu.com>+-- 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+ "<purpose>" ++ pur ++ "</purpose>"+ ) +++ ( if eis then+ []+ else+ "<instructions>" +++ tis +++ "</instructions>"+ ) +++ ( if ees then+ []+ else+ "<examples>" +++ tes +++ "</examples>"+ ) +++ ( if efs then+ []+ else+ "<files>" +++ concatMap aux tfs +++ "</files>"+ ) +++ 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 -> "<instruction><![CDATA[" ++ x ++ "]]></instruction>")+ $ instructions tpl+ tes =+ concatMap (\ x -> "<example><![CDATA[" ++ x ++ "]]></example>")+ $ examples tpl+ tfs = zip [0 :: Int ..] $ files tpl+ aux (i, File (src, ls)) =+ "<file index='" ++ show i ++ "'>" +++ "<source>" ++ src ++ "</source>" +++ "<content><![CDATA[" ++ unlines ls ++ "]]></content>" +++ "</file>"++--------------------------------------------------------------------------------+--------------------------------------------------------------------------------++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 ) =+ "<typedhole>" +++ "<source>" +++ (frp ++ ":" ++ show l ++ ":" ++ show o) +++ "</source>" +++ "<hole><![CDATA[" +++ hn ++ " :: " ++ s +++ "]]></hole>" +++ "<description><![CDATA[" +++ (init . unlines) d +++ "]]></description>" +++ "<bindings>" +++ (concatMap b . zip [0 :: Int ..]) bs +++ "</bindings>" +++ "<constraints>" +++ (concatMap c . zip [0 :: Int ..]) cs +++ "</constraints>" +++ "<fits>" +++ (concatMap f . zip [0 :: Int ..]) fs +++ "</fits>" +++ "<refinements>" +++ (concatMap r . zip [0 :: Int ..]) rs +++ "</refinements>" +++ "</typedhole>"+ where+ dec n = showFFloat (Just 10) n ""+ frp = drop (length cwd) p+ b (i, (n, s_)) =+ "<binding index='" ++ show i ++ "'><![CDATA[" +++ n ++ " :: " ++ s_ +++ "]]></binding>"+ c (i, (n, p_)) =+ "<constraint index='" ++ show i ++ "'><![CDATA[" +++ n ++ " " ++ p_ +++ "]]></constraint>"+ f (i, (c_, s_, l_)) =+ "<fit index='" ++ show i ++ "' likelihood='" ++ dec l_ ++ "'>" +++ "<code><![CDATA[" +++ c_ +++ "]]></code>" +++ "<where><![CDATA[" +++ c_ ++ " :: " ++ s_ +++ "]]></where>" +++ "</fit>"+ where+ -- lc = map toLower $ show l_+ _ = dec l_+ r (i, (n, c_, s_)) =+ "<refinement index='" ++ show i ++ "'>" +++ "<code><![CDATA[" +++ n ++ c_ +++ "]]></code>" +++ "<where><![CDATA[" +++ s_ +++ "]]></where>" +++ "</refinement>"++ths2xml+ :: String+ -> [Hole]+ -> String+ths2xml cwd ths =+ if null ths then+ []+ else+ "<typedholes>" +++ concatMap (th2xml cwd) ths +++ "</typedholes>"++--------------------------------------------------------------------------------++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
src/Internal/LLM/Action.hs view
@@ -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
+ src/Internal/LLM/SystemOne.hs view
@@ -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 <mail+hackage@spisemisu.com>+-- 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
src/Internal/RIO.hs view
@@ -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 <mail+hackage@spisemisu.com>--- Stability : experimental------ Safe {H}askell------ https://simonmar.github.io/bib/safe-haskell-2012_abstract.html------ (David Terei, David Mazières, Simon Marlow, Simon Peyton Jones) Haskell ’12:--- Proceedings of the Fifth ACM SIGPLAN Symposium on Haskell, Copenhagen,--- Denmark, ACM, 2012------ Though Haskell is predominantly type-safe, implementations contain a few--- loopholes through which code can bypass typing and module encapsulation. This--- paper presents Safe Haskell, a language extension that closes these--- loopholes. Safe Haskell makes it possible to confine and safely execute--- untrusted, possibly malicious code. By strictly enforcing types, Safe Haskell--- allows a variety of different policies from API sandboxing to--- information-flow control to be implemented easily as monads. Safe Haskell is--- aimed to be as unobtrusive as possible. It enforces properties that--- programmers tend to meet already by convention. We describe the design of--- Safe Haskell and an implementation (currently shipping with GHC) that infers--- safety for code that lies in a safe subset of the language. We use Safe--- Haskell to implement an online Haskell interpreter that can securely execute--- arbitrary untrusted code with no overhead. The use of Safe Haskell greatly--- simplifies this task and allows the use of a large body of existing code and--- tools.------------------------------------------------------------------------------------module Internal.RIO- ( RIO ()- , run- -- * Environment- , getEnvVar- -- * Read/Print- , input- , output- -- * 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 <mail+hackage@spisemisu.com>+-- Stability : experimental+--+-- Safe {H}askell+--+-- https://simonmar.github.io/bib/safe-haskell-2012_abstract.html+--+-- (David Terei, David Mazières, Simon Marlow, Simon Peyton Jones) Haskell ’12:+-- Proceedings of the Fifth ACM SIGPLAN Symposium on Haskell, Copenhagen,+-- Denmark, ACM, 2012+--+-- Though Haskell is predominantly type-safe, implementations contain a few+-- loopholes through which code can bypass typing and module encapsulation. This+-- paper presents Safe Haskell, a language extension that closes these+-- loopholes. Safe Haskell makes it possible to confine and safely execute+-- untrusted, possibly malicious code. By strictly enforcing types, Safe Haskell+-- allows a variety of different policies from API sandboxing to+-- information-flow control to be implemented easily as monads. Safe Haskell is+-- aimed to be as unobtrusive as possible. It enforces properties that+-- programmers tend to meet already by convention. We describe the design of+-- Safe Haskell and an implementation (currently shipping with GHC) that infers+-- safety for code that lies in a safe subset of the language. We use Safe+-- Haskell to implement an online Haskell interpreter that can securely execute+-- arbitrary untrusted code with no overhead. The use of Safe Haskell greatly+-- simplifies this task and allows the use of a large body of existing code and+-- tools.++--------------------------------------------------------------------------------++module Internal.RIO+ ( RIO ()+ , run+ -- * Environment+ , getEnvVar+ -- * Read/Print+ , input+ , output+ -- * 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)
src/Internal/Utils.hs view
@@ -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