diff --git a/A-gent.cabal b/A-gent.cabal --- a/A-gent.cabal +++ b/A-gent.cabal @@ -9,7 +9,7 @@ build-type: Simple name: A-gent -version: 0.11.0.7 +version: 0.11.0.8 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 @@ -141,23 +141,28 @@ hs-source-dirs: src other-modules: + -- error: [GHC-87110] + -- Could not load module ‘Internal.…’. + -- it is a hidden module in the package ‘A-gent-0.11.0.…’ Internal.GaloisInc.Text.JSON Internal.GaloisInc.Text.JSON.Generic Internal.GaloisInc.Text.JSON.String Internal.GaloisInc.Text.JSON.Types -- Internal.GlasgowUniversity.Data.Generics.Aliases + -- + Internal.LLM + Internal.RIO exposed-modules: Agent.Control.Concurrent Agent.Control.IFC Agent.Control.MAC + Agent.Data.ANSI.EscapeCode -- Agent.IO.Effects Agent.IO.Restricted -- Agent.Utils.Common - Agent.Utils.Code - Agent.Utils.Plan -- Agent.JSON -- diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,7 +1,56 @@ # Revision history for Λ-gent -## 0.11.0.7 -- 2026-03-30 +## 0.11.0.8 -- 2026-04-15 +* Refactored `/pile` to no longer storing a `find` filter but the absolute path + to the `find` results. + + > **NOTE:** Even though absolute path is stored, only relative will be shown. + +* `/list` performance has been improved instead of performing the filters with + Haskell, it's now passed to the `find` command. + +* Added logic to request `ISO-8601` timestamps (`UTC`) that are file path safe. + +* Added to website, info tab, a guide on how to setup LSP support for IDE's: + + * https://a-gent.org/info.html#lsp-support-for-ides + +* Due to future `git-worktree` usage, the folder `/tmp/` MUST exist in the root + of the project and it needs to be added to the `.gitignore` file to avoid + `GIT` collisions. + +* Added `Internal.RIO` so the application can execute `RestrictedIO`, but, + consumers of the `Λ-gent` package will NOT. + +* All `Context` properties, except `load`, have now `internal` constructor + types. This will ensure that we will know that they have been instantiated by + the `Λ-gents`. + +* From `0.11.0.6 -- 2026-03-20` below: + + > **NOTE**: Fix is not verified. Well, this update will confirm (or not). + + * Package is NO longer marked as broken: **NOTE**: Changes to current existing Λ-gent scripts can be done by just + > post-fixing `Nothing`. Example: `replWithMode Echo eval Nothing` + +## 0.11.0.7 -- 2026-03-30 + * We seem to have fixed multi-line issues. I guess we can say that we are probably as good as `GHCi`. @@ -21,7 +70,7 @@ * `CTRL + D` equivalent to `DELETE`. -## 0.11.0.6 -- 2026-03-20 +## 0.11.0.6 -- 2026-03-20 * Added a `todo.org` file in the root folder of the project. This will allow to see current, but also future, status of the project. @@ -51,11 +100,11 @@ * Added `Agent.Utils` modules to help for the respective `modes`. This will help keep `Λ-gent` code small by providing ready to plug code bloks. -## 0.11.0.5 -- 2026-03-08 +## 0.11.0.5 -- 2026-03-08 * `ENTER` only triggers if something is typed. -## 0.11.0.4 -- 2026-03-08 +## 0.11.0.4 -- 2026-03-08 * Fixed the `BUG` when trying to print emojii's ('🍎', '🍏', …): @@ -66,7 +115,7 @@ by adding `setLocaleEncoding utf8` to `replWithMode`. Now instead of crashing, invalid `UTF-8` characters will just be shown as single or multiple `?`. -## 0.11.0.3 -- 2026-03-06 +## 0.11.0.3 -- 2026-03-06 * Made `read` usable by providing support for: @@ -77,7 +126,7 @@ * Move to start and end of the text with `HOME` and `END`. -## 0.11.0.2 -- 2026-03-05 +## 0.11.0.2 -- 2026-03-05 * Fixed issue with Hackage. The project now builds for: * `ghc-9.4.8` @@ -86,12 +135,12 @@ * `ghc-9.10.3` * `ghc-9.12.2` -## 0.11.0.1 -- 2026-03-05 +## 0.11.0.1 -- 2026-03-05 * Issue with Hackage. Since the service builds with `9.8.4` we have to comply with that. -## 0.11.0.0 -- 2026-03-04 +## 0.11.0.0 -- 2026-03-04 * Initial release after feedback from the NixOS Copenhagen User Group, March meetup: diff --git a/src/Agent/Data/ANSI/EscapeCode.hs b/src/Agent/Data/ANSI/EscapeCode.hs new file mode 100644 --- /dev/null +++ b/src/Agent/Data/ANSI/EscapeCode.hs @@ -0,0 +1,217 @@ +{-# OPTIONS_GHC -Wall -Werror #-} + +{-# LANGUAGE NoGeneralizedNewtypeDeriving #-} +{-# LANGUAGE Safe #-} + +-------------------------------------------------------------------------------- + +-- | +-- Copyright : (c) 2026 SPISE MISU ApS +-- License : SSPL-1.0 OR AGPL-3.0-only +-- Maintainer : SPISE MISU +-- Stability : experimental + +-------------------------------------------------------------------------------- + +module Agent.Data.ANSI.EscapeCode + ( Colour + ( Black + , Red + , Green + , Yellow + , Blue + , Magenta + , Cyan + , White + ) + , Frecuency + ( Slow + , Fast + ) + -- + , sgr + -- + , foreground + , background + , bold + , faint + , italic + , underline + , blink + ) +where + +-------------------------------------------------------------------------------- + +data Colour + = Black + | Red + | Green + | Yellow + | Blue + | Magenta + | Cyan + | White + deriving (Eq) + +instance Enum Colour where + fromEnum Black = 0 + fromEnum Red = 1 + fromEnum Green = 2 + fromEnum Yellow = 3 + fromEnum Blue = 4 + fromEnum Magenta = 5 + fromEnum Cyan = 6 + fromEnum White = 7 + + toEnum 0 = Black + toEnum 1 = Red + toEnum 2 = Green + toEnum 3 = Yellow + toEnum 4 = Blue + toEnum 5 = Magenta + toEnum 6 = Cyan + toEnum 7 = White + toEnum _ = error "Colour code not supported" + +type Bright = Bool + +data Background = BG !Bool Bright Colour +data Foreground = FG !Bool Bright Colour + +data Frecuency + = Slow + | Fast + +data Blink = B !Bool Frecuency + +data SelectGraphicRendition + = SGR !Background !Foreground !Bool !Bool !Bool !Bool !Blink String + +instance Show SelectGraphicRendition where + show (SGR bg fg bo fa it un bl text) = + "\ESC[" ++ + "0" ++ + (cb bg) ++ + (cf fg) ++ + (fb bo) ++ + (ff fa) ++ + (fi it) ++ + (fu un) ++ + (bf bl) ++ + "m" ++ + text ++ + "\ESC[00m" + where + cb (BG True True c) = ";" ++ (show $ 60 + 40 + fromEnum c) + cb (BG True False c) = ";" ++ (show $ 40 + fromEnum c) + cb (BG False _____ _) = [ ] + cf (FG True True c) = ";" ++ (show $ 60 + 30 + fromEnum c) + cf (FG True False c) = ";" ++ (show $ 30 + fromEnum c) + cf (FG False _____ _) = [ ] + fb True = ";01" + fb False = [ ] + ff True = ";02" + ff False = [ ] + fi True = ";03" + fi False = [ ] + fu True = ";04" + fu False = [ ] + bf (B True Slow) = ";05" + bf (B True Fast) = ";06" + bf (B False ____) = [ ] + +-------------------------------------------------------------------------------- + +sgr + :: String + -> SelectGraphicRendition + +foreground + :: Bright + -> Colour + -> SelectGraphicRendition + -> SelectGraphicRendition + +background + :: Bright + -> Colour + -> SelectGraphicRendition + -> SelectGraphicRendition + +bold + :: SelectGraphicRendition + -> SelectGraphicRendition + +faint + :: SelectGraphicRendition + -> SelectGraphicRendition + +italic + :: SelectGraphicRendition + -> SelectGraphicRendition + +underline + :: SelectGraphicRendition + -> SelectGraphicRendition + +blink + :: Frecuency + -> SelectGraphicRendition + -> SelectGraphicRendition + +-------------------------------------------------------------------------------- +sgr = + SGR bg fg bo fa it un bl + where + fg = FG False undefined undefined + bg = BG False undefined undefined + bo = False + fa = False + it = False + un = False + bl = B False undefined + +-------------------------------------------------------------------------------- + +foreground b c (SGR bg __ bo fa it un bl txt) = + SGR bg fg bo fa it un bl txt + where + fg = FG True b c + +background b c (SGR __ fg bo fa it un bl txt) = + SGR bg fg bo fa it un bl txt + where + bg = BG True b c + +bold (SGR bg fg __ fa it un bl txt) = + SGR bg fg bo fa it un bl txt + where + bo = True + +faint (SGR bg fg bo __ it un bl txt) = + SGR bg fg bo fa it un bl txt + where + fa = True + +italic (SGR bg fg bo fa __ un bl txt) = + SGR bg fg bo fa it un bl txt + where + it = True + +underline (SGR bg fg bo fa it __ bl txt) = + SGR bg fg bo fa it un bl txt + where + un = True + +blink f (SGR bg fg bo fa it un __ txt) = + SGR bg fg bo fa it un bl txt + where + bl = B True f + +-------------------------------------------------------------------------------- + +-- References +-- +-- ANSI escape code: +-- * https://en.wikipedia.org/wiki/ANSI_escape_code#SGR_parameters diff --git a/src/Agent/IO/Effects.hs b/src/Agent/IO/Effects.hs --- a/src/Agent/IO/Effects.hs +++ b/src/Agent/IO/Effects.hs @@ -35,12 +35,17 @@ -------------------------------------------------------------------------------- + +import qualified Internal.LLM as LLM + +-------------------------------------------------------------------------------- + class Monad m => LlmConf m where llmPathCWD - :: m (Maybe String) + :: m (Maybe LLM.Root) -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- @@ -93,11 +98,11 @@ => LlmCodeRead m where llmCodeSeq - :: Maybe String - -> m (Either String [ String ]) + :: Maybe LLM.Filter + -> m (Either [String] LLM.Files) llmCodeGet :: String - -> m (Either String String) + -> m (Either String LLM.File) -------------------------------------------------------------------------------- @@ -136,15 +141,16 @@ ( LlmConf m , LlmPlanRoot m , LlmPlanMask m + , LlmCodeRead m ) => LlmPlanRead m where llmPlanSeq - :: Maybe String - -> m (Either String [ String ]) + :: Maybe LLM.Filter + -> m (Either [String] LLM.Files) llmPlanGet :: String - -> m (Either String String) + -> m (Either String LLM.File) -------------------------------------------------------------------------------- diff --git a/src/Agent/IO/Restricted.hs b/src/Agent/IO/Restricted.hs --- a/src/Agent/IO/Restricted.hs +++ b/src/Agent/IO/Restricted.hs @@ -3,1129 +3,83 @@ {-# LANGUAGE NoGeneralizedNewtypeDeriving #-} {-# LANGUAGE Safe #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# LANGUAGE MonoLocalBinds #-} - -{-# LANGUAGE LambdaCase #-} - --------------------------------------------------------------------------------- - --- | --- Copyright : (c) 2026 SPISE MISU ApS --- License : SSPL-1.0 OR AGPL-3.0-only --- Maintainer : SPISE MISU --- Stability : experimental --- --- Safe {H}askell --- --- https://simonmar.github.io/bib/safe-haskell-2012_abstract.html --- --- (David Terei, David Mazières, Simon Marlow, Simon Peyton Jones) Haskell ’12: --- Proceedings of the Fifth ACM SIGPLAN Symposium on Haskell, Copenhagen, --- Denmark, ACM, 2012 --- --- Though Haskell is predominantly type-safe, implementations contain a few --- loopholes through which code can bypass typing and module encapsulation. This --- paper presents Safe Haskell, a language extension that closes these --- loopholes. Safe Haskell makes it possible to confine and safely execute --- untrusted, possibly malicious code. By strictly enforcing types, Safe Haskell --- allows a variety of different policies from API sandboxing to --- information-flow control to be implemented easily as monads. Safe Haskell is --- aimed to be as unobtrusive as possible. It enforces properties that --- programmers tend to meet already by convention. We describe the design of --- Safe Haskell and an implementation (currently shipping with GHC) that infers --- safety for code that lies in a safe subset of the language. We use Safe --- Haskell to implement an online Haskell interpreter that can securely execute --- arbitrary untrusted code with no overhead. The use of Safe Haskell greatly --- simplifies this task and allows the use of a large body of existing code and --- tools. - --------------------------------------------------------------------------------- - -module Agent.IO.Restricted - ( RIO () - , run - -- * Environment - , getEnvVar - -- * Read/Print - , input - , output - -- * LLM (Config) - , llmPathCWD - -- * LLM (Chat) - , llmChatKey, llmChatAPI - , llmChatWeb - -- * LLM (Code) - , llmCodeDir - , llmCodeMsk - , llmCodeSeq, llmCodeGet - -- * LLM (Plan) - , llmPlanDir - , llmPlanMsk - , llmPlanSeq, llmPlanGet - , llmPlanKey, llmPlanAPI - , llmPlanWeb - ) -where - --------------------------------------------------------------------------------- - -import Data.Either ( partitionEithers ) -import Data.List ( isInfixOf ) -import Data.Maybe ( fromMaybe, maybeToList ) -import qualified System.Environment.Blank as ENV -import System.Exit - ( ExitCode (ExitFailure, ExitSuccess) - ) -import System.IO ( hFlush, hReady, stdin, stdout ) -import System.Process - ( CreateProcess (cwd) - , proc - , readCreateProcessWithExitCode - , readProcessWithExitCode - ) -import Text.Read ( readMaybe ) - -import qualified Agent.IO.Effects as EFF -import qualified Agent.Utils.Common as COM - - --------------------------------------------------------------------------------- - -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: - -- "\ESC[#;#R" => "\ESC" and "[#;#R" (only parse last) - maybeToList - ( readMaybe (f str) >>= \ y -> - readMaybe (g str) >>= \ x -> - Just - ( Position y x - , h str - ) - ) - where - f = takeWhile (/= ';') . drop 1 . dropWhile (/= '[') - g = takeWhile (/= 'R') . drop 1 . dropWhile (/= ';') - h = drop 1 . dropWhile (/= 'R') . dropWhile (/= ';') . dropWhile (/= '[') - --------------------------------------------------------------------------------- - -data MultiLine = - MultiLine - { stx :: Maybe Position - , cur :: Maybe Position - , etx :: Maybe Position - , col :: Int - } - deriving Show - --------------------------------------------------------------------------------- --------------------------------------------------------------------------------- - -class StdIn m where - input - :: [ String ] - -> [ String ] - -> m String - -class StdOut m where - output - :: String - -> m () - --------------------------------------------------------------------------------- - -instance StdIn RIO where - -- BUG: Issue with multiline text - input prev next = - -- NOTE: "\ESC7" - save cursor position (SCO) - -- - https://gist.github.com/fnky/458719343aabd01cfb17a3a4f7296797#cursor-controls - RestrictedIO $ putStr "\ESC7" >> aux gen prev next [] [] - where - msv = 32767 :: Int - gen = - MultiLine - { stx = Nothing - , cur = Nothing - , etx = Nothing - , col = 0 - } - aux mlp hps hns bcs acs = - key >>= \ k -> - case (k < ['\32'], k) of - (True , ['\^H']) -> - case bcs of - -- NOTE: CTRL + H or Backspace (remove char if any and re-write - -- after chars) - [ ] -> aux mlp hps hns bcs acs - (_:cs) -> - hFlush stdout >> - -- NOTE: 0) Print "\ESC[6n" position before action - putStr "\ESC[6n" >> - -- NOTE: Remove char - putChar '\^H' >> - -- NOTE: Save position - putStr "\ESC7" >> - -- NOTE: Clear rest of screen from position - putStr "\ESC[0J" >> - -- NOTE: Print after chars - putStr acs >> - -- NOTE: 1) Print "\ESC[6n" end position after action - putStr "\ESC[6n" >> - -- NOTE: 2) Print "\ESC[6n" column witdh - putStr ("\ESC[" ++ show msv ++ "C") >> - putStr "\ESC[6n" >> - -- NOTE: Go back to saved position - putStr "\ESC8" >> - -- NOTE: 3) Print "\ESC[6n" current position after action - putStr "\ESC[6n" >> hFlush stdout >> - aux mlp hps hns cs acs - (True , ['\^J']) -> - -- NOTE: ENTER (line feed) only if something is typed - case (bcs, acs) of - ([], []) -> - aux mlp hps hns bcs acs - ________ -> - pure $ (++ acs) $ reverse $ bcs - (True , ['\^L']) -> - -- NOTE: CTRL + L (form feed) becomes "/w" (clear screen) - pure $ "/wipe" - (True , ['\^U']) -> - -- NOTE: CTRL + U cut text to start - hFlush stdout >> - -- NOTE: 0) Print "\ESC[6n" position before action - putStr "\ESC[6n" >> - -- NOTE: Go back to start of line - putStr hom >> hFlush stdout >> - -- NOTE: Save position - putStr "\ESC7" >> - -- NOTE: Clear rest of screen from position - putStr "\ESC[0J" >> - -- NOTE: Print after chars - putStr acs >> - -- NOTE: 1) Print "\ESC[6n" end position after action - putStr "\ESC[6n" >> - -- NOTE: 2) Print "\ESC[6n" column witdh - putStr ("\ESC[" ++ show msv ++ "C") >> - putStr "\ESC[6n" >> - -- NOTE: Go back to saved position - putStr "\ESC8" >> - -- NOTE: 3) Print "\ESC[6n" current position after action - putStr "\ESC[6n" >> hFlush stdout >> - aux mlp hps hns [] acs - where - hom = - case mlp of - MultiLine { stx = Just (Position y x) } -> - "\ESC[" ++ show y ++ ";" ++ show x ++ "H" - _______________________________________ -> - "\ESC8" - (True , ['\^K']) -> - -- NOTE: CTRL + K cut text to end - hFlush stdout >> - -- NOTE: 0) Print "\ESC[6n" position before action - putStr "\ESC[6n" >> - -- NOTE: Save position - putStr "\ESC7" >> - -- NOTE: Clear rest of screen from position - putStr "\ESC[0J" >> - -- NOTE: 1) Print "\ESC[6n" end position after action - putStr "\ESC[6n" >> - -- NOTE: 2) Print "\ESC[6n" column witdh - putStr ("\ESC[" ++ show msv ++ "C") >> - putStr "\ESC[6n" >> - -- NOTE: Go back to saved position - putStr "\ESC8" >> - -- NOTE: 3) Print "\ESC[6n" current position after action - putStr "\ESC[6n" >> hFlush stdout >> - aux mlp hps hns bcs [] - (True , ['\ESC','[','H']) -> - -- NOTE: HOME - -- - -- NOTE: Move to start of text - putStr hom >> - -- NOTE: Update current position - putStr "\ESC[6n" >> 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) } - , "\ESC[" ++ show y ++ ";" ++ show x ++ "H" - ) - _______________________________________ -> - ( mlp - , "\ESC8" - ) - (True , ['\ESC','[','F']) -> - -- NOTE: END - -- - -- NOTE: Move to end of text - hFlush stdout >> - putStr hom >> - -- NOTE: Update current position - putStr "\ESC[6n" >> 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) } - , "\ESC[" ++ show y ++ ";" ++ show x ++ "H" - ) - _______________________________________ -> - ( mlp - , "\ESC8" - ) - (True , ['\^A']) -> - -- NOTE: CTRL + A to move to start of text - -- - -- TODO: DRY as equal to HOME - -- NOTE: Move to start of text - hFlush stdout >> - putStr hom >> - -- NOTE: Update current position - putStr "\ESC[6n" >> 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) } - , "\ESC[" ++ show y ++ ";" ++ show x ++ "H" - ) - _______________________________________ -> - ( mlp - , "\ESC8" - ) - (True , ['\^E']) -> - -- NOTE: CTRL + E to move to end of text - -- - -- TODO: DRY as equal to END - -- NOTE: Move to end of text - hFlush stdout >> - putStr hom >> - -- NOTE: Update current position - putStr "\ESC[6n" >> 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) } - , "\ESC[" ++ show y ++ ";" ++ show x ++ "H" - ) - _______________________________________ -> - ( mlp - , "\ESC8" - ) - (True , ['\ESC','[','A']) -> - -- NOTE: Allowed escaped sequences: Arrow "↑" - case (hps, hns) of - ([ ], _) -> aux mlp hps hns bcs acs - (p:ps, _) -> - hFlush stdout >> - -- NOTE: 0) Print "\ESC[6n" position before action - putStr "\ESC[6n" >> - -- NOTE: Move to start of text - putStr hom >> - -- NOTE: Print previous line - putStr p >> - -- NOTE: Save position - putStr "\ESC7" >> - -- NOTE: Clear rest of screen from position - putStr "\ESC[0J" >> - -- NOTE: Print after chars - putStr [] >> - -- NOTE: 1) Print "\ESC[6n" end position after action - putStr "\ESC[6n" >> - -- NOTE: 2) Print "\ESC[6n" column witdh - putStr ("\ESC[" ++ show msv ++ "C") >> - putStr "\ESC[6n" >> - -- NOTE: Go back to saved position - putStr "\ESC8" >> - -- NOTE: 3) Print "\ESC[6n" current position after action - putStr "\ESC[6n" >> hFlush stdout >> - aux mlp ps (p:hns) rev [] - where - rev = reverse p - hom = - case mlp of - MultiLine { stx = Just (Position y x) } -> - "\ESC[" ++ show y ++ ";" ++ show x ++ "H" - _______________________________________ -> - "\ESC8" - (True , ['\ESC','[','B']) -> - -- NOTE: Allowed escaped sequences: Arrow "↓" - case (hps, hns) of - (_, [ ]) -> aux mlp hps hns bcs acs - (_, p:ps) -> - hFlush stdout >> - -- NOTE: 0) Print "\ESC[6n" position before action - putStr "\ESC[6n" >> - -- NOTE: Move to start of text - putStr hom >> - -- NOTE: Print previous line - putStr p >> - -- NOTE: Save position - putStr "\ESC7" >> - -- NOTE: Clear rest of screen from position - putStr "\ESC[0J" >> - -- NOTE: Print after chars - putStr [] >> - -- NOTE: 1) Print "\ESC[6n" end position after action - putStr "\ESC[6n" >> - -- NOTE: 2) Print "\ESC[6n" column witdh - putStr ("\ESC[" ++ show msv ++ "C") >> - putStr "\ESC[6n" >> - -- NOTE: Go back to saved position - putStr "\ESC8" >> - -- NOTE: 3) Print "\ESC[6n" current position after action - putStr "\ESC[6n" >> hFlush stdout >> - aux mlp (p:hps) ps rev [] - where - rev = reverse p - hom = - case mlp of - MultiLine { stx = Just (Position y x) } -> - "\ESC[" ++ show y ++ ";" ++ show x ++ "H" - _______________________________________ -> - "\ESC8" - (True , ['\ESC','[','C']) -> - -- NOTE: Allowed escaped sequences: Arrow "→" - case (bcs, acs) of - (_, [ ]) -> - aux mlp hps hns bcs acs - (_, c:cs) -> - hFlush stdout >> - ( if pl then - putStr ("\ESC[" ++ "1" ++ "E") - else - putStr k - ) >> - -- NOTE: Update current position - putStr "\ESC[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 - (True , ['\ESC','[','D']) -> - -- NOTE: Allowed escaped sequences: Arrow "←" - case (bcs, acs) of - ([ ], _) -> - aux mlp hps hns bcs acs - (c:cs, _) -> - hFlush stdout >> - ( if pl then - putStr ("\ESC[" ++ "1" ++ "F") >> - putStr ("\ESC[" ++ show msv ++ "C") - else - putStr k - ) >> - -- NOTE: Update current position - putStr "\ESC[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 - - (True , ['\ESC','[','1',';','5','C']) -> - -- NOTE: Allowed escaped sequences: CTRL + Arrow "→" - -- NOTE: Move to end of text - hFlush stdout >> - putStr np >> - -- NOTE: Update current position - putStr "\ESC[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) -> - "\ESC[" ++ show y ++ ";" ++ show x ++ "H" - where - y = cy + 1 - x = lc - (cw - cx) - __________ -> - "\ESC[" ++ show y ++ ";" ++ show x ++ "H" - where - y = cy - x = cx + lc - ___ -> [] - - (True , ['\ESC','[','1',';','5','D']) -> - -- NOTE: Allowed escaped sequences: CTRL + Arrow "←" - hFlush stdout >> - putStr np >> - -- NOTE: Update current position - putStr "\ESC[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) -> - "\ESC[" ++ show y ++ ";" ++ show x ++ "H" - where - y = cy - 1 - x = cw - (lc - cx) - __________ -> - "\ESC[" ++ show y ++ ";" ++ show x ++ "H" - where - y = cy - x = cx - lc - ___ -> [] - (True , ['\ESC','[','3','~']) -> - -- NOTE: CTRL + D behave as delete key - -- TODO: Use DRY - 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 "\ESC[6n" position before action - putStr "\ESC[6n" >> - -- NOTE: Save position - putStr "\ESC7" >> - -- NOTE: Clear rest of screen from position - putStr "\ESC[0J" >> - -- NOTE: Print after chars - putStr cs >> - -- NOTE: 1) Print "\ESC[6n" end position after action - putStr "\ESC[6n" >> - -- NOTE: 2) Print "\ESC[6n" column witdh - putStr ("\ESC[" ++ show msv ++ "C") >> - putStr "\ESC[6n" >> - -- NOTE: Go back to saved position - putStr "\ESC8" >> - -- NOTE: 3) Print "\ESC[6n" current position after action - putStr "\ESC[6n" >> hFlush stdout >> - aux mlp hps hns bcs cs - (True , ['\^D']) -> - -- NOTE: CTRL + D behave as delete key - -- TODO: Use DRY - 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 "\ESC[6n" position before action - putStr "\ESC[6n" >> - -- NOTE: Save position - putStr "\ESC7" >> - -- NOTE: Clear rest of screen from position - putStr "\ESC[0J" >> - -- NOTE: Print after chars - putStr cs >> - -- NOTE: 1) Print "\ESC[6n" end position after action - putStr "\ESC[6n" >> - -- NOTE: 2) Print "\ESC[6n" column witdh - putStr ("\ESC[" ++ show msv ++ "C") >> - putStr "\ESC[6n" >> - -- NOTE: Go back to saved position - putStr "\ESC8" >> - -- NOTE: 3) Print "\ESC[6n" current position after action - putStr "\ESC[6n" >> hFlush stdout >> - aux mlp hps hns bcs cs - (True , '\ESC':ps) -> - -- NOTE: Other escaped sequences (skip unless positions) - aux mln hps hns bcs acs - where - ops = map readMaybe $ COM.split '\ESC' ps :: [Maybe Position] - mln = - -- NOTE: 0) Print "\ESC[6n" position before action (unused) - -- NOTE: 1) Print "\ESC[6n" end position after action - -- NOTE: 2) Print "\ESC[6n" column witdh - -- NOTE: 3) Print "\ESC[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 - (True , _) -> - aux mlp hps hns bcs acs - (False, ['\DEL']) -> - -- NOTE: DELETE (skip) - aux mlp hps hns bcs acs - (False, _) -> - hFlush stdout >> - -- NOTE: 0) Print "\ESC[6n" position before action - putStr "\ESC[6n" >> - -- NOTE: Type key or text - putStr k >> - -- NOTE: Save position - putStr "\ESC7" >> - -- NOTE: Clear rest of screen from position - putStr "\ESC[0J" >> - -- NOTE: Print after chars - putStr acs >> - -- NOTE: 1) Print "\ESC[6n" end position after action - putStr "\ESC[6n" >> - -- NOTE: 2) Print "\ESC[6n" column witdh - putStr ("\ESC[" ++ show msv ++ "C") >> - putStr "\ESC[6n" >> - -- NOTE: Go back to saved position - putStr "\ESC8" >> - -- NOTE: 3) Print "\ESC[6n" current position after action - putStr "\ESC[6n" >> hFlush stdout >> - aux mlp hps hns (reverse k ++ bcs) acs - key = - -- NOTE: https://stackoverflow.com/a/38553473 - 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 String) - -instance - EFF.LlmConf RIO - => LlmConf RIO - where - llmPathCWD = 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.LlmConf m - , EFF.LlmCodeRoot m - , EFF.LlmCodeMask m - ) - => LlmCodeRead m - where - llmCodeSeq - :: Maybe String - -> m (Either String [ String ]) - llmCodeGet - :: String - -> m (Either String String) - -instance - ( EFF.LlmConf RIO - , EFF.LlmCodeRoot RIO - , EFF.LlmCodeMask RIO - ) - => LlmCodeRead RIO - where - llmCodeSeq mfilter = - EFF.llmPathCWD >>= \ ocwd -> - EFF.llmCodeDir >>= \ cdir -> - EFF.llmCodeMsk >>= \ cmsk -> - realPath (fromMaybe [] ocwd ++ "/" ++ cdir) >>= \ efrp -> - case efrp of - Right frp -> - ( \ case - ([], rs) -> - Right $ concat rs - (ls, __) -> - Left $ foldl1 (\ x y -> x ++ "\n" ++ y) ls - ) - . partitionEithers - . map - ( \ case - Right fns -> - case mfilter of - Nothing -> Right rel - Just fil -> Right $ filter (isInfixOf fil) rel - where - rel = map (cdir ++ ) fns - Left err -> - Left err - ) - <$> mapM (findFiles frp) cmsk - Left err -> - pure $ Left err - - llmCodeGet relpath = - EFF.llmPathCWD >>= \ ocwd -> - realPath (fromMaybe [] ocwd) >>= \ efrp -> - case efrp of - Right frp -> - Right <$> readFileStrict (frp ++ "/" ++ relpath) - Left err -> - pure $ Left err - --------------------------------------------------------------------------------- --------------------------------------------------------------------------------- - -class - EFF.LlmConf m - => LlmPlanRoot m - where - llmPlanDir - :: m String - -instance - ( EFF.LlmConf RIO - , EFF.LlmPlanRoot RIO - ) - => LlmPlanRoot RIO - where - llmPlanDir = pure "llm" - --------------------------------------------------------------------------------- - -class - EFF.LlmConf m - => LlmPlanMask m - where - llmPlanMsk - :: m [ String ] - -instance - ( EFF.LlmConf RIO - , EFF.LlmPlanMask RIO - ) - => LlmPlanMask RIO - where - llmPlanMsk = pure [ "plan_*.md" ] - --------------------------------------------------------------------------------- - -class - ( EFF.LlmConf m - , EFF.LlmPlanRoot m - , EFF.LlmPlanMask m - ) - => LlmPlanRead m - where - llmPlanSeq - :: Maybe String - -> m (Either String [ String ]) - llmPlanGet - :: String - -> m (Either String String) - -instance - ( EFF.LlmConf RIO - , EFF.LlmPlanRoot RIO - , EFF.LlmPlanMask RIO - ) - => LlmPlanRead RIO - where - llmPlanSeq mfilter = - EFF.llmPathCWD >>= \ ocwd -> - EFF.llmPlanDir >>= \ pdir -> - EFF.llmPlanMsk >>= \ pmsk -> - realPath (fromMaybe [] ocwd ++ "/" ++ pdir) >>= \ efrp -> - case efrp of - Right frp -> - ( \ case - ([], rs) -> - Right $ concat rs - (ls, __) -> - Left $ foldl1 (\ x y -> x ++ "\n" ++ y) ls - ) - . partitionEithers - . map - ( \ case - Right fns -> - case mfilter of - Nothing -> Right rel - Just fil -> Right $ filter (isInfixOf fil) rel - where - rel = map (pdir ++ ) fns - Left err -> - Left err - ) - <$> mapM (findFiles frp) pmsk - Left err -> - pure $ Left err - - llmPlanGet path = - EFF.llmPathCWD >>= \ ocwd -> - EFF.llmPlanDir >>= \ pdir -> - realPath (fromMaybe [] ocwd ++ "/" ++ pdir) >>= \ efrp -> - case efrp of - Right rp -> - if rp `isInfixOf` path then - Right <$> readFileStrict path - else - pure $ Left $ "File: " ++ path ++ " is not in: " ++ rp - Left err -> - pure $ Left err - --------------------------------------------------------------------------------- - -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.llmPathCWD >>= \ ocwd -> - realPath (fromMaybe [] ocwd) >>= \ efrp -> - case efrp of - Right rp -> - gitExist rp >>= \ git -> - if git then - EFF.llmPlanAPI >>= \ mapi -> - EFF.llmPlanKey >>= \ mkey -> - llmCurl json mapi mkey - else - pure $ Left "No GIT repo initialized" - Left err -> - pure $ Left err - --------------------------------------------------------------------------------- --------------------------------------------------------------------------------- - --- HELPERS (public) - -getEnvVar - :: String - -> RIO (Maybe String) -getEnvVar = - RestrictedIO . ENV.getEnv - --------------------------------------------------------------------------------- - --- HELPERS (private) - -findFiles - :: String - -> 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: Relative paths instead of full - $ map (filter (/= '\NUL') . drop (length path)) - $ lines str - Left err -> - Left err - ) - <$> withExitCodeAndCWD path "find" - [ path - , "-name" - , mask - ] - -gitExist - :: String - -> RIO Bool -gitExist path = - ( \case - Right _ -> True - Left _ -> False - ) - <$> withExitCodeAndCWD path "git" - [ "status" - ] - -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) -> - withExitCode "curl" - ( [ "--silent" - , "--show-error" - ] - ++ hs ++ - [ "--data", json - , api ++ "/chat/completions" - ] - ) - (Just api, Just key) -> - withExitCode "curl" - ( [ "--silent" - , "--show-error" - , "--header", "\"Authorization: \"" ++ key ++ "\"" - ] - ++ hs ++ - [ "--data", json - , api ++ "/chat/completions" - ] - ) - 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 = - -- NOTE: «Too Many Open Files» error in Linux - -- - -- - http://woshub.com/too-many-open-files-error-linux/ - RestrictedIO $ - readFile path >>= \cs -> - length cs `seq` pure cs - -realPath - :: String - -> RIO (Either String String) -realPath path = - -- NOTE: Remove any '\NUL` from filepaths - -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/10110 - ( \case - Right str -> Right $ filter (/= '\NUL') str - Left err -> Left err - ) - <$> withExitCode "realpath" - [ "--canonicalize-existing" - , "--logical" - , "--physical" - -- NOTE: End each output line with NUL, not newline - , "--zero" - , path - ] - -withExitCode - :: String - -> [String] - -> RIO (Either String String) -withExitCode cmd args = - RestrictedIO $ - do - (exitcode, out, err) <- readProcessWithExitCode cmd args [] - case exitcode of - ExitSuccess -> - pure $ Right out - ExitFailure _ -> - pure $ Left err - -withExitCodeAndCWD - :: String - -> String - -> [String] - -> RIO (Either String String) -withExitCodeAndCWD path cmd args = - RestrictedIO $ - do - (exitcode, out, err) <- readCreateProcessWithExitCode rcp [] - case exitcode of - ExitSuccess -> - pure $ Right out - ExitFailure _ -> - pure $ Left err - where - raw = proc cmd args - rcp = raw { cwd = Just path } +-------------------------------------------------------------------------------- + +-- | +-- Copyright : (c) 2026 SPISE MISU ApS +-- License : SSPL-1.0 OR AGPL-3.0-only +-- Maintainer : SPISE MISU +-- Stability : experimental +-- +-- Safe {H}askell +-- +-- https://simonmar.github.io/bib/safe-haskell-2012_abstract.html +-- +-- (David Terei, David Mazières, Simon Marlow, Simon Peyton Jones) Haskell ’12: +-- Proceedings of the Fifth ACM SIGPLAN Symposium on Haskell, Copenhagen, +-- Denmark, ACM, 2012 +-- +-- Though Haskell is predominantly type-safe, implementations contain a few +-- loopholes through which code can bypass typing and module encapsulation. This +-- paper presents Safe Haskell, a language extension that closes these +-- loopholes. Safe Haskell makes it possible to confine and safely execute +-- untrusted, possibly malicious code. By strictly enforcing types, Safe Haskell +-- allows a variety of different policies from API sandboxing to +-- information-flow control to be implemented easily as monads. Safe Haskell is +-- aimed to be as unobtrusive as possible. It enforces properties that +-- programmers tend to meet already by convention. We describe the design of +-- Safe Haskell and an implementation (currently shipping with GHC) that infers +-- safety for code that lies in a safe subset of the language. We use Safe +-- Haskell to implement an online Haskell interpreter that can securely execute +-- arbitrary untrusted code with no overhead. The use of Safe Haskell greatly +-- simplifies this task and allows the use of a large body of existing code and +-- tools. + +-------------------------------------------------------------------------------- + +module Agent.IO.Restricted + ( RIO + -- , run + -- * Environment + , getEnvVar + -- * LLM (Config) + , llmPathCWD + -- * LLM (Chat) + , llmChatKey, llmChatAPI + , llmChatWeb + -- * LLM (Code) + , llmCodeDir + , llmCodeMsk + , llmCodeSeq, llmCodeGet + -- * LLM (Plan) + , llmPlanDir + , llmPlanMsk + , llmPlanSeq, llmPlanGet + , llmPlanKey, llmPlanAPI + , llmPlanWeb + ) +where + +-------------------------------------------------------------------------------- + +import Internal.RIO ( RIO ) + +import Internal.RIO ( getEnvVar ) + +import Internal.RIO + ( llmChatAPI + , llmChatKey + , llmChatWeb + , llmCodeDir + , llmCodeGet + , llmCodeMsk + , llmCodeSeq + , llmPathCWD + , llmPlanAPI + , llmPlanDir + , llmPlanGet + , llmPlanKey + , llmPlanMsk + , llmPlanSeq + , llmPlanWeb + ) diff --git a/src/Agent/LLM.hs b/src/Agent/LLM.hs --- a/src/Agent/LLM.hs +++ b/src/Agent/LLM.hs @@ -5,7 +5,7 @@ {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE LambdaCase #-} -------------------------------------------------------------------------------- @@ -22,16 +22,21 @@ module Agent.LLM ( -- * Modes - Mode(..) + INT.Mode(..) -- * Context , Load , History(..) , Context(..) + , INT.files -- * Paramenters , Eval -- * Methods , repl , replWithMode + , rootPath + -- * Helpers + , combineFiles + , getFile ) where @@ -59,69 +64,44 @@ import Text.Read ( readMaybe ) import Internal.GaloisInc.Text.JSON.Generic ( Data ) - -import Agent.IO.Restricted +import Internal.LLM + ( Chit (..) + , History (..) + , Template (..) + , View (..) + , modes + ) +import qualified Internal.LLM as INT +import Internal.RIO ( RIO (..) + , findFiles , input , output + , readFileStrict ) + +import qualified Agent.Data.ANSI.EscapeCode as AEC +import qualified Agent.JSON as JSON import qualified Agent.Utils.Common as COM -------------------------------------------------------------------------------- -data Mode - = Auto - | Chat - | Code - | Docs - | Echo - | Plan - | Test - deriving (Bounded, Enum, Eq, Read, Show) - type Load a = ( Data a , Show a ) => Maybe a -data View - = None - | Both - | Chit' - | Chat' - -data Chit = - Chit - { prev :: [String] - -- TODO: add: yank :: Maybe String to store cutted text? - , next :: [String] - } - -type Chat = [String] - -data History = - History - { view :: View - , chit :: Chit - , chat :: Chat - } - -type Index = Int - -type Numbers = Bool - -type Filter = String - data Context a = Context - { exit :: Bool - , mode :: Mode - , load :: Load a - , hist :: History - , list :: Maybe Filter - , safe :: Maybe Filter - , file :: Maybe (Index, Numbers) + { exit :: !INT.Exit + , root :: !(Maybe INT.Root) + , mode :: !INT.Mode + , load :: !(Load a) + , hist :: !INT.History + , list :: !(Maybe INT.Filter) + , pile :: !(Maybe INT.Files) + , file :: !(Maybe INT.File) } type Eval a = @@ -131,17 +111,25 @@ -------------------------------------------------------------------------------- +rootPath + :: RIO (Maybe INT.Root) + -> IO (Maybe INT.Root) +rootPath = + run + repl :: Eval a + -> Maybe INT.Root -> IO () repl = - replWithMode Chat + replWithMode INT.Chat replWithMode - :: Mode + :: INT.Mode -> Eval a + -> Maybe INT.Root -> IO () -replWithMode mod proc = +replWithMode mod proc mroot = do setLocaleEncoding utf8 hSetBuffering stderr NoBuffering @@ -154,12 +142,13 @@ where ctx = Context - { exit = False + { exit = INT.Exit False + , root = mroot , mode = mod , load = Nothing , hist = History - { view = None + { view = [] , chit = Chit { prev = [] @@ -168,14 +157,31 @@ , chat = [] } , list = Nothing - , safe = Nothing + , pile = Just $ INT.Files [] -- Nothing , file = Nothing } -------------------------------------------------------------------------------- --- HELPERS +-- HELPERS (public) +combineFiles + :: INT.Files + -> INT.Files + -> INT.Files +combineFiles (INT.Files xs) (INT.Files ys) = + INT.Files $ xs ++ ys + +getFile + :: INT.File + -> (FilePath, [INT.FileLine]) +getFile (INT.File f) = + f + +-------------------------------------------------------------------------------- + +-- HELPERS (private) + {- NOTE: Doesn't seem to work ctrlC :: IO () -> IO () ctrlC task = @@ -190,27 +196,46 @@ -> RIO () loop ctx eval = case ctx of - Context { exit = True } -> + Context { exit = INT.Exit True } -> return () - Context { hist = History { view = Both } } -> + Context { hist = History { view = [ Chits, Chats ] } } -> printLn "* Chits:" >> - (mapM_ printLn $ COM.chits True $ prev $ chit $ hist ctx) >> + ( mapM_ printLn . COM.combine . COM.chits True . prev . chit . hist + ) ctx >> printLn "* Chats:" >> - (mapM_ printLn $ COM.chats True $ chat $ hist ctx) >> - loop (ctx { hist = ((hist ctx) { view = None }) }) eval - Context { hist = History { view = Chit' } } -> + ( mapM_ print . COM.combine . COM.chats True . chat . hist + ) ctx >> + loop (ctx { hist = ((hist ctx) { view = [] }) }) eval + Context { hist = History { view = [ Chits ] } } -> printLn "* Chits:" >> - (mapM_ printLn $ COM.chits True $ prev $ chit $ hist ctx) >> - loop (ctx { hist = ((hist ctx) { view = None }) }) eval - Context { hist = History { view = Chat' } } -> + ( mapM_ printLn . COM.combine . COM.chits True . prev . chit . hist + ) ctx >> + loop (ctx { hist = ((hist ctx) { view = [] }) }) eval + Context { hist = History { view = [ Chats ] } } -> printLn "* Chats:" >> - (mapM_ printLn $ COM.chats True $ chat $ hist ctx) >> - loop (ctx { hist = ((hist ctx) { view = None }) }) eval + ( mapM_ printLn . COM.combine . COM.chats True . chat . hist + ) ctx >> + loop (ctx { hist = ((hist ctx) { view = [] }) }) eval + Context { list = Just _, pile = Just _ } -> + eval ctx [ ] >>= \ (upd, _) -> + ( mapM_ printLn . + COM.combine . + COM.files [] True . + -- NOTE: Show relative paths + map (drop (length cwd)) . + concatMap INT.files . + pile + ) upd >> + loop (upd { list = Nothing }) eval + where + cwd = + case root ctx of + Just (INT.Root cs) -> cs + Nothing -> [] Context { list = Just _ } -> - eval ctx [ ] >>= \ (upd, res) -> - printLn res >> - loop (upd { list = Nothing, safe = list ctx }) eval - Context { file = Just _, safe = Just _ } -> + eval ctx [ ] >>= \ (upd, _) -> + loop upd eval + Context { file = Just _ } -> eval ctx [ ] >>= \ (upd, res) -> printLn res >> loop (upd { file = Nothing }) eval @@ -221,18 +246,20 @@ case txt of '/':'m':'o':'d':'e':' ':c:cs -> caseMode txt c cs '/':'m' :' ':c:cs -> caseMode txt c cs - '/':'f':'i':'l':'e' :midx -> caseFile txt midx - '/':'f' :midx -> caseFile txt midx - '/':'n':'u':'m':'s' :midx -> caseNums txt midx - '/':'n' :midx -> caseNums txt midx + '/':'s':'e':'n':'d':' ':mesg -> caseSend txt mesg + '/':'s' :' ':mesg -> caseSend txt mesg + '/':'f':'i':'l':'e' :midx -> caseFile txt midx False + '/':'f' :midx -> caseFile txt midx False + '/':'n':'u':'m':'s' :midx -> caseFile txt midx True + '/':'n' :midx -> caseFile txt midx True '/':'l':'i':'s':'t' :mfil -> caseList txt mfil '/':'l' :mfil -> caseList txt mfil - "/safe" -> caseSafe txt - "/s" -> caseSafe txt - "/hist" -> caseHist txt Both - "/h" -> caseHist txt Both - "/chit" -> caseHist txt Chit' - "/chat" -> caseHist txt Chat' + "/pile" -> casePile txt + "/p" -> casePile txt + "/hist" -> caseHist txt [ Chits, Chats ] + "/h" -> caseHist txt [ Chits, Chats ] + "/chit" -> caseHist txt [ Chits ] + "/chat" -> caseHist txt [ Chats ] "/wipe" -> caseWipe txt "/w" -> caseWipe txt "/help" -> caseHelp txt @@ -245,9 +272,18 @@ where msg = "Command not recognized: " ++ cmd ____________________________ -> - eval ctx txt >>= \ (upd, res) -> + eval ctx xml >>= \ (upd, res) -> printLn res >> loop (nxt txt upd (Just res)) eval + where + tpl = + Template + { purpose = txt + , instructions = [] + , examples = [] + , documents = [] + } + xml = INT.tpl2xml tpl where his = hist ctx chi = chit his @@ -263,46 +299,113 @@ } , chat = case o of - Nothing -> ( chat $ hist c) - Just r -> ((r:) $ chat $ hist c) + Nothing -> chat $ hist c + Just r -> (r:) $ chat $ hist c } } - -- NOTE: Enforce DRY in cases caseMode txt c cs = case mmod of Just mod -> printLn ("Changed to " ++ low ++ "-mode") >> - loop (nxt txt (ctx { mode = mod, safe = Nothing }) Nothing) eval + loop (nxt txt (ctx { mode = mod, pile = Nothing }) Nothing) eval where low = map toLower $ show mod Nothing -> printLn ("Invalid mode: " ++ c:cs) >> loop (nxt txt ctx Nothing) eval where - mmod = readMaybe (toUpper c : map toLower cs) :: Maybe Mode - caseFile txt midx = - case lst of - Just _ -> - loop (nxt txt (ctx { file = (, False) <$> idx }) Nothing) eval - Nothing -> - printLn ("Invalid index") >> - loop (nxt txt ctx Nothing) eval + mmod = readMaybe (toUpper c : map toLower cs) :: Maybe INT.Mode + caseSend txt msg = + pds >>= \ ds -> + tis >>= \ is -> + eval ctx (xml ds (concat is)) >>= \ (upd, res) -> + printLn res >> + loop (nxt txt upd (Just res)) eval where - lst = safe ctx - idx = - case midx of - [ ] -> Nothing - ' ':cs -> readMaybe cs :: Maybe Int - ______ -> Nothing - caseNums txt midx = - case lst of - Just _ -> - loop (nxt txt (ctx { file = (, True) <$> idx }) Nothing) eval - Nothing -> - printLn ("Invalid index") >> - loop (nxt txt ctx Nothing) eval + cwd = + case root ctx of + Just (INT.Root cs) -> cs + Nothing -> [] + pds = + ( mapM + ( \ fap -> + INT.Document . + INT.File . + (,) (drop (length cwd) fap) . + lines + <$> readFileStrict fap + ) . + concatMap INT.files . + pile + ) ctx + + tis = + -- TODO: This need to be refactored + findFiles cwd ("*/tpl/" ++ mod ++ "_instructions_*.json") >>= \ efs -> + case efs of + Right aps -> + mapM (\ ap -> dec <$> readFileStrict ap) aps + Left ___ -> + pure [] + where + mod = (map toLower . show . mode) ctx + dec x = + case JSON.decode x :: Either JSON.DecodeError [String] of + Right xs -> xs + Left __ -> [] + tpl ds is = + Template + { purpose = msg + , instructions = is + , examples = + -- TODO: Look in {root}/tpl/{mode}_examples_*.md + [] + , documents = ds + } + xml xs ys = INT.tpl2xml $ tpl xs ys + + caseFile txt midx nums = + ( case idx of + Just i -> + if 0 <= i && i < length pfs then + let + cwd = + case root ctx of + Just (INT.Root cs) -> cs + Nothing -> [] + fap = pfs !! i + in + readFileStrict fap >>= \ f -> + ( mapM_ printLn . + COM.combine . + COM.file nums + ) f >> + loop + ( nxt txt + ( ctx + { file = + Just + ( INT.File + -- NOTE: Store relative path + ( drop (length cwd) fap + , lines f + ) + ) + } + ) Nothing + ) eval + else + let + m = "Index (" ++ show i ++ ") is out of bounds." + in + printLn m >> + loop (nxt txt ctx Nothing) eval + Nothing -> + printLn "Invalid index" >> + loop (nxt txt ctx Nothing) eval + ) where - lst = safe ctx + pfs = concatMap INT.files $ pile ctx idx = case midx of [ ] -> Nothing @@ -313,11 +416,24 @@ where fil = case mfil of - [ ] -> Just mfil - ' ':cs -> Just cs + [ ] -> Just $ INT.Filter mfil + ' ':cs -> Just $ INT.Filter cs ______ -> Nothing - caseSafe txt = - loop (nxt txt (ctx { list = safe ctx }) Nothing) eval + casePile txt = + ( mapM_ printLn . + COM.combine . + COM.files [] True . + -- NOTE: Show relative paths + map (drop (length cwd)) . + concatMap INT.files . + pile + ) ctx >> + loop (nxt txt ctx Nothing) eval + where + cwd = + case root ctx of + Just (INT.Root cs) -> cs + Nothing -> [] caseHist txt v = loop (nxt txt (ctx { hist = his { view = v } }) Nothing) eval caseWipe txt = @@ -328,19 +444,17 @@ loop (nxt txt ctx Nothing) eval caseExit txt = printLn "Λ-gent will shutdown" >> - loop (nxt txt (ctx { exit = True }) Nothing) eval + loop (nxt txt (ctx { exit = INT.Exit True }) Nothing) eval where -- NOTE: Clear screen & Move top-left - clear = "\ESC[H\ESC[2J" -- NOTE: See `infocmp -x` - prompt = "Λ-" ++ (map toLower $ show $ mode ctx) ++ "> " + clear = "\^[[H\^[[2J" -- NOTE: See `infocmp -x` + prompt = + (show . AEC.bold . AEC.sgr) + ("Λ-" ++ (map toLower . show . mode) ctx ++ "> ") read = input - print = output + print = output . show . AEC.faint . AEC.sgr printLn x = print $ x ++ "\n" -modes :: [Mode] -modes = - [ minBound .. maxBound ] - head :: String head = "# Exit Λ-gent with /e or /exit. For more commands, type /? or /help." @@ -355,9 +469,11 @@ "/h or /hist | View chit-chat (input and output) history\n" ++ " /chit | View chit (input) history\n" ++ " /chat | View chat (output) history\n" ++ - "/s or /safe | Show stored list of files. See /list below\n" ++ "/l f or /list f | List of files, limited by mode, file masks and filter\n" ++ - "/f i or /file i | Show file with the given index. See, /safe above\n" ++ - "/n i or /nums i | Show file with line numbers. See /file above" + "/p or /pile | Show stored list of files. See /list above\n" ++ + "/f i or /file i | Show file with the given index. See, /pile above\n" ++ + "/n i or /nums i | Show file with line numbers. See /file above\n" ++ + "/s m or /send m | Sending /pile to LLM as context to the message" where - ms = foldl1 (\ x y -> x ++ "|" ++ y) $ map (map toLower . show) modes + ms = + foldl1 (\ x y -> x ++ "|" ++ y) $ map (map toLower . show) modes diff --git a/src/Agent/Utils/Code.hs b/src/Agent/Utils/Code.hs deleted file mode 100644 --- a/src/Agent/Utils/Code.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# OPTIONS_GHC -Wall -Werror #-} - -{-# LANGUAGE NoGeneralizedNewtypeDeriving #-} -{-# LANGUAGE Safe #-} - -{-# LANGUAGE LambdaCase #-} - --------------------------------------------------------------------------------- - --- | --- Copyright : (c) 2026 SPISE MISU ApS --- License : SSPL-1.0 OR AGPL-3.0-only --- Maintainer : SPISE MISU --- Stability : experimental - --------------------------------------------------------------------------------- - -module Agent.Utils.Code - ( -- * Files - files - , file - ) -where - --------------------------------------------------------------------------------- - -import Data.Either ( fromRight ) - -import qualified Agent.IO.Effects as EFF -import qualified Agent.Utils.Common as COM - --------------------------------------------------------------------------------- - -files - :: EFF.LlmCodeRead rio - => Maybe String - -> rio [ String ] -files mfilter = - filesHelper mfilter True - -file - :: EFF.LlmCodeRead rio - => Maybe String - -> Int - -> Bool - -> rio (Either String [String]) -file mfilter index nums = - filesHelper mfilter False >>= \ fs -> - if length fs > index && index >= 0 then - ( \case - Right f -> Right $ COM.file nums f - Left e -> Left e - ) - <$> EFF.llmCodeGet (fs !! index) - else - pure $ Left msg - where - msg = "Index (" ++ show index ++ ") is out of bounds. See /last" - --------------------------------------------------------------------------------- - --- HELPERS (private) - -filesHelper - :: EFF.LlmCodeRead rio - => Maybe String - -> Bool - -> rio [ String ] -filesHelper mfilter nums = - (COM.files nums) . fromRight [] <$> EFF.llmCodeSeq mfilter diff --git a/src/Agent/Utils/Common.hs b/src/Agent/Utils/Common.hs --- a/src/Agent/Utils/Common.hs +++ b/src/Agent/Utils/Common.hs @@ -3,6 +3,8 @@ {-# LANGUAGE NoGeneralizedNewtypeDeriving #-} {-# LANGUAGE Safe #-} +{-# LANGUAGE DeriveDataTypeable #-} + -------------------------------------------------------------------------------- -- | @@ -21,14 +23,33 @@ , chits , chats -- * Helpers + , combine , leftpad , index , split + , linesOptNums ) where -------------------------------------------------------------------------------- +import Prelude hiding ( lines ) +import qualified Prelude as Prelude + +-------------------------------------------------------------------------------- + +combine + :: [ (String, String) ] + -> [ String ] +combine = + map + ( \ (x, y) -> + if null x then + y + else + x ++ ": " ++ y + ) + leftpad :: Char -> Int @@ -61,54 +82,52 @@ -------------------------------------------------------------------------------- files - :: Bool - -> [ String ] + :: String + -> Bool -> [ String ] -files nums fs = - linesOptNums nums 0 fs + -> [ (String, String) ] +files prefix nums fs = + linesOptNums prefix nums 0 fs file - :: Bool - -> String - -> [String] + :: Bool + -> String + -> [ (String, String) ] file nums f = - linesOptNums nums 1 $ lines f + linesOptNums [] nums 1 $ Prelude.lines f -------------------------------------------------------------------------------- chits :: Bool -> [ String ] - -> [ String ] + -> [ (String, String) ] chits nums fs = - linesOptNums nums 0 $ reverse fs + linesOptNums [] nums 0 $ reverse fs chats :: Bool -> [ String ] - -> [ String ] + -> [ (String, String) ] chats nums fs = - linesOptNums nums 0 $ reverse fs + linesOptNums [] nums 0 $ reverse fs -------------------------------------------------------------------------------- -- HELPERS (private) linesOptNums - :: Bool + :: String + -> Bool -> Int -> [ String ] - -> [ String ] -linesOptNums nums origo xs = - if null xs then - [] - else - map (\ (idx, rel) -> f idx rel) - $ zip [origo..] xs - where - len = length $ show $ length xs - f i x = - if nums then - index len i ++ ": " ++ x - else - x + -> [ (String, String) ] +linesOptNums prefix nums origo xs = + zipWith (\ idx rel -> (prefix ++ f idx, rel)) [origo..] xs + where + len = length $ show $ length xs + f i = + if nums then + index len i + else + [] diff --git a/src/Agent/Utils/Plan.hs b/src/Agent/Utils/Plan.hs deleted file mode 100644 --- a/src/Agent/Utils/Plan.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# OPTIONS_GHC -Wall -Werror #-} - -{-# LANGUAGE NoGeneralizedNewtypeDeriving #-} -{-# LANGUAGE Safe #-} - -{-# LANGUAGE LambdaCase #-} - --------------------------------------------------------------------------------- - --- | --- Copyright : (c) 2026 SPISE MISU ApS --- License : SSPL-1.0 OR AGPL-3.0-only --- Maintainer : SPISE MISU --- Stability : experimental - --------------------------------------------------------------------------------- - -module Agent.Utils.Plan - ( -- * Files - files - , file - ) -where - --------------------------------------------------------------------------------- - -import Data.Either ( fromRight ) - -import qualified Agent.IO.Effects as EFF -import qualified Agent.Utils.Common as COM - --------------------------------------------------------------------------------- - -files - :: EFF.LlmPlanRead rio - => Maybe String - -> rio [ String ] -files mfilter = - filesHelper mfilter True - -file - :: EFF.LlmPlanRead rio - => Maybe String - -> Int - -> Bool - -> rio (Either String [String]) -file mfilter index nums = - filesHelper mfilter False >>= \ fs -> - if length fs > index && index >= 0 then - ( \case - Right f -> Right $ COM.file nums f - Left e -> Left e - ) - <$> EFF.llmPlanGet (fs !! index) - else - pure $ Left msg - where - msg = "Index (" ++ show index ++ ") is out of bounds. See /last" - --------------------------------------------------------------------------------- - --- HELPERS (private) - -filesHelper - :: EFF.LlmPlanRead rio - => Maybe String - -> Bool - -> rio [ String ] -filesHelper mfilter nums = - (COM.files nums) . fromRight [] <$> EFF.llmPlanSeq mfilter diff --git a/src/Internal/LLM.hs b/src/Internal/LLM.hs new file mode 100644 --- /dev/null +++ b/src/Internal/LLM.hs @@ -0,0 +1,165 @@ +{-# OPTIONS_GHC -Wall -Werror #-} + +{-# LANGUAGE NoGeneralizedNewtypeDeriving #-} +{-# LANGUAGE Safe #-} + +-------------------------------------------------------------------------------- + +-- | +-- Copyright : (c) 2026 SPISE MISU ApS +-- License : SSPL-1.0 OR AGPL-3.0-only +-- Maintainer : SPISE MISU +-- Stability : experimental + +-------------------------------------------------------------------------------- + +module Internal.LLM + ( Exit (..) + , Root (..) + , Filter (..) + , Mode (..) + , View (..) + , Chit (..) + , Chat + , History (..) + , Mask (..) + , File (..) + , FileLine + , Files (..) + , Document (..) + , Template (..) + , modes + , tpl2xml + ) +where + +-------------------------------------------------------------------------------- + +newtype Exit = Exit Bool + +newtype Root = Root FilePath + +newtype Filter = Filter String + +data Mode + = Auto + | Chat + | Code + | Docs + | Echo + | Plan + | Test + deriving (Bounded, Enum, Eq, Read, Show) + +data View + = Chits + | Chats + +data Chit = + Chit + { prev :: ![String] + , next :: ![String] + } + +type Chat = [String] + +data History = + History + { view :: ![View] + , chit :: !Chit + , chat :: !Chat + } + +-------------------------------------------------------------------------------- + +newtype Mask = Mask [String] + +-------------------------------------------------------------------------------- + +type Markdown = String + +type FileLine = String + +newtype File = File { file :: (FilePath, [FileLine]) } + +newtype Files = Files { files :: [FilePath] } + +newtype Document = Document { document :: File } + +data Template = + Template + { purpose :: !String + , instructions :: ![String] + , examples :: ![Markdown] + , documents :: ![Document] + } + +-------------------------------------------------------------------------------- + +modes :: [Mode] +modes = + [ minBound .. maxBound ] + +tpl2xml + :: Template + -> String +tpl2xml tpl = + ( if eis && ees && eds then + pur + else + "" ++ pur ++ "" + ) ++ + ( if eis then + [] + else + "" ++ + tis ++ + "" + ) ++ + ( if ees then + [] + else + "" ++ + tes ++ + "" + ) ++ + ( if eds then + [] + else + "" ++ + concatMap aux tds ++ + "" + ) + where + pur = + purpose tpl ++ + ( if eis then + [] + else + ". Follow the specififed `instructions`" + ) ++ + ( if ees then + [] + else + ". Output MUST match provided `examples`" + ) ++ + ( if ees then + [] + else + ". List of provided `documents`" + ) + eis = null tis + ees = null tes + eds = null tds + tis = + concatMap (\ x -> "" ++ x ++ "") + $ instructions tpl + tes = + concatMap (\ x -> "" ++ x ++ "") + $ examples tpl + tds = zip [0 :: Int ..] $ documents tpl + aux (i, Document (File (src, ls))) = + "" ++ + "" ++ src ++ "" ++ + "" ++ unlines ls ++ "" ++ + "" diff --git a/src/Internal/RIO.hs b/src/Internal/RIO.hs new file mode 100644 --- /dev/null +++ b/src/Internal/RIO.hs @@ -0,0 +1,1215 @@ +{-# OPTIONS_GHC -Wall -Werror #-} + +{-# LANGUAGE NoGeneralizedNewtypeDeriving #-} +{-# LANGUAGE Safe #-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# LANGUAGE LambdaCase #-} + +-------------------------------------------------------------------------------- + +-- | +-- Copyright : (c) 2026 SPISE MISU ApS +-- License : SSPL-1.0 OR AGPL-3.0-only +-- Maintainer : SPISE MISU +-- Stability : experimental +-- +-- Safe {H}askell +-- +-- https://simonmar.github.io/bib/safe-haskell-2012_abstract.html +-- +-- (David Terei, David Mazières, Simon Marlow, Simon Peyton Jones) Haskell ’12: +-- Proceedings of the Fifth ACM SIGPLAN Symposium on Haskell, Copenhagen, +-- Denmark, ACM, 2012 +-- +-- Though Haskell is predominantly type-safe, implementations contain a few +-- loopholes through which code can bypass typing and module encapsulation. This +-- paper presents Safe Haskell, a language extension that closes these +-- loopholes. Safe Haskell makes it possible to confine and safely execute +-- untrusted, possibly malicious code. By strictly enforcing types, Safe Haskell +-- allows a variety of different policies from API sandboxing to +-- information-flow control to be implemented easily as monads. Safe Haskell is +-- aimed to be as unobtrusive as possible. It enforces properties that +-- programmers tend to meet already by convention. We describe the design of +-- Safe Haskell and an implementation (currently shipping with GHC) that infers +-- safety for code that lies in a safe subset of the language. We use Safe +-- Haskell to implement an online Haskell interpreter that can securely execute +-- arbitrary untrusted code with no overhead. The use of Safe Haskell greatly +-- simplifies this task and allows the use of a large body of existing code and +-- tools. + +-------------------------------------------------------------------------------- + +module Internal.RIO + ( RIO () + , run + -- * Environment + , getEnvVar + -- * Read/Print + , input + , output + -- * LLM (Config) + , llmPathCWD + -- * LLM (Chat) + , llmChatKey, llmChatAPI + , llmChatWeb + -- * LLM (Code) + , llmCodeDir + , llmCodeMsk + , llmCodeSeq, llmCodeGet + -- * LLM (Plan) + , llmPlanDir + , llmPlanMsk + , llmPlanSeq, llmPlanGet + , llmPlanKey, llmPlanAPI + , llmPlanWeb + -- * Internal + , findFiles + , readFileStrict + -- * Temp + , timestampUTC + ) +where + +-------------------------------------------------------------------------------- + +import Data.Either ( 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 Agent.IO.Effects as EFF +import qualified Agent.Utils.Common as COM + +-------------------------------------------------------------------------------- + +newtype RIO a = RestrictedIO { run :: IO a } + +instance Functor RIO where + fmap f m = RestrictedIO $ f <$> run m + +instance Applicative RIO where + pure = RestrictedIO . pure + (<*>) f m = RestrictedIO $ run f <*> run m + +instance Monad RIO where + (>>=) m f = RestrictedIO $ run m >>= run . f + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +data Position = + Position !Int !Int + deriving (Eq, Show) + +instance Ord Position where + (<=) (Position y1 x1) (Position y2 x2) = + case compare y1 y2 of + GT -> False + EQ -> x1 <= x2 + LT -> True + +instance Read Position where + readsPrec _ str = + -- NOTE: + -- "\^[[#;#R" => "\^[" and "[#;#R" (only parse last) + maybeToList + ( readMaybe (f str) >>= \ y -> + readMaybe (g str) >>= \ x -> + Just + ( Position y x + , h str + ) + ) + where + f = takeWhile (/= ';') . drop 1 . dropWhile (/= '[') + g = takeWhile (/= 'R') . drop 1 . dropWhile (/= ';') + h = drop 1 . dropWhile (/= 'R') . dropWhile (/= ';') . dropWhile (/= '[') + +-------------------------------------------------------------------------------- + +data MultiLine = + MultiLine + { stx :: !(Maybe Position) + , cur :: !(Maybe Position) + , etx :: !(Maybe Position) + , col :: !Int + } + deriving Show + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +class StdIn m where + input + :: [ String ] + -> [ String ] + -> m String + +class StdOut m where + output + :: String + -> m () + +-------------------------------------------------------------------------------- + +instance StdIn RIO where + input prev next = + -- NOTE: "\^[7" - save cursor position (SCO) + -- - https://gist.github.com/fnky/458719343aabd01cfb17a3a4f7296797#cursor-controls + RestrictedIO $ putStr "\^[7" >> aux gen prev next [] [] + where + msv = 32767 :: Int + gen = + MultiLine + { stx = Nothing + , cur = Nothing + , etx = Nothing + , col = 0 + } + aux mlp hps hns bcs acs = + block >>= \ blk -> + case (blk < ['\32'], blk) of + -- NOTE: To view keystrokes, use: `ghc -e getLine` (hit + ENTER) and + -- then map to ASCII control codes (use Caret notation cos Λ prefix): + -- + -- - https://en.wikipedia.org/wiki/ASCII#Control_code_table + (True , ['\^J']) -> caseEnter + (True , ['\^H']) -> caseBackspace + (True , ['\^[','[','3','~']) -> caseDelete + (True , ['\^D']) -> caseDelete + (True , ['\^[','[','H']) -> caseHome + (True , ['\^A']) -> caseHome + (True , ['\^[','[','F']) -> caseEnd + (True , ['\^E']) -> caseEnd + (True , ['\^L']) -> caseWipe + (True , ['\^U']) -> caseWipeStart + (True , ['\^K']) -> caseWipeEnd + (True , ['\^[','[','A']) -> caseArrowUp + (True , ['\^[','[','B']) -> caseArrowDown + (True , ['\^[','[','C']) -> caseArrowRight blk + (True , ['\^[','[','D']) -> caseArrowLeft blk + (True , ['\^[','[','1',';','5','C']) -> caseArrowCtrlRight + (True , ['\^[','[','1',';','5','D']) -> caseArrowCtrlLeft + (True , '\^[':ps) -> casePositions ps + (True , _) -> caseSkip + (False, ['\DEL']) -> caseSkip + (False, _) -> caseText blk + where + caseEnter = + -- NOTE: ENTER (line feed) only if something is typed + case (bcs, acs) of + ([], []) -> + aux mlp hps hns bcs acs + ________ -> + hFlush stdout >> + -- NOTE: Move to end of text + putStr hom >> + hFlush stdout >> + (pure . (++ acs) . reverse) bcs + where + hom = + case mlp of + MultiLine { etx = Just (Position y x) } -> + "\^[[" ++ show y ++ ";" ++ show x ++ "H" + _______________________________________ -> + [] + caseBackspace = + -- NOTE: BACKSPACE / CTRL + H (remove char if any and re-write + -- after chars) + case bcs of + [ ] -> aux mlp hps hns bcs acs + (_:cs) -> + hFlush stdout >> + -- NOTE: 0) Print "\^[[6n" position before action + putStr "\^[[6n" >> + -- NOTE: Remove char + putChar '\^H' >> + -- NOTE: Save position + putStr "\^[7" >> + -- NOTE: Clear rest of screen from position + putStr "\^[[0J" >> + -- NOTE: Print after chars + putStr acs >> + -- NOTE: 1) Print "\^[[6n" end position after action + putStr "\^[[6n" >> + -- NOTE: 2) Print "\^[[6n" column witdh + putStr ("\^[[" ++ show msv ++ "C") >> + putStr "\^[[6n" >> + -- NOTE: Go back to saved position + putStr "\^[8" >> + -- NOTE: 3) Print "\^[[6n" current position after action + putStr "\^[[6n" >> + hFlush stdout >> + aux mlp hps hns cs acs + caseDelete = + -- NOTE: DELETE / CTRL + D behave as delete key + case acs of + -- NOTE: Delete (remove char if any and re-write after chars) + [ ] -> aux mlp hps hns bcs acs + (_:cs) -> + hFlush stdout >> + -- NOTE: 0) Print "\^[[6n" position before action + putStr "\^[[6n" >> + -- NOTE: Save position + putStr "\^[7" >> + -- NOTE: Clear rest of screen from position + putStr "\^[[0J" >> + -- NOTE: Print after chars + putStr cs >> + -- NOTE: 1) Print "\^[[6n" end position after action + putStr "\^[[6n" >> + -- NOTE: 2) Print "\^[[6n" column witdh + putStr ("\^[[" ++ show msv ++ "C") >> + putStr "\^[[6n" >> + -- NOTE: Go back to saved position + putStr "\^[8" >> + -- NOTE: 3) Print "\^[[6n" current position after action + putStr "\^[[6n" >> + hFlush stdout >> + aux mlp hps hns bcs cs + caseHome = + -- NOTE: HOME / CTRL + A to move to start of text + hFlush stdout >> + putStr hom >> + hFlush stdout >> + aux mln hps hns [] (reverse bcs ++ acs) + where + (mln, hom) = + case mlp of + MultiLine { stx = Just (Position y x) } -> + ( mlp { cur = Just (Position y x) } + , "\^[[" ++ show y ++ ";" ++ show x ++ "H" + ) + _______________________________________ -> + ( mlp + , "\^[8" + ) + caseEnd = + -- NOTE: END / CTRL + E to move to end of text + hFlush stdout >> + putStr hom >> + hFlush stdout >> + aux mln hps hns ((++ bcs) $ reverse acs) [] + where + (mln, hom) = + case mlp of + MultiLine { etx = Just (Position y x) } -> + ( mlp { cur = Just (Position y x) } + , "\^[[" ++ show y ++ ";" ++ show x ++ "H" + ) + _______________________________________ -> + ( mlp + , [] + ) + caseWipe = + -- NOTE: CTRL + L (form feed) becomes "/w" (clear screen) + pure "/wipe" + caseWipeStart = + -- NOTE: CTRL + U cut text to start + hFlush stdout >> + -- NOTE: 0) Print "\^[[6n" position before action + putStr "\^[[6n" >> + -- NOTE: Go back to start of line + putStr hom >> + -- NOTE: Save position + putStr "\^[7" >> + -- NOTE: Clear rest of screen from position + putStr "\^[[0J" >> + -- NOTE: Print after chars + putStr acs >> + -- NOTE: 1) Print "\^[[6n" end position after action + putStr "\^[[6n" >> + -- NOTE: 2) Print "\^[[6n" column witdh + putStr ("\^[[" ++ show msv ++ "C") >> + putStr "\^[[6n" >> + -- NOTE: Go back to saved position + putStr "\^[8" >> + -- NOTE: 3) Print "\^[[6n" current position after action + putStr "\^[[6n" >> + hFlush stdout >> + aux mlp hps hns [] acs + where + hom = + case mlp of + MultiLine { stx = Just (Position y x) } -> + "\^[[" ++ show y ++ ";" ++ show x ++ "H" + _______________________________________ -> + "\^[8" + caseWipeEnd = + -- NOTE: CTRL + K cut text to end + hFlush stdout >> + -- NOTE: 0) Print "\^[[6n" position before action + putStr "\^[[6n" >> + -- NOTE: Save position + putStr "\^[7" >> + -- NOTE: Clear rest of screen from position + putStr "\^[[0J" >> + -- NOTE: 1) Print "\^[[6n" end position after action + putStr "\^[[6n" >> + -- NOTE: 2) Print "\^[[6n" column witdh + putStr ("\^[[" ++ show msv ++ "C") >> + putStr "\^[[6n" >> + -- NOTE: Go back to saved position + putStr "\^[8" >> + -- NOTE: 3) Print "\^[[6n" current position after action + putStr "\^[[6n" >> + hFlush stdout >> + aux mlp hps hns bcs [] + caseArrowUp = + -- NOTE: Allowed escaped sequences: Arrow "↑" + case (hps, hns) of + ([ ], _) -> aux mlp hps hns bcs acs + (p:ps, _) -> + hFlush stdout >> + -- NOTE: 0) Print "\^[[6n" position before action + putStr "\^[[6n" >> + -- NOTE: Move to start of text + putStr hom >> + -- NOTE: Print previous line + putStr p >> + -- NOTE: Save position + putStr "\^[7" >> + -- NOTE: Clear rest of screen from position + putStr "\^[[0J" >> + -- NOTE: Print after chars + putStr [] >> + -- NOTE: 1) Print "\^[[6n" end position after action + putStr "\^[[6n" >> + -- NOTE: 2) Print "\^[[6n" column witdh + putStr ("\^[[" ++ show msv ++ "C") >> + putStr "\^[[6n" >> + -- NOTE: Go back to saved position + putStr "\^[8" >> + -- NOTE: 3) Print "\^[[6n" current position after action + putStr "\^[[6n" >> + hFlush stdout >> + aux mlp ps (p:hns) rev [] + where + rev = reverse p + hom = + case mlp of + MultiLine { stx = Just (Position y x) } -> + "\^[[" ++ show y ++ ";" ++ show x ++ "H" + _______________________________________ -> + "\^[8" + caseArrowDown = + -- NOTE: Allowed escaped sequences: Arrow "↓" + case (hps, hns) of + (_, [ ]) -> aux mlp hps hns bcs acs + (_, p:ps) -> + hFlush stdout >> + -- NOTE: 0) Print "\^[[6n" position before action + putStr "\^[[6n" >> + -- NOTE: Move to start of text + putStr hom >> + -- NOTE: Print previous line + putStr p >> + -- NOTE: Save position + putStr "\^[7" >> + -- NOTE: Clear rest of screen from position + putStr "\^[[0J" >> + -- NOTE: Print after chars + putStr [] >> + -- NOTE: 1) Print "\^[[6n" end position after action + putStr "\^[[6n" >> + -- NOTE: 2) Print "\^[[6n" column witdh + putStr ("\^[[" ++ show msv ++ "C") >> + putStr "\^[[6n" >> + -- NOTE: Go back to saved position + putStr "\^[8" >> + -- NOTE: 3) Print "\^[[6n" current position after action + putStr "\^[[6n" >> + hFlush stdout >> + aux mlp (p:hps) ps rev [] + where + rev = reverse p + hom = + case mlp of + MultiLine { stx = Just (Position y x) } -> + "\^[[" ++ show y ++ ";" ++ show x ++ "H" + _______________________________________ -> + "\^[8" + caseArrowRight str = + -- NOTE: Allowed escaped sequences: Arrow "→" + case (bcs, acs) of + (_, [ ]) -> + aux mlp hps hns bcs acs + (_, c:cs) -> + hFlush stdout >> + ( if pl then + putStr ("\^[[" ++ "1" ++ "E") + else + putStr str + ) >> + -- NOTE: Update current position + putStr "\^[[6n" >> + hFlush stdout >> + aux mlp hps hns (c:bcs) cs + where + pl = + case mlp of + MultiLine + { cur = Just (Position cy cx) + , etx = Just (Position ey __) + , col = cw + } -> cy <= ey && cx == cw + ___ -> False + caseArrowLeft str = + -- NOTE: Allowed escaped sequences: Arrow "←" + case (bcs, acs) of + ([ ], _) -> + aux mlp hps hns bcs acs + (c:cs, _) -> + hFlush stdout >> + ( if pl then + putStr ("\^[[" ++ "1" ++ "F") >> + putStr ("\^[[" ++ show msv ++ "C") + else + putStr str + ) >> + -- NOTE: Update current position + putStr "\^[[6n" >> + hFlush stdout >> + aux mlp hps hns cs (c:acs) + where + pl = + case mlp of + MultiLine + { stx = Just (Position sy __) + , cur = Just (Position cy 01) + } -> sy < cy + ___ -> False + caseArrowCtrlRight = + -- NOTE: Allowed escaped sequences: CTRL + Arrow "→" + -- NOTE: Move to end of text + hFlush stdout >> + putStr np >> + -- NOTE: Update current position + putStr "\^[[6n" >> + hFlush stdout >> + aux mlp hps hns (ts ++ bcs) ds + where + ds = dropWhile (== ' ') $ dropWhile (/= ' ') acs + ts = drop (length ds) $ reverse acs + lc = length ts + np = + case mlp of + MultiLine + { cur = Just (Position cy cx) + , etx = Just (Position ey _ ) + , col = cw + } -> + case (cy < ey, compare (cw - cx) lc) of + (True, LT) -> + "\^[[" ++ show y ++ ";" ++ show x ++ "H" + where + y = cy + 1 + x = lc - (cw - cx) + __________ -> + "\^[[" ++ show y ++ ";" ++ show x ++ "H" + where + y = cy + x = cx + lc + ___ -> [] + caseArrowCtrlLeft = + -- NOTE: Allowed escaped sequences: CTRL + Arrow "←" + hFlush stdout >> + putStr np >> + -- NOTE: Update current position + putStr "\^[[6n" >> + hFlush stdout >> + aux mlp hps hns ds (ts ++ acs) + where + ds = dropWhile (== ' ') $ dropWhile (/= ' ') bcs + ts = drop (length ds) $ reverse bcs + lc = length ts + np = + case mlp of + MultiLine + { stx = Just (Position sy _ ) + , cur = Just (Position cy cx) + , col = cw + } -> + case (sy < cy, compare cx lc) of + (True, LT) -> + "\^[[" ++ show y ++ ";" ++ show x ++ "H" + where + y = cy - 1 + x = cw - (lc - cx) + __________ -> + "\^[[" ++ show y ++ ";" ++ show x ++ "H" + where + y = cy + x = cx - lc + ___ -> [] + casePositions ps = + -- NOTE: Other escaped sequences (skip unless positions) + aux mln hps hns bcs acs + where + ops = map readMaybe $ COM.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 String) + :: m (Maybe LLM.Root) + +instance + EFF.LlmConf RIO + => LlmConf RIO + where + -- llmPathCWD = getEnvVar "LLM_PATH_CWD" + 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.LlmConf m + , EFF.LlmCodeRoot m + , EFF.LlmCodeMask m + ) + => LlmCodeRead m + where + llmCodeSeq + :: Maybe LLM.Filter + -> m (Either [String] LLM.Files) + llmCodeGet + :: String + -> m (Either String LLM.File) + +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.Files $ concat 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 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 + Right . LLM.File . (,) abspath . lines + <$> readFileStrict abspath + else + pure $ Left $ notPrefixRootAndMode fap abspath LLM.Code + Left err -> + pure $ Left err + Nothing -> + pure $ Left noLlmConf + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +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.Files) + 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.Files $ concat 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 + Right . LLM.File . (,) abspath . lines + <$> readFileStrict abspath + else + pure $ Left $ notPrefixRootAndMode fap abspath LLM.Plan + Left err -> + pure $ Left err + 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.llmPathCWD >>= \ ocwd -> + case ocwd of + Just (LLM.Root root) -> + realPath root >>= \ efap -> + case efap of + Right rp -> + gitExist rp >>= \ git -> + gitignoreTmp rp >>= \ tmp -> + case (git, tmp) of + (True, True) -> + EFF.llmPlanAPI >>= \ mapi -> + EFF.llmPlanKey >>= \ mkey -> + llmCurl json mapi mkey + (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 + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +-- HELPERS (public) + +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" + [ path + , "-path" + , mask + ] + +getEnvVar + :: String + -> RIO (Maybe String) +getEnvVar = + RestrictedIO . ENV.getEnv + +-------------------------------------------------------------------------------- + +-- HELPERS (private) + +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" + +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 = + -- NOTE: «Too Many Open Files» error in Linux + -- + -- - http://woshub.com/too-many-open-files-error-linux/ + RestrictedIO $ + readFile path >>= \cs -> + length cs `seq` pure cs + +realPath + :: FilePath + -> RIO (Either String String) +realPath path = + -- NOTE: Remove any '\NUL` from filepaths + -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/10110 + ( \case + Right str -> Right $ filter (/= '\NUL') str + Left err -> Left err + ) + <$> withExitCode "realpath" + [ "--canonicalize-existing" + , "--logical" + , "--physical" + -- NOTE: End each output line with NUL, not newline + , "--zero" + , path + ] + +timestampUTC :: RIO (Maybe String) +timestampUTC = + ( \case + Right str -> Just str + Left ___ -> Nothing + ) + <$> withExitCode "date" + [ "-u" + , "+'%Y%m%d-%H%M%S-%N'" + ] + +withExitCode + :: String + -> [String] + -> RIO (Either String String) +withExitCode cmd args = + RestrictedIO $ + do + (exitcode, out, err) <- readProcessWithExitCode cmd args [] + case exitcode of + ExitSuccess -> + pure $ Right out + ExitFailure _ -> + pure $ Left err + +withExitCodeStdIn + :: String + -> [String] + -> String + -> RIO (Either String String) +withExitCodeStdIn cmd args txt = + RestrictedIO $ + do + (Just hinp, Just hout, Just herr, ph) <- createProcess rcp + hPutStrLn hinp txt + hClose hinp + out <- hGetContents hout + err <- hGetContents herr + exitcode <- waitForProcess ph + case exitcode of + ExitSuccess -> + pure $ Right out + ExitFailure _ -> + pure $ Left err + where + raw = proc cmd args + rcp = + raw + { std_in = CreatePipe + , std_out = CreatePipe + , std_err = CreatePipe + } + +withExitCodeCwd + :: String + -> String + -> [String] + -> RIO (Either String String) +withExitCodeCwd path cmd args = + RestrictedIO $ + do + (exitcode, out, err) <- readCreateProcessWithExitCode rcp [] + case exitcode of + ExitSuccess -> + pure $ Right out + ExitFailure _ -> + pure $ Left $ err + where + raw = proc cmd args + rcp = raw { cwd = Just path }