A-gent-0.11.0.7: src/Agent/LLM.hs
{-# OPTIONS_GHC -Wall -Werror #-}
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
--------------------------------------------------------------------------------
-- |
-- Copyright : (c) 2026 SPISE MISU ApS
-- License : SSPL-1.0 OR AGPL-3.0-only
-- Maintainer : SPISE MISU <mail+hackage@spisemisu.com>
-- Stability : experimental
--
-- Polite and well educated LLM agent with excellent manners that always behaves
-- well.
--------------------------------------------------------------------------------
module Agent.LLM
( -- * Modes
Mode(..)
-- * Context
, Load
, History(..)
, Context(..)
-- * Paramenters
, Eval
-- * Methods
, repl
, replWithMode
)
where
--------------------------------------------------------------------------------
import Prelude hiding
( head
, mod
, print
, read
)
import Data.Char ( toLower, toUpper )
import GHC.IO.Encoding ( setLocaleEncoding )
import System.IO
( BufferMode (LineBuffering, NoBuffering)
, hFlush
, hSetBuffering
, hSetEcho
, stderr
, stdin
, stdout
, utf8
)
import Text.Read ( readMaybe )
import Internal.GaloisInc.Text.JSON.Generic ( Data )
import Agent.IO.Restricted
( RIO (..)
, input
, output
)
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)
}
type Eval a =
Context a
-> String
-> RIO (Context a, String)
--------------------------------------------------------------------------------
repl
:: Eval a
-> IO ()
repl =
replWithMode Chat
replWithMode
:: Mode
-> Eval a
-> IO ()
replWithMode mod proc =
do
setLocaleEncoding utf8
hSetBuffering stderr NoBuffering
hSetBuffering stdin NoBuffering
hSetBuffering stdout LineBuffering -- NOTE: logic based on `hFlush stdout`
-- NOTE: No default output when typing
hSetEcho stdin False
putStrLn head >> hFlush stdout
run $ loop ctx proc
where
ctx =
Context
{ exit = False
, mode = mod
, load = Nothing
, hist =
History
{ view = None
, chit =
Chit
{ prev = []
, next = []
}
, chat = []
}
, list = Nothing
, safe = Nothing
, file = Nothing
}
--------------------------------------------------------------------------------
-- HELPERS
{- NOTE: Doesn't seem to work
ctrlC :: IO () -> IO ()
ctrlC task =
-- NOTE: Catch CTRL+C
-- https://neilmitchell.blogspot.com/2015/05/handling-control-c-in-haskell.html
sync . (:[]) <$> fork task
-}
loop
:: Context a
-> Eval a
-> RIO ()
loop ctx eval =
case ctx of
Context { exit = True } ->
return ()
Context { hist = History { view = Both } } ->
printLn "* Chits:" >>
(mapM_ printLn $ 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' } } ->
printLn "* Chits:" >>
(mapM_ printLn $ COM.chits True $ prev $ chit $ hist ctx) >>
loop (ctx { hist = ((hist ctx) { view = None }) }) eval
Context { hist = History { view = Chat' } } ->
printLn "* Chats:" >>
(mapM_ printLn $ COM.chats True $ chat $ hist ctx) >>
loop (ctx { hist = ((hist ctx) { view = None }) }) eval
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, res) ->
printLn res >>
loop (upd { file = Nothing }) eval
__________________________________________ ->
print prompt >>
read hps hns >>= \ txt ->
printLn [ ] >>
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
'/':'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'
"/wipe" -> caseWipe txt
"/w" -> caseWipe txt
"/help" -> caseHelp txt
"/?" -> caseHelp txt
"/exit" -> caseExit txt
"/e" -> caseExit txt
'/':cmd ->
printLn msg >>
loop (nxt txt ctx Nothing) eval
where
msg = "Command not recognized: " ++ cmd
____________________________ ->
eval ctx txt >>= \ (upd, res) ->
printLn res >>
loop (nxt txt upd (Just res)) eval
where
his = hist ctx
chi = chit his
hps = prev chi
hns = next chi
nxt p c o =
c
{ hist =
(hist c)
{ chit =
(chit $ hist c)
{ prev = p : hps
}
, chat =
case o of
Nothing -> ( chat $ hist c)
Just r -> ((r:) $ chat $ hist c)
}
}
-- 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
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
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
where
lst = safe ctx
idx =
case midx of
[ ] -> Nothing
' ':cs -> readMaybe cs :: Maybe Int
______ -> Nothing
caseList txt mfil =
loop (nxt txt (ctx { list = fil }) Nothing) eval
where
fil =
case mfil of
[ ] -> Just mfil
' ':cs -> Just cs
______ -> Nothing
caseSafe txt =
loop (nxt txt (ctx { list = safe ctx }) Nothing) eval
caseHist txt v =
loop (nxt txt (ctx { hist = his { view = v } }) Nothing) eval
caseWipe txt =
printLn clear >>
loop (nxt txt ctx Nothing) eval
caseHelp txt =
printLn help >>
loop (nxt txt ctx Nothing) eval
caseExit txt =
printLn "Λ-gent will shutdown" >>
loop (nxt txt (ctx { 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) ++ "> "
read = input
print = output
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."
help :: String
help =
"# Supported commands:\n" ++
"/? or /help | This message\n" ++
"/e or /exit | Exit Λ-gent\n" ++
"/w or /wipe | Clear screen\n" ++
"/m m or /mode m | Change to {" ++ ms ++ "}. Ex: /m code\n" ++
"/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"
where
ms = foldl1 (\ x y -> x ++ "|" ++ y) $ map (map toLower . show) modes