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.18 +version: 0.11.0.19 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 @@ -34,7 +34,7 @@ GHC == 9.6.7 GHC == 9.8.4 GHC == 9.10.3 - GHC == 9.12.2 + GHC == 9.12.4 source-repository head type: diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,21 @@ # Revision history for Λ-gent +## 0.11.0.19 -- 2026-07-11 + +* Feature branch descriptions prefix tags for `Λ-gent` mode on success as done + for failures with `[FAIL]`. + +* Updated `GHC` from `9.12.2` to `9.12.4`. + +* Added a commercial source-available & non-copyleft license `SPISE MISU + License, v2 (SML-2.0)`. For more info, have a look at: + + * https://a-gent.org/about.html#licenses + +* Added a dummy OpenAI API mockup, to ease and increase development pace. + +* Added support for multitasking/batching of LLM prompt requests. + ## 0.11.0.18 -- 2026-05-18 * Added the `/drop` command to remove end-user provided `load` will help clear diff --git a/LICENSE.md b/LICENSE.md --- a/LICENSE.md +++ b/LICENSE.md @@ -1,8 +1,8 @@ -License -======= +Licenses +======== -Source code in this repository is ONLY covered by a [**Server Side Public -License, v1 (SSPL-1.0)**][spdx-sspl-1]. +Source code in the [repository][gitlab-agent] is ONLY covered by a [**Server +Side Public License, v1 (SSPL-1.0)**][spdx-sspl-1]. However, as `SSPL-1.0` is not approved by the [Free Software Foundation (FSF)][fsf] nor the [Open Source Initiative (OSI)][osi] as an open source @@ -18,12 +18,22 @@ * [**GNU Affero General Public License v3.0 only (AGPL-3.0-only)**][local-agpl-3o] +For organizations that can't use any of the mentioned open-source & copyleft +licenses, a commercial source-available & non-copyleft license, heavily inspired +by [Elastic License 2.0 (ELv2)][elastic-el-2], is provided: + +* [**SPISE MISU License, v2 (SML-2.0)**][local-sml-2] + +[gitlab-agent]: https://gitlab.com/a-gent/a-gent/ + [spdx-sspl-1]: https://spdx.org/licenses/SSPL-1.0 [spdx-agpl-3o]: https://spdx.org/licenses/AGPL-3.0-only [hackage-osl]: https://hackage.haskell.org/upload +[elastic-el-2]: https://www.elastic.co/blog/elastic-license-v2 [fsf]: https://www.fsf.org/ [osi]: https://opensource.org/ [local-sspl-1]: ./LICENSE_SSPL-1.0.txt [local-agpl-3o]: ./LICENSE_AGPL-3.0-only.txt +[local-sml-2]: ./LICENSE_SML-2.0.txt diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -30,58 +30,64 @@ ================= ```sh -├── doc -│   └── TODO.md -├── src -│   ├── Agent -│   │   ├── Control -│   │   │   ├── Concurrent.hs -│   │   │   ├── IFC.hs -│   │   │   └── MAC.hs -│   │   ├── Data -│   │   │   ├── ANSI -│   │   │   │   └── EscapeCode.hs -│   │   │   └── JSON.hs -│   │   ├── IO -│   │   │   ├── Effects.hs -│   │   │   └── Restricted.hs -│   │   └── LLM.hs -│   └── Internal -│   ├── GaloisInc -│   │   └── Text -│   │   ├── JSON -│   │   │   ├── Generic.hs -│   │   │   ├── String.hs -│   │   │   └── Types.hs -│   │   ├── JSON.hs -│   │   ├── LICENSE -│   │   └── NOTES.md -│   ├── GlasgowUniversity -│   │   ├── Data -│   │   │   └── Generics -│   │   │   └── Aliases.hs -│   │   ├── LICENSE -│   │   └── NOTES.md -│   ├── LLM.hs -│   ├── RIO.hs -│   └── Utils.hs -├── uat -│   └── TODO.md -├── A-gent.cabal -├── CHANGELOG.md -├── LICENSE.md -├── LICENSE_AGPL-3.0-only.txt -├── LICENSE_SSPL-1.0.txt -├── README.md -├── Setup.hs -└── todo.org +|-- 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 ``` -License -======= +Licenses +======== -Source code in this repository is ONLY covered by a [**Server Side Public -License, v1 (SSPL-1.0)**][spdx-sspl-1]. +Source code in the [repository][gitlab-agent] is ONLY covered by a [**Server +Side Public License, v1 (SSPL-1.0)**][spdx-sspl-1]. However, as `SSPL-1.0` is not approved by the [Free Software Foundation (FSF)][fsf] nor the [Open Source Initiative (OSI)][osi] as an open source @@ -97,12 +103,22 @@ * [**GNU Affero General Public License v3.0 only (AGPL-3.0-only)**][local-agpl-3o] +For organizations that can't use any of the mentioned open-source & copyleft +licenses, a commercial source-available & non-copyleft license, heavily inspired +by [Elastic License 2.0 (ELv2)][elastic-el-2], is provided: + +* [**SPISE MISU License, v2 (SML-2.0)**][local-sml-2] + +[gitlab-agent]: https://gitlab.com/a-gent/a-gent/ + [spdx-sspl-1]: https://spdx.org/licenses/SSPL-1.0 [spdx-agpl-3o]: https://spdx.org/licenses/AGPL-3.0-only [hackage-osl]: https://hackage.haskell.org/upload +[elastic-el-2]: https://www.elastic.co/blog/elastic-license-v2 [fsf]: https://www.fsf.org/ [osi]: https://opensource.org/ [local-sspl-1]: ./LICENSE_SSPL-1.0.txt [local-agpl-3o]: ./LICENSE_AGPL-3.0-only.txt +[local-sml-2]: ./LICENSE_SML-2.0.txt diff --git a/src/Agent/Control/Concurrent.hs b/src/Agent/Control/Concurrent.hs --- a/src/Agent/Control/Concurrent.hs +++ b/src/Agent/Control/Concurrent.hs @@ -21,26 +21,139 @@ , fork , wait , join + , tmax + , ttid + , tkil + , tnum + , tvar + , tval + , terr ) where -------------------------------------------------------------------------------- -import Control.Concurrent ( ThreadId, forkFinally ) +{- DEBUG + +import Control.Concurrent + ( ThreadId + , forkFinally + , getNumCapabilities + , killThread + , threadDelay + ) + import Control.Concurrent.MVar ( MVar , newEmptyMVar , putMVar , readMVar + , 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 ) -------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- -data Task a = Task !ThreadId (IO (Either SomeException a)) +type Wrap a = Either SomeException a +data Task a = Task !ThreadId !(MVar (Wrap a)) !(IO (Wrap a)) -------------------------------------------------------------------------------- +tmax :: IO Int +tmax = + getNumCapabilities + +ttid + :: Task a + -> ThreadId +ttid (Task uid _ _) = + uid + +tkil + :: Task a + -> IO String +tkil t@(Task uid _ _) = + killThread uid >> + pure n + where + n = tnum t + +tnum + :: Task a + -> String +tnum (Task uid _ _) = + -- NOTE: Sample of `show uid` is `ThreadId 42` and + -- > cat /proc/sys/kernel/threads-max + -- > 509_390 + (lpad 6 '0' . drop 1 . dropWhile (/= ' ') . show) uid + where + lpad n c x = + replicate (n - l) c ++ x + where + l = length x + +tvar + :: Task a + -> IO Bool +tvar (Task _ mvar _) = + ( \case + Nothing -> False + Just __ -> True + ) + <$> tryReadMVar mvar + +tval + :: Task a + -> IO (Maybe a) +tval (Task _ _ mval) = + ( \case + Right a -> Just a + Left _ -> Nothing + ) + <$> mval + +terr + :: Task a + -> IO (Maybe String) +terr (Task _ _ mval) = + ( \case + Right _ -> Nothing + Left e -> Just $ show e + ) + <$> mval + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + -- | -- To prevent the users from adding instances of `Async`, we -- provide a middle-layer (`Proxy`) between the `Monad` instance and the `Proxy` @@ -72,14 +185,19 @@ fork compute = new >>= \ var -> forkFinally compute (finally var) >>= \ tid -> - pure $ Task tid $ get var + pure $ Task tid var $ get var where - finally v r = put v r - wait (Task _ mvar) = + 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 + wait (Task _ _ mval) = ( \case Right v -> v Left e -> throw e ) - <$> mvar + <$> mval join = mapM_ wait diff --git a/src/Agent/LLM.hs b/src/Agent/LLM.hs --- a/src/Agent/LLM.hs +++ b/src/Agent/LLM.hs @@ -47,8 +47,7 @@ -------------------------------------------------------------------------------- -import Prelude hiding ( head, mod, print, read ) - +import Prelude hiding ( head, print, read ) import Data.Char ( toLower, toUpper ) import Data.Maybe ( fromMaybe ) @@ -81,6 +80,7 @@ , Files , Filter , History (..) + , Jobs , Mask , Mode (..) , Root @@ -90,7 +90,19 @@ ) import qualified Internal.LLM as INT import Internal.LLM.Action ( Action (..) ) -import Internal.RIO ( RIO (..), input, output ) +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 @@ -99,7 +111,6 @@ import Agent.Data.JSON ( Data ) import Agent.LLM.Message ( Message ) - -------------------------------------------------------------------------------- type Load a = @@ -110,13 +121,13 @@ data Context a = Context - { uuid :: !UUID - , mode :: !Mode + { mode :: !Mode , load :: !(Load a) , hist :: !History , list :: !(Maybe Filter) , pile :: !(Maybe FilePaths) , ruck :: !(Maybe Files) + , jobs :: !(Maybe (Jobs (Context a))) } type Eval a = @@ -136,7 +147,7 @@ :: INT.Mode -> Eval a -> IO () -replWithMode mod proc = +replWithMode mode' proc = do constraint <- integrity case constraint of @@ -150,14 +161,13 @@ -- NOTE: No default output when typing hSetEcho stdin False putStrLn head >> hFlush stdout - run $ loop ctx proc + run $ loop ctx proc >> pure () Left err -> putStrLn err >> hFlush stdout where ctx = Context - { uuid = INT.UUID [] - , mode = mod + { mode = mode' , load = Nothing , hist = History @@ -171,6 +181,7 @@ , list = Nothing , pile = Just $ INT.FilePaths [] , ruck = Just $ INT.Files [] + , jobs = Just $ INT.Jobs [] } -------------------------------------------------------------------------------- @@ -178,11 +189,11 @@ -- HELPERS (private) {- NOTE: Doesn't seem to work -ctrlC :: IO () -> IO () +-- ctrlC :: IO () -> IO () ctrlC task = -- NOTE: Catch CTRL+C -- https://neilmitchell.blogspot.com/2015/05/handling-control-c-in-haskell.html - sync . (:[]) <$> fork task + join . (:[]) <$> fork task -} head :: String @@ -199,84 +210,131 @@ , "/w or /wipe | Wipe screen" , "/d or /drop | Drop end-user data load" , ds - , "/m m or /mode m | Change to {" ++ ms ++ "}. Ex: /m plan" + , "/m m or /mode m | Change to {" ++ ms ++ "}. Ex: /mode plan" , ds - , "/h or /hist | View history (input and output)" + , "/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 and filter" - , "/p or /pile | Show stored list of files. See /list above" - , "/f i or /file i | Show file with the given index. See /pile above" - , "/n i or /nums i | Show file with line numbers. See /file above" + , "/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" + , "/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 (+ description). See /atom above" + , " /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 () + -> RIO (Context a) loop ctx eval = print prompt >> - read hps hns >>= \ txt -> + read hps hns >>= \ txt -> printLn [ ] >> - case txt2act txt of + 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 (nxt txt ctx Nothing) eval + loop ctx eval File _ -> - loop (nxt txt ctx Nothing) eval + loop ctx eval Template _ _ _ _ -> - loop (nxt txt ctx Nothing) eval + loop ctx eval -- Nested -- Stop Exit -> caseExit - Help -> caseHelp txt - Drop -> caseDrop txt - Hist (chits, chats) -> caseHist txt chits chats - Mode c cs -> caseMode txt c cs - Paths (INT.FilePaths fps) -> casePaths txt fps - Pile -> casePile txt - Ruck mdix -> caseRuck txt mdix - Wipe -> caseWipe txt - UnknownCmd cmd -> caseUnknownCmd txt cmd + 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, action) -> - case action of + eval ctx (MSG.Atom msg fs) >>= \ (upd, act) -> + case act of Message (MSG.Text cs) -> printLn cs >> - loop (nxt txt upd (Just cs)) eval + loop (nxt upd (Just cs)) eval None -> - loop (nxt txt upd Nothing) eval + loop (nxt upd Nothing) eval _________________________ -> -- NOTE: Unexpected error printLn "Unexpected error" >> - loop (nxt txt upd (Just [])) eval + loop (nxt upd (Just [])) eval Prompt msg -> - eval ctx (MSG.Tmpl afps) >>= \ (upd0, action0) -> - case action0 of - Template f is es fs -> + eval ctx (MSG.Tmpl afps) >>= \ (upd0, act0) -> + case act0 of + Template p is es fs -> - eval ctx (MSG.Send xml) >>= \ (upd1, action1) -> - case action1 of + eval upd0 (MSG.Send xml) >>= \ (upd1, act1) -> + case act1 of Message (MSG.Text cs) -> printLn cs >> loop - ( nxt txt + ( nxt ( upd1 { ruck = Just $ pfs } ) ( Just cs @@ -284,15 +342,15 @@ ) eval where pfs = - case (map INT.File . f) cs of + case (map INT.File . p) cs of [] -> INT.Files [] xs -> INT.Files xs None -> - loop (nxt txt upd1 Nothing) eval + loop (nxt upd1 Nothing) eval _________________________ -> -- NOTE: Unexpected error printLn "Unexpected error" >> - loop (nxt txt upd1 (Just [])) eval + loop (nxt upd1 (Just [])) eval where ils = map ( \ (INT.File (_, ls)) -> unlines ls) is els = map ( \ (INT.File (_, ls)) -> unlines ls) es @@ -301,262 +359,296 @@ Message (MSG.Text cs) -> printLn cs >> - loop (nxt txt upd0 (Just cs)) eval + loop (nxt upd0 (Just cs)) eval None -> - loop (nxt txt upd0 Nothing) eval + loop (nxt upd0 Nothing) eval _________________________ -> -- NOTE: Unexpected error printLn "Unexpected error" >> - loop (nxt txt upd0 (Just [])) eval + 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, action) -> - case action of + eval ctx (MSG.Path ns afp) >>= \ (upd, act) -> + case act of File (INT.File (_,ls)) -> - caseFile txt ns ls + caseFile ns ls Message (MSG.Text cs) -> printLn cs >> - loop (nxt txt upd (Just cs)) eval + loop (nxt upd (Just cs)) eval None -> - loop (nxt txt upd Nothing) eval + loop (nxt upd Nothing) eval _________________________ -> -- NOTE: Unexpected error printLn "Unexpected error" >> - loop (nxt txt upd (Just [])) eval + loop (nxt upd (Just [])) eval Message (MSG.List fil) -> - eval ctx (MSG.List fil) >>= \ (upd, action) -> - case action of + eval ctx (MSG.List fil) >>= \ (upd, act) -> + case act of Paths (INT.FilePaths fps) -> - casePaths txt fps + casePaths fps Message (MSG.Text cs) -> printLn cs >> - loop (nxt txt upd (Just cs)) eval + loop (nxt upd (Just cs)) eval None -> - loop (nxt txt upd Nothing) eval + loop (nxt upd Nothing) eval _________________________ -> -- NOTE: Unexpected error printLn "Unexpected error" >> - loop (nxt txt upd (Just [])) eval + loop (nxt upd (Just [])) eval Message MSG.Repo -> - eval ctx MSG.Repo >>= \ (upd, action) -> - case action of + eval ctx MSG.Repo >>= \ (upd, act) -> + case act of Message (MSG.Text cs) -> printLn cs >> - loop (nxt txt upd (Just cs)) eval + loop (nxt upd (Just cs)) eval None -> - loop (nxt txt upd Nothing) eval + loop (nxt upd Nothing) eval _________________________ -> -- NOTE: Unexpected error printLn "Unexpected error" >> - loop (nxt txt upd (Just [])) eval + loop (nxt upd (Just [])) eval Message msg -> - eval ctx msg >>= \ (upd, action) -> - case action of + eval ctx msg >>= \ (upd, act) -> + case act of Message (MSG.Text cs) -> printLn cs >> - loop (nxt txt upd (Just cs)) eval + loop (nxt upd (Just cs)) eval None -> - loop (nxt txt upd Nothing) eval + loop (nxt upd Nothing) eval _________________________ -> -- NOTE: Unexpected error printLn "Unexpected error" >> - loop (nxt txt upd (Just [])) eval + loop (nxt upd (Just [])) eval where -- TODO: Refactoring needed - txt2act txt = - -- TODO: Refactoring needed - case txt of - - '/':'m':'o':'d':'e':' ':c:cs -> Mode c cs - '/':'m' :' ':c:cs -> Mode c cs - - '/':'l':'i':'s':'t' :mfil -> - -- TODO: DRY - Message (MSG.List fil) - where - fil = - case mfil of - [ ] -> Just $ INT.Filter mfil - ' ':cs -> Just $ INT.Filter cs - ______ -> Nothing - '/':'l' :mfil -> - -- TODO: DRY - Message (MSG.List fil) - where - fil = - case mfil of - [ ] -> Just $ INT.Filter mfil - ' ':cs -> Just $ INT.Filter cs - ______ -> Nothing - - '/':'f':'i':'l':'e':' ':midx -> - -- TODO: DRY - case oidx of - Nothing -> - Message (MSG.Path False Nothing) - Just idx -> - if 0 <= idx && idx < length pfs then - Message (MSG.Path False (Just $ INT.AbsoluteFilePath $ pfs !! idx)) - else - Message (MSG.Path False Nothing) - where - pfs = concatMap INT.filePaths $ pile ctx - where - oidx = - case midx of - [] -> Nothing - cs -> readMaybe cs :: Maybe Int - '/':'f' :' ':midx -> - -- TODO: DRY - case oidx of - Nothing -> - Message (MSG.Path False Nothing) - Just idx -> - if 0 <= idx && idx < length pfs then - Message (MSG.Path False (Just $ INT.AbsoluteFilePath $ pfs !! idx)) - else - Message (MSG.Path False Nothing) - where - pfs = concatMap INT.filePaths $ pile ctx - where - oidx = - case midx of - [] -> Nothing - cs -> readMaybe cs :: Maybe Int - '/':'n':'u':'m':'s':' ':midx -> - -- TODO: DRY - case oidx of - Nothing -> - Message (MSG.Path True Nothing) - Just idx -> - if 0 <= idx && idx < length pfs then - Message (MSG.Path True (Just $ INT.AbsoluteFilePath $ pfs !! idx)) - else - Message (MSG.Path True Nothing) - where - pfs = concatMap INT.filePaths $ pile ctx - where - oidx = - case midx of - [] -> Nothing - cs -> readMaybe cs :: Maybe Int - '/':'n' :' ':midx -> - -- TODO: DRY - case oidx of - Nothing -> - Message (MSG.Path True Nothing) - Just idx -> - if 0 <= idx && idx < length pfs then - Message (MSG.Path True (Just $ INT.AbsoluteFilePath $ pfs !! idx)) - else - Message (MSG.Path True Nothing) - where - pfs = concatMap INT.filePaths $ pile ctx - where - oidx = - case midx of - [] -> Nothing - cs -> readMaybe cs :: Maybe Int - - '/':'s':'e':'n':'d':' ':mesg -> Prompt mesg - '/':'s' :' ':mesg -> Prompt mesg - - '/':'a':'t':'o':'m':' ':mesg -> - -- TODO: DRY - Branch mesg fs - where - fs = fromMaybe (INT.Files []) (ruck ctx) - '/':'a' :' ':mesg -> - -- TODO: DRY - Branch mesg fs - where - fs = fromMaybe (INT.Files []) (ruck ctx) - - '/':'r':'e':'p':'o' :[ ] -> Message MSG.Repo - - '/':'r':'u':'c':'k' :midx -> Ruck midx - '/':'r' :midx -> Ruck midx - - "/exit" -> Exit - "/e" -> Exit - "/help" -> Help - "/?" -> Help - "/drop" -> Drop - "/d" -> Drop - "/hist" -> Hist ( True, True ) - "/h" -> Hist ( True, True ) - "/chit" -> Hist ( True, False ) - "/chat" -> Hist ( False, True ) - "/pile" -> Pile - "/p" -> Pile - "/wipe" -> Wipe - "/w" -> Wipe - - '/':cmd -> UnknownCmd cmd - ____________________________ -> Message (MSG.Text txt) - - -- TODO: Refactoring needed - his = hist ctx - chi = chit his - hps = prev chi - hns = next chi - nxt p c o = + nxt c o = c { hist = - (hist c) - { chit = - (chit $ hist c) - { prev = p : hps - } - , chat = + 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 () + return ctx - caseDrop txt = + caseDrop = printLn ("Dropping end-user data load") >> loop - ( (nxt txt ctx Nothing) + ( ctx { load = Nothing } ) eval -- TODO: Refactoring needed - caseMode txt c cs = + caseMode c cs = case mmod of - Just mod -> + Just mode' -> printLn ("Changed to " ++ low ++ "-mode") >> loop - ( (nxt txt ctx Nothing) - { mode = mod + ( ctx + { mode = mode' , pile = Just $ INT.FilePaths [] , ruck = Just $ INT.Files [] } ) eval where - low = map toLower $ show mod + 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 txt chits chats = + caseHist chits chats = ( if chits then printLn "* Chits:" >> ( mapM_ printLn . UTL.combine . UTL.chits True . prev . chit . hist @@ -571,21 +663,21 @@ else pure () ) >> - loop (nxt txt ctx Nothing) eval + loop ctx eval - caseFile txt ns ls = + caseFile ns ls = ( mapM_ printLn . UTL.combine . UTL.file ns ) (unlines ls) >> - loop (nxt txt ctx Nothing) eval - caseHelp txt = + loop ctx eval + caseHelp = printLn help >> - loop (nxt txt ctx Nothing) eval + loop ctx eval - casePaths txt fps = - eval ctx MSG.Root >>= \ (upd, action) -> - case action of + casePaths fps = + eval ctx MSG.Root >>= \ (upd, act) -> + case act of Paths (INT.FilePaths rfps) -> ( case rfps of [cwd] -> @@ -599,23 +691,23 @@ printLn "Missing root path" ) >> loop - ( (nxt txt upd Nothing) + ( (nxt upd Nothing) { pile = Just $ INT.FilePaths fps } ) eval Message (MSG.Text cs) -> printLn cs >> - loop (nxt txt upd (Just cs)) eval + loop (nxt upd (Just cs)) eval None -> - loop (nxt txt upd Nothing) eval + loop (nxt upd Nothing) eval _________________________ -> -- NOTE: Unexpected error printLn "Unexpected error" >> - loop (nxt txt upd (Just [])) eval + loop (nxt upd (Just [])) eval - casePile txt = - eval ctx MSG.Root >>= \ (upd, action) -> - case action of + casePile = + eval ctx MSG.Root >>= \ (upd, act) -> + case act of Paths (INT.FilePaths fps) -> ( case fps of [cwd] -> @@ -630,18 +722,18 @@ _____ -> printLn "Missing root path" ) >> - loop (nxt txt upd Nothing) eval + loop (nxt upd Nothing) eval Message (MSG.Text cs) -> printLn cs >> - loop (nxt txt upd (Just cs)) eval + loop (nxt upd (Just cs)) eval None -> - loop (nxt txt upd Nothing) eval + loop (nxt upd Nothing) eval _________________________ -> -- NOTE: Unexpected error printLn "Unexpected error" >> - loop (nxt txt upd (Just [])) eval + loop (nxt upd (Just [])) eval - caseRuck txt midx = + caseRuck midx = ( if null midx then -- NOTE: If no optional index provided, show only paths ( mapM_ printLn . @@ -674,7 +766,7 @@ printLn "Invalid use of /ruck. Use space between cmd and index" ) ) >> - loop (nxt txt ctx Nothing) eval + loop ctx eval where idx = case midx of @@ -688,24 +780,191 @@ fps (INT.Files fs) = map ( \ (INT.File (p,_)) -> p) fs - caseWipe txt = + caseWipe = printLn clear >> - loop (nxt txt ctx Nothing) eval + loop ctx eval - caseUnknownCmd txt cmd = + caseUnknownCmd cmd = printLn msg >> - loop (nxt txt ctx Nothing) eval + loop ctx eval where msg = "Command not recognized: " ++ cmd -- NOTE: Clear screen & Move top-left clear = "\^[[H\^[[2J" -- NOTE: See `infocmp -x` - prompt = - (show . AEC.bold . AEC.sgr) - ("Λ-" ++ (map toLower . show . mode) ctx ++ "> ") - read = input - print = output . show . AEC.faint . AEC.sgr - printLn x = print $ x ++ "\n" + +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 = diff --git a/src/Internal/LLM.hs b/src/Internal/LLM.hs --- a/src/Internal/LLM.hs +++ b/src/Internal/LLM.hs @@ -26,6 +26,7 @@ , Files (..) , FileLine , FilePaths (..) + , Jobs (..) , AbsoluteFilePath (..) , Template (..) , modes @@ -34,6 +35,9 @@ where -------------------------------------------------------------------------------- + +import Agent.Control.Concurrent ( Task ) + -------------------------------------------------------------------------------- newtype UUID = UUID String @@ -107,6 +111,10 @@ instance Monoid FilePaths where mempty = FilePaths [] + +-------------------------------------------------------------------------------- + +newtype Jobs a = Jobs [(UUID, Task a)] -------------------------------------------------------------------------------- diff --git a/src/Internal/LLM/Action.hs b/src/Internal/LLM/Action.hs --- a/src/Internal/LLM/Action.hs +++ b/src/Internal/LLM/Action.hs @@ -42,6 +42,10 @@ | Paths !INT.FilePaths | Pile | Prompt !String + | Batch !String + | Status + | Sync + | Stop | Ruck !String | Template !TextToFile ![INT.File] ![INT.File] ![INT.File] | UnknownCmd !String diff --git a/src/Internal/RIO.hs b/src/Internal/RIO.hs --- a/src/Internal/RIO.hs +++ b/src/Internal/RIO.hs @@ -50,6 +50,19 @@ -- * Read/Print , input , output + -- * Timestamps + , timestampUTC + -- * MultiThreading + , fork + , wait + , join + , tmax + , ttid + , tkil + , tnum + , tvar + , tval + , terr -- * LLM (Config) , llmPathCWD -- * LLM (Chat) @@ -74,6 +87,10 @@ -------------------------------------------------------------------------------- +import Prelude hiding ( mod ) + +import Control.Concurrent ( ThreadId ) + import Control.Exception ( SomeException, try ) import Data.Char ( isDigit ) import Data.Either ( fromLeft, partitionEithers ) @@ -108,6 +125,9 @@ 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 } @@ -167,6 +187,37 @@ -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- +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 ] @@ -1006,7 +1057,7 @@ , Right wcf , Right wrf ) -> - gitUpdateBranchDesc root ts txt >>= \ ewtb -> + gitUpdateBranchDesc root ts mod >>= \ ewtb -> case ewtb of Right _ -> pure $ Right $ unlines @@ -1021,6 +1072,8 @@ , wrf ] Left e -> pure $ Left e + where + mod = "[CODE] " ++ txt ( _, (es,__), _, _, _) -> gitUpdateBranchDesc root ts err >>= \ ewtb -> case ewtb of @@ -1032,7 +1085,7 @@ , "## Adding description:" , fromLeft "No error" ewtb , "## Saving files:" - , concat es + , concat $ map (++ "\n") es , "## Adding files:" , fromLeft "No error" ewaf , "## Committing:" @@ -1042,7 +1095,7 @@ ] Left e -> pure $ Left e where - err = "[ERROR]: " ++ txt + err = "[FAIL] " ++ txt where tap = tmp ++ "/" ++ ts dir = tap ++ "/" ++ cdir