A-gent-0.11.0.20: src/Internal/RIO.hs
{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
--------------------------------------------------------------------------------
-- |
-- Copyright : (c) 2026 SPISE MISU ApS
-- License : SSPL-1.0 OR AGPL-3.0-only
-- Maintainer : SPISE MISU <mail+hackage@spisemisu.com>
-- Stability : experimental
--
-- Safe {H}askell
--
-- https://simonmar.github.io/bib/safe-haskell-2012_abstract.html
--
-- (David Terei, David Mazières, Simon Marlow, Simon Peyton Jones) Haskell ’12:
-- Proceedings of the Fifth ACM SIGPLAN Symposium on Haskell, Copenhagen,
-- Denmark, ACM, 2012
--
-- Though Haskell is predominantly type-safe, implementations contain a few
-- loopholes through which code can bypass typing and module encapsulation. This
-- paper presents Safe Haskell, a language extension that closes these
-- loopholes. Safe Haskell makes it possible to confine and safely execute
-- untrusted, possibly malicious code. By strictly enforcing types, Safe Haskell
-- allows a variety of different policies from API sandboxing to
-- information-flow control to be implemented easily as monads. Safe Haskell is
-- aimed to be as unobtrusive as possible. It enforces properties that
-- programmers tend to meet already by convention. We describe the design of
-- Safe Haskell and an implementation (currently shipping with GHC) that infers
-- safety for code that lies in a safe subset of the language. We use Safe
-- Haskell to implement an online Haskell interpreter that can securely execute
-- arbitrary untrusted code with no overhead. The use of Safe Haskell greatly
-- simplifies this task and allows the use of a large body of existing code and
-- tools.
--------------------------------------------------------------------------------
module Internal.RIO
( RIO ()
, run
-- * Environment
, getEnvVar
-- * Read/Print
, input
, output
-- * Timestamps
, timestampUTC
-- * MultiThreading
, fork
, wait
, join
, tmax
, ttid
, tkil
, tnum
, tvar
, tval
, terr
-- * LLM (Config)
, llmPathCWD
-- * LLM (Chat)
, llmChatAPI, llmChatKey
, llmChatWeb
-- * LLM (Repo)
, llmRepoDir
, llmRepoBrs
, llmRepoGet
, llmRepoLab
, llmRepoCmp
, llmRepoRem
, llmRepoAdd
, llmRepoReq, llmRepoTug, llmRepoDel
-- * LLM (Code)
, llmCodeDir
, llmCodeMsk
, llmCodeIns, llmCodeExa
, llmCodeSeq, llmCodeGet
, llmCodePut
, llmCodeAPI, llmCodeKey
, llmCodeWeb
-- * LLM (Plan)
, llmPlanDir
, llmPlanMsk
, llmPlanSeq, llmPlanGet
, llmPlanAPI, llmPlanKey
, llmPlanWeb
-- * LLM (Spec)
, llmSpecLib, llmSpecDep, llmSpecMod, llmSpecFun, llmSpecRun, llmSpecOto
-- * LLM (Hone)
, llmHoneDir
, llmHoneMsk
, llmHoneSeq, llmHoneGet
, llmHonePut
, llmHoneSOM, llmHoneKey
, llmHoneWeb
--
, typedHolesDev
, timeout
)
where
--------------------------------------------------------------------------------
import Prelude hiding ( abs, mod, span )
import Control.Concurrent ( ThreadId )
import Control.Exception ( SomeException, try )
import Data.Char ( isDigit, toLower, toUpper )
import Data.Either ( fromLeft, lefts, partitionEithers )
import Data.List
( isInfixOf
, isPrefixOf
, isSuffixOf
, partition
, sortBy
)
import Data.Maybe ( maybeToList )
import qualified System.Environment.Blank as ENV
import System.Exit
( ExitCode (ExitFailure, ExitSuccess)
)
import System.IO
( hClose
, hFlush
, hGetContents'
, hPutStrLn
, hReady
, stdin
, stdout
)
import qualified System.Process as SP
import System.Process
( CreateProcess (std_err, std_in, std_out)
, StdStream (CreatePipe)
, createProcess
, proc
, readCreateProcessWithExitCode
, readProcessWithExitCode
, waitForProcess
)
import qualified System.Timeout as ST
import Text.Read ( readMaybe )
import qualified Internal.LLM as LLM
import qualified Internal.Utils as UTL
import qualified Agent.IO.Effects as EFF
import Agent.Control.Concurrent ( Task )
import qualified Agent.Control.Concurrent as CON
--------------------------------------------------------------------------------
newtype RIO a = RestrictedIO { run :: IO a }
instance Functor RIO where
fmap f m = RestrictedIO $ f <$> run m
instance Applicative RIO where
pure = RestrictedIO . pure
(<*>) f m = RestrictedIO $ run f <*> run m
instance Monad RIO where
(>>=) m f = RestrictedIO $ run m >>= run . f
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
data Position =
Position !Int !Int
deriving (Eq, Show)
instance Ord Position where
(<=) (Position y1 x1) (Position y2 x2) =
case compare y1 y2 of
GT -> False
EQ -> x1 <= x2
LT -> True
instance Read Position where
readsPrec _ str =
-- NOTE:
-- "\^[[#;#R" => "\^[" and "[#;#R" (only parse last)
maybeToList
( readMaybe (f str) >>= \ y ->
readMaybe (g str) >>= \ x ->
Just
( Position y x
, h str
)
)
where
f = takeWhile (/= ';') . drop 1 . dropWhile (/= '[')
g = takeWhile (/= 'R') . drop 1 . dropWhile (/= ';')
h = drop 1 . dropWhile (/= 'R') . dropWhile (/= ';') . dropWhile (/= '[')
--------------------------------------------------------------------------------
data MultiLine =
MultiLine
{ stx :: !(Maybe Position)
, cur :: !(Maybe Position)
, etx :: !(Maybe Position)
, col :: !Int
}
deriving Show
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
class MultiThreading m where
fork :: m a -> m (Task a)
wait :: Task a -> m a
join :: [ Task a ] -> m ( )
--
tmax :: m Int
ttid :: Task a -> m ThreadId
tkil :: Task a -> m String
tnum :: Task a -> m String
tvar :: Task a -> m Bool
tval :: Task a -> m (Maybe a)
terr :: Task a -> m (Maybe String)
--------------------------------------------------------------------------------
instance MultiThreading RIO where
fork (RestrictedIO io) = RestrictedIO $ CON.fork io
wait = RestrictedIO . CON.wait
join = RestrictedIO . CON.join
--
tmax = RestrictedIO CON.tmax
ttid = pure . CON.ttid
tkil = RestrictedIO . CON.tkil
tnum = pure . CON.tnum
tvar = RestrictedIO . CON.tvar
tval = RestrictedIO . CON.tval
terr = RestrictedIO . CON.terr
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
class StdIn m where
input
:: [ String ]
-> [ String ]
-> m String
class StdOut m where
output
:: String
-> m ()
--------------------------------------------------------------------------------
instance StdIn RIO where
input prev next =
-- NOTE: "\^[7" - save cursor position (SCO)
-- - https://gist.github.com/fnky/458719343aabd01cfb17a3a4f7296797#cursor-controls
RestrictedIO $ putStr "\^[7" >> aux gen prev next [] []
where
msv = 32_767 :: Int
gen =
MultiLine
{ stx = Nothing
, cur = Nothing
, etx = Nothing
, col = 0
}
aux mlp hps hns bcs acs =
block >>= \ blk ->
case (blk < ['\32'], blk) of
-- NOTE: To view keystrokes, use: `ghc -e getLine` (hit + ENTER) and
-- then map to ASCII control codes (use Caret notation cos Λ prefix):
--
-- - https://en.wikipedia.org/wiki/ASCII#Control_code_table
(True , ['\^J']) -> caseEnter
(True , ['\^H']) -> caseBackspace
(True , ['\^[','[','3','~']) -> caseDelete
(True , ['\^D']) -> caseDelete
(True , ['\^[','[','H']) -> caseHome
(True , ['\^A']) -> caseHome
(True , ['\^[','[','F']) -> caseEnd
(True , ['\^E']) -> caseEnd
(True , ['\^L']) -> caseWipe
(True , ['\^U']) -> caseWipeStart
(True , ['\^K']) -> caseWipeEnd
(True , ['\^[','[','A']) -> caseArrowUp
(True , ['\^[','[','B']) -> caseArrowDown
(True , ['\^[','[','C']) -> caseArrowRight blk
(True , ['\^[','[','D']) -> caseArrowLeft blk
(True , ['\^[','[','1',';','5','C']) -> caseArrowCtrlRight
(True , ['\^[','[','1',';','5','D']) -> caseArrowCtrlLeft
(True , '\^[':ps) -> casePositions ps
(True , _) -> caseSkip
(False, ['\DEL']) -> caseSkip
(False, _) -> caseText blk
where
caseEnter =
-- NOTE: ENTER (line feed) only if something is typed
case (bcs, acs) of
([], []) ->
aux mlp hps hns bcs acs
________ ->
hFlush stdout >>
-- NOTE: Move to end of text
putStr hom >>
hFlush stdout >>
(pure . (++ acs) . reverse) bcs
where
hom =
case mlp of
MultiLine { etx = Just (Position y x) } ->
"\^[[" ++ show y ++ ";" ++ show x ++ "H"
_______________________________________ ->
[]
caseBackspace =
-- NOTE: BACKSPACE / CTRL + H (remove char if any and re-write
-- after chars)
case bcs of
[ ] -> aux mlp hps hns bcs acs
(_:cs) ->
hFlush stdout >>
-- NOTE: 0) Print "\^[[6n" position before action
putStr "\^[[6n" >>
-- NOTE: Remove char
putChar '\^H' >>
-- NOTE: Save position
putStr "\^[7" >>
-- NOTE: Clear rest of screen from position
putStr "\^[[0J" >>
-- NOTE: Print after chars
putStr acs >>
-- NOTE: 1) Print "\^[[6n" end position after action
putStr "\^[[6n" >>
-- NOTE: 2) Print "\^[[6n" column witdh
putStr ("\^[[" ++ show msv ++ "C") >>
putStr "\^[[6n" >>
-- NOTE: Go back to saved position
putStr "\^[8" >>
-- NOTE: 3) Print "\^[[6n" current position after action
putStr "\^[[6n" >>
hFlush stdout >>
aux mlp hps hns cs acs
caseDelete =
-- NOTE: DELETE / CTRL + D behave as delete key
case acs of
-- NOTE: Delete (remove char if any and re-write after chars)
[ ] -> aux mlp hps hns bcs acs
(_:cs) ->
hFlush stdout >>
-- NOTE: 0) Print "\^[[6n" position before action
putStr "\^[[6n" >>
-- NOTE: Save position
putStr "\^[7" >>
-- NOTE: Clear rest of screen from position
putStr "\^[[0J" >>
-- NOTE: Print after chars
putStr cs >>
-- NOTE: 1) Print "\^[[6n" end position after action
putStr "\^[[6n" >>
-- NOTE: 2) Print "\^[[6n" column witdh
putStr ("\^[[" ++ show msv ++ "C") >>
putStr "\^[[6n" >>
-- NOTE: Go back to saved position
putStr "\^[8" >>
-- NOTE: 3) Print "\^[[6n" current position after action
putStr "\^[[6n" >>
hFlush stdout >>
aux mlp hps hns bcs cs
caseHome =
-- NOTE: HOME / CTRL + A to move to start of text
hFlush stdout >>
putStr hom >>
hFlush stdout >>
aux mln hps hns [] (reverse bcs ++ acs)
where
(mln, hom) =
case mlp of
MultiLine { stx = Just (Position y x) } ->
( mlp { cur = Just (Position y x) }
, "\^[[" ++ show y ++ ";" ++ show x ++ "H"
)
_______________________________________ ->
( mlp
, "\^[8"
)
caseEnd =
-- NOTE: END / CTRL + E to move to end of text
hFlush stdout >>
putStr hom >>
hFlush stdout >>
aux mln hps hns ((++ bcs) $ reverse acs) []
where
(mln, hom) =
case mlp of
MultiLine { etx = Just (Position y x) } ->
( mlp { cur = Just (Position y x) }
, "\^[[" ++ show y ++ ";" ++ show x ++ "H"
)
_______________________________________ ->
( mlp
, []
)
caseWipe =
-- NOTE: CTRL + L (form feed) becomes "/w" (clear screen)
pure "/wipe"
caseWipeStart =
-- NOTE: CTRL + U cut text to start
hFlush stdout >>
-- NOTE: 0) Print "\^[[6n" position before action
putStr "\^[[6n" >>
-- NOTE: Go back to start of line
putStr hom >>
-- NOTE: Save position
putStr "\^[7" >>
-- NOTE: Clear rest of screen from position
putStr "\^[[0J" >>
-- NOTE: Print after chars
putStr acs >>
-- NOTE: 1) Print "\^[[6n" end position after action
putStr "\^[[6n" >>
-- NOTE: 2) Print "\^[[6n" column witdh
putStr ("\^[[" ++ show msv ++ "C") >>
putStr "\^[[6n" >>
-- NOTE: Go back to saved position
putStr "\^[8" >>
-- NOTE: 3) Print "\^[[6n" current position after action
putStr "\^[[6n" >>
hFlush stdout >>
aux mlp hps hns [] acs
where
hom =
case mlp of
MultiLine { stx = Just (Position y x) } ->
"\^[[" ++ show y ++ ";" ++ show x ++ "H"
_______________________________________ ->
"\^[8"
caseWipeEnd =
-- NOTE: CTRL + K cut text to end
hFlush stdout >>
-- NOTE: 0) Print "\^[[6n" position before action
putStr "\^[[6n" >>
-- NOTE: Save position
putStr "\^[7" >>
-- NOTE: Clear rest of screen from position
putStr "\^[[0J" >>
-- NOTE: 1) Print "\^[[6n" end position after action
putStr "\^[[6n" >>
-- NOTE: 2) Print "\^[[6n" column witdh
putStr ("\^[[" ++ show msv ++ "C") >>
putStr "\^[[6n" >>
-- NOTE: Go back to saved position
putStr "\^[8" >>
-- NOTE: 3) Print "\^[[6n" current position after action
putStr "\^[[6n" >>
hFlush stdout >>
aux mlp hps hns bcs []
caseArrowUp =
-- NOTE: Allowed escaped sequences: Arrow "↑"
case (hps, hns) of
([ ], _) -> aux mlp hps hns bcs acs
(p:ps, _) ->
hFlush stdout >>
-- NOTE: 0) Print "\^[[6n" position before action
putStr "\^[[6n" >>
-- NOTE: Move to start of text
putStr hom >>
-- NOTE: Print previous line
putStr p >>
-- NOTE: Save position
putStr "\^[7" >>
-- NOTE: Clear rest of screen from position
putStr "\^[[0J" >>
-- NOTE: Print after chars
putStr [] >>
-- NOTE: 1) Print "\^[[6n" end position after action
putStr "\^[[6n" >>
-- NOTE: 2) Print "\^[[6n" column witdh
putStr ("\^[[" ++ show msv ++ "C") >>
putStr "\^[[6n" >>
-- NOTE: Go back to saved position
putStr "\^[8" >>
-- NOTE: 3) Print "\^[[6n" current position after action
putStr "\^[[6n" >>
hFlush stdout >>
aux mlp ps (p:hns) rev []
where
rev = reverse p
hom =
case mlp of
MultiLine { stx = Just (Position y x) } ->
"\^[[" ++ show y ++ ";" ++ show x ++ "H"
_______________________________________ ->
"\^[8"
caseArrowDown =
-- NOTE: Allowed escaped sequences: Arrow "↓"
case (hps, hns) of
(_, [ ]) -> aux mlp hps hns bcs acs
(_, p:ps) ->
hFlush stdout >>
-- NOTE: 0) Print "\^[[6n" position before action
putStr "\^[[6n" >>
-- NOTE: Move to start of text
putStr hom >>
-- NOTE: Print previous line
putStr p >>
-- NOTE: Save position
putStr "\^[7" >>
-- NOTE: Clear rest of screen from position
putStr "\^[[0J" >>
-- NOTE: Print after chars
putStr [] >>
-- NOTE: 1) Print "\^[[6n" end position after action
putStr "\^[[6n" >>
-- NOTE: 2) Print "\^[[6n" column witdh
putStr ("\^[[" ++ show msv ++ "C") >>
putStr "\^[[6n" >>
-- NOTE: Go back to saved position
putStr "\^[8" >>
-- NOTE: 3) Print "\^[[6n" current position after action
putStr "\^[[6n" >>
hFlush stdout >>
aux mlp (p:hps) ps rev []
where
rev = reverse p
hom =
case mlp of
MultiLine { stx = Just (Position y x) } ->
"\^[[" ++ show y ++ ";" ++ show x ++ "H"
_______________________________________ ->
"\^[8"
caseArrowRight str =
-- NOTE: Allowed escaped sequences: Arrow "→"
case (bcs, acs) of
(_, [ ]) ->
aux mlp hps hns bcs acs
(_, c:cs) ->
hFlush stdout >>
( if pl then
putStr ("\^[[" ++ "1" ++ "E")
else
putStr str
) >>
-- NOTE: Update current position
putStr "\^[[6n" >>
hFlush stdout >>
aux mlp hps hns (c:bcs) cs
where
pl =
case mlp of
MultiLine
{ cur = Just (Position cy cx)
, etx = Just (Position ey __)
, col = cw
} -> cy <= ey && cx == cw
___ -> False
caseArrowLeft str =
-- NOTE: Allowed escaped sequences: Arrow "←"
case (bcs, acs) of
([ ], _) ->
aux mlp hps hns bcs acs
(c:cs, _) ->
hFlush stdout >>
( if pl then
putStr ("\^[[" ++ "1" ++ "F") >>
putStr ("\^[[" ++ show msv ++ "C")
else
putStr str
) >>
-- NOTE: Update current position
putStr "\^[[6n" >>
hFlush stdout >>
aux mlp hps hns cs (c:acs)
where
pl =
case mlp of
MultiLine
{ stx = Just (Position sy __)
, cur = Just (Position cy 01)
} -> sy < cy
___ -> False
caseArrowCtrlRight =
-- NOTE: Allowed escaped sequences: CTRL + Arrow "→"
-- NOTE: Move to end of text
hFlush stdout >>
putStr np >>
-- NOTE: Update current position
putStr "\^[[6n" >>
hFlush stdout >>
aux mlp hps hns (ts ++ bcs) ds
where
ds = dropWhile (== ' ') $ dropWhile (/= ' ') acs
ts = drop (length ds) $ reverse acs
lc = length ts
np =
case mlp of
MultiLine
{ cur = Just (Position cy cx)
, etx = Just (Position ey _ )
, col = cw
} ->
case (cy < ey, compare (cw - cx) lc) of
(True, LT) ->
"\^[[" ++ show y ++ ";" ++ show x ++ "H"
where
y = cy + 1
x = lc - (cw - cx)
__________ ->
"\^[[" ++ show y ++ ";" ++ show x ++ "H"
where
y = cy
x = cx + lc
___ -> []
caseArrowCtrlLeft =
-- NOTE: Allowed escaped sequences: CTRL + Arrow "←"
hFlush stdout >>
putStr np >>
-- NOTE: Update current position
putStr "\^[[6n" >>
hFlush stdout >>
aux mlp hps hns ds (ts ++ acs)
where
ds = dropWhile (== ' ') $ dropWhile (/= ' ') bcs
ts = drop (length ds) $ reverse bcs
lc = length ts
np =
case mlp of
MultiLine
{ stx = Just (Position sy _ )
, cur = Just (Position cy cx)
, col = cw
} ->
case (sy < cy, compare cx lc) of
(True, LT) ->
"\^[[" ++ show y ++ ";" ++ show x ++ "H"
where
y = cy - 1
x = cw - (lc - cx)
__________ ->
"\^[[" ++ show y ++ ";" ++ show x ++ "H"
where
y = cy
x = cx - lc
___ -> []
casePositions ps =
-- NOTE: Other escaped sequences (skip unless positions)
aux mln hps hns bcs acs
where
ops = map readMaybe $ UTL.split '\^[' ps :: [Maybe Position]
mln =
-- NOTE: 0) Print "\^[[6n" position before action (unused)
-- NOTE: 1) Print "\^[[6n" end position after action
-- NOTE: 2) Print "\^[[6n" column witdh
-- NOTE: 3) Print "\^[[6n" current position after action
case (mlp, ops) of
(___________________________,
[ ]) ->
mlp
(MultiLine { stx = Nothing },
[Just (Position y x) ]) ->
mlp
{ stx = Just sp
, cur = Just sp
, etx = Just sp
, col = x
}
where
sp = Position y x
(MultiLine { etx = Just ep },
[Just cp ]) ->
if cp > ep then
mlp
{ cur = Just cp
, etx = Just cp
}
else
mlp
{ cur = Just cp
}
(MultiLine { stx = Nothing },
[Just sp,Just ep,Just (Position _ w),Just cp]) ->
mlp
{ stx = Just sp
, cur = Just cp
, etx = Just ep
, col = w
}
(___________________________,
[Just __,Just ep,Just (Position _ w),Just cp]) ->
mlp
{ cur = Just cp
, etx = Just ep
, col = w
}
_______________________________________________ ->
mlp
caseSkip =
aux mlp hps hns bcs acs
caseText str =
hFlush stdout >>
-- NOTE: 0) Print "\^[[6n" position before action
putStr "\^[[6n" >>
-- NOTE: Type key or text
putStr str >>
-- NOTE: Save position
putStr "\^[7" >>
-- NOTE: Clear rest of screen from position
putStr "\^[[0J" >>
-- NOTE: Print after chars
putStr acs >>
-- NOTE: 1) Print "\^[[6n" end position after action
putStr "\^[[6n" >>
-- NOTE: 2) Print "\^[[6n" column witdh
putStr ("\^[[" ++ show msv ++ "C") >>
putStr "\^[[6n" >>
-- NOTE: Go back to saved position
putStr "\^[8" >>
-- NOTE: 3) Print "\^[[6n" current position after action
putStr "\^[[6n" >>
hFlush stdout >>
aux mlp hps hns (reverse str ++ bcs) acs
block =
-- NOTE: https://stackoverflow.com/a/38553473
--
-- We refactored and named it `block` instead of `key` as it is possible
-- to paste a huge block of text. Calling that a keystroke, doesn't seem
-- appropiate
reverse <$> nxt []
where
nxt cs =
do
c <- getChar
m <- hReady stdin
(if m then nxt else pure) (c:cs)
instance StdOut RIO where
output x = RestrictedIO $
putStr x >> hFlush stdout
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
class
EFF.LlmConf m
=> LlmConf m
where
llmPathCWD
:: m (Maybe LLM.Root)
instance
EFF.LlmConf RIO
=> LlmConf RIO
where
llmPathCWD =
( \ case
Just rp -> Just $ LLM.Root rp
Nothing -> Nothing
)
<$> getEnvVar "LLM_PATH_CWD"
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
class
EFF.LlmChatConf m
=> LlmChatConf m
where
llmChatAPI
:: m (Maybe String)
llmChatKey
:: m (Maybe String)
instance
EFF.LlmChatConf RIO
=> LlmChatConf RIO
where
llmChatAPI = getEnvVar "LLM_CHAT_LOCALHOST_API"
llmChatKey = pure Nothing
--------------------------------------------------------------------------------
class
EFF.LlmChatConf m
=> LlmChatPost m
where
llmChatWeb
:: String -> m (Either String String)
instance
EFF.LlmChatConf RIO
=> LlmChatPost RIO
where
llmChatWeb json =
EFF.llmChatAPI >>= \ mapi ->
EFF.llmChatKey >>= \ mkey ->
llmCurlChatCompletions json mapi mkey
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
class
EFF.LlmConf m
=> LlmRepoRoot m
where
llmRepoDir
:: m (Maybe LLM.Root)
instance
EFF.LlmConf RIO
=> LlmRepoRoot RIO
where
llmRepoDir = EFF.llmPathCWD
--------------------------------------------------------------------------------
class
EFF.LlmRepoRoot m
=> LlmRepoAtom m
where
llmRepoBrs
:: m (Either [String] LLM.Branches)
instance
EFF.LlmRepoRoot RIO
=> LlmRepoAtom RIO
where
llmRepoBrs =
EFF.llmRepoDir >>= \ case
Just (LLM.Root root) ->
realPath root root >>= \ case
-- TODO: DRY
Right fap ->
gitExist fap >>= \ case
True ->
gitBranchesDesc fap >>= \ case
Left e -> pure $ Left [e]
Right bs ->
if null lbs then
pure
$ Right
$ LLM.Branches
$ sortBy
( \ (LLM.Branch (LLM.UUID uid1) _ _)
(LLM.Branch (LLM.UUID uid2) _ _) ->
compare uid1 uid2
)
abs
else
pure
$ Left
$ map show lbs
where
(lbs, rbs) = partitionEithers $ map LLM.txt2b bs
atl = "_TL"
abs =
-- NOTE: Show all non-TAIL branches
filter
( \ (LLM.Branch (LLM.UUID uid) _ _) ->
not (atl `isSuffixOf` uid)
) rbs
False ->
pure $ Left [ "No GIT repo initialized" ]
Left err ->
pure $ Left [ err ]
Nothing ->
pure $ Left [ noLlmConf ]
--------------------------------------------------------------------------------
class
EFF.LlmRepoRoot m
=> LlmRepoTail m
where
llmRepoGet
:: m (Either String LLM.Branch)
instance
EFF.LlmRepoRoot RIO
=> LlmRepoTail RIO
where
llmRepoGet =
EFF.llmRepoDir >>= \ case
Just (LLM.Root root) ->
realPath root root >>= \ case
-- TODO: DRY
Right fap ->
gitExist fap >>= \ case
True ->
gitBranchesDesc fap >>= \ case
Left e -> pure $ Left e
Right bs ->
if null lbs then
case tbs of
[t] -> pure $ Right t
[ ] ->
timestampUTC >>= \ case
Just ts ->
gitBranch fap tid ohd >>= \ case
Right _ ->
gitBranchDescUpdate fap tid msg >>= \ case
Right _ ->
pure
$ Right
$ LLM.Branch
(LLM.UUID tid)
(Right LLM.Hone)
(drop ((+ 1) $ length hmt) msg)
Left e ->
pure $ Left e
Left e ->
pure $ Left e
where
len = length atl
tid = dropLastN len ts ++ atl
ohd = "origin/HEAD"
hmt = "[HONE]"
msg =
hmt ++ " Local TAIL branch" ++
", based on origin/HEAD" ++
", as local storage"
_______ ->
pure $ Left "No timestamp"
___ ->
pure $ Left "Too many TAIL branches"
else
( pure
. Left
. concatMap ((++ "\n") . show)
) lbs
where
(lbs, rbs) = partitionEithers $ map LLM.txt2b bs
atl = "_TL"
tbs =
-- NOTE: Show only TAIL branches
filter
( \ (LLM.Branch (LLM.UUID uid) _ _) ->
atl `isSuffixOf` uid
) rbs
False ->
pure $ Left "No GIT repo initialized"
Left err ->
pure $ Left err
Nothing ->
pure $ Left noLlmConf
--------------------------------------------------------------------------------
class
( EFF.LlmRepoAtom m
, EFF.LlmRepoTail m
)
=> LlmRepoDesc m
where
llmRepoLab
:: LLM.UUID
-> LLM.Label
-> m (Either String String)
instance
( EFF.LlmRepoAtom RIO
, EFF.LlmRepoTail RIO
)
=> LlmRepoDesc RIO
where
llmRepoLab (LLM.UUID uid) (LLM.Label lab) =
EFF.llmRepoDir >>= \ case
Just (LLM.Root root) ->
realPath root root >>= \ case
-- TODO: DRY
Right fap ->
EFF.llmRepoGet >>= \ case
Right (LLM.Branch (LLM.UUID tid) _ _) ->
if tid == uid then
gitBranchDescUpdate fap tid lab
else
EFF.llmRepoBrs >>= \ case
Right (LLM.Branches bs) ->
( \ (ls, rs) ->
-- NOTE: We assume only ONE instance
if null ls then
Right $ concat rs
else
Left $ concat ls
)
<$> eb
where
fb =
filter
( \ (LLM.Branch (LLM.UUID bid) _ _) ->
bid == uid
) bs
eb =
partitionEithers
<$> mapM
( \ (LLM.Branch (LLM.UUID bid) _ _) ->
gitBranchDescUpdate fap bid lab
) fb
Left es ->
pure $ Left $ unlines es
Left e ->
pure $ Left e
Left err ->
pure $ Left err
Nothing ->
pure $ Left noLlmConf
--------------------------------------------------------------------------------
class
( EFF.LlmRepoAtom m
, EFF.LlmRepoTail m
)
=> LlmRepoDiff m
where
llmRepoCmp
:: LLM.UUID
-> m (Either String [String])
instance
( EFF.LlmRepoAtom RIO
, EFF.LlmRepoTail RIO
)
=> LlmRepoDiff RIO
where
llmRepoCmp (LLM.UUID uid) =
EFF.llmRepoDir >>= \ case
Just (LLM.Root root) ->
realPath root root >>= \ case
-- TODO: DRY
Right fap ->
EFF.llmRepoGet >>= \ case
Right (LLM.Branch (LLM.UUID tid) _ _) ->
if tid == uid then
( \case
Right r -> Right r
Left e -> Left $ unlines e
)
<$> gitDiff fap ohd tid
else
EFF.llmRepoBrs >>= \ case
Right (LLM.Branches bs) ->
( \ (ls, rs) ->
-- NOTE: We assume only ONE instance
if null ls then
Right $ concat rs
else
Left $ unlines $ concat ls
)
<$> eb
where
fb =
filter
( \ (LLM.Branch (LLM.UUID bid) _ _) ->
bid == uid
) bs
eb =
partitionEithers
<$> mapM
( \ (LLM.Branch (LLM.UUID bid) _ _) ->
gitDiff fap tid bid -- "src"
) fb
Left es ->
pure $ Left $ unlines es
Left e ->
pure $ Left e
Left err ->
pure $ Left err
Nothing ->
pure $ Left noLlmConf
where
ohd = "origin/HEAD"
--------------------------------------------------------------------------------
class
( EFF.LlmRepoAtom m
, EFF.LlmRepoTail m
)
=> LlmRepoDisp m
where
llmRepoRem
:: Maybe LLM.UUID
-> m (Either String [String])
instance
( EFF.LlmRepoAtom RIO
, EFF.LlmRepoTail RIO
)
=> LlmRepoDisp RIO
where
llmRepoRem ouid =
EFF.llmRepoDir >>= \ case
Just (LLM.Root root) ->
realPath root root >>= \ case
-- TODO: DRY
Right fap ->
EFF.llmRepoGet >>= \ case
Right (LLM.Branch (LLM.UUID tid) _ _) ->
EFF.llmRepoBrs >>= \ case
Right (LLM.Branches bs) ->
( \ (ls, rs) ->
if null ls then
Right rs
else
Left $ unlines ls
)
<$> eb
where
(ds,ms) =
partition
( \ (LLM.Branch (LLM.UUID bid) emof _) ->
case emof of
Left _ -> True
Right _ -> tid > bid
) bs
mo =
-- NOTE: Delete outdated (all except ahead of parent)
( \ abs ->
map fst
$ filter ((GT /=) . snd)
$ map
( \(b, ean) ->
case ean of
Right n -> (b, n)
--Left _ -> (b, 0)
Left _ -> (b, LT)
)
abs
)
<$> zip ms
<$> mapM
( \ (LLM.Branch (LLM.UUID bid) _ _) ->
gitBranchAheadParent fap bid tid
) ms
eb =
mo >>= \ os ->
partitionEithers
<$> mapM
( \ (LLM.Branch (LLM.UUID bid) _ _) ->
gitBranchRemove True fap bid
) (ds ++ os)
Left es ->
pure $ Left $ unlines es
Left e ->
pure $ Left e
Left err ->
pure $ Left err
Nothing ->
pure $ Left noLlmConf
where
-- NOTE: Use this for when we delete _TL after successfully merged to
-- origin/HEAD and pulled
_ {- uids -} = maybeToList ouid
--------------------------------------------------------------------------------
class
( EFF.LlmRepoAtom m
, EFF.LlmRepoTail m
)
=> LlmRepoMeld m
where
llmRepoAdd
:: m (Either String [String])
instance
( EFF.LlmRepoAtom RIO
, EFF.LlmRepoTail RIO
)
=> LlmRepoMeld RIO
where
llmRepoAdd =
EFF.llmRepoDir >>= \ case
Just (LLM.Root root) ->
realPath root root >>= \ efap ->
realPath root "tmp" >>= \ etmp ->
case (efap, etmp) of
-- TODO: DRY
(Right fap, Right tmp) ->
EFF.llmRepoGet >>= \ case
Right (LLM.Branch pid@(LLM.UUID tid) _ _) ->
EFF.llmRepoBrs >>= \ case
Right (LLM.Branches bs) ->
gitWorktreeAdd fap lid tap (Just pid) >>= \ case
Right _ ->
eb >>= \ baz ->
gitWorktreeMer tap baz >>= \ emb ->
gitFetchMerge tap lid tid >>= \ emg ->
case (emb, emg) of
(Right mb, Right mg) ->
-- NOTE: Ensure worktree branch is always removed
gitWorktreeRem fap tap >>
gitBranchRemove True fap lid >>
(pure . Right) [ mb, mg ]
(other1, other2) ->
-- NOTE: Ensure worktree branch is always removed
gitWorktreeRem fap tap >>
gitBranchRemove True fap lid >>
(pure . Left . unlines . lefts) [other1, other2]
where
ms =
filter
( \ (LLM.Branch (LLM.UUID bid) emof _) ->
case emof of
Left _ -> False
Right _ -> tid <= bid
) bs
mo =
-- NOTE: Not outdated (parent is behind)
( \ abs ->
map fst
$ filter ((GT ==) . snd)
$ map
( \(b, eac) ->
case eac of
Right c -> (b, c)
Left _ -> (b, EQ)
)
abs
)
<$> zip ms
<$> mapM
( \ (LLM.Branch (LLM.UUID bid) _ _) ->
gitBranchAheadParent fap bid tid
) ms
eb =
map (\ (LLM.Branch uuid _ _) -> uuid) <$> mo
Left err ->
pure $ Left err
where
lid = (++ "_") $ map toLower tid
tap = tmp ++ "/" ++ lid ++ "/"
Left es ->
pure $ Left $ unlines es
Left e ->
pure $ Left e
(other1, other2) ->
pure $ Left $ unlines $ lefts [other1, other2]
Nothing ->
pure $ Left noLlmConf
--------------------------------------------------------------------------------
class
EFF.LlmRepoTail m
=> LlmRepoPull m
where
llmRepoReq
:: m (Either String [String])
llmRepoTug
:: m (Either String [String])
llmRepoDel
:: m (Either String [String])
instance
EFF.LlmRepoTail RIO
=> LlmRepoPull RIO
where
llmRepoReq =
EFF.llmRepoDir >>= \ case
Just (LLM.Root root) ->
realPath root root >>= \ case
-- TODO: DRY
Right fap ->
EFF.llmRepoGet >>= \ case
Right (LLM.Branch (LLM.UUID tid) _ _) ->
( \case
Right txt -> (Right . lines) txt
Left err -> Left err
)
<$> gitBranchPushOrigin fap tid
Left e ->
pure $ Left e
Left err ->
pure $ Left err
Nothing ->
pure $ Left noLlmConf
llmRepoTug =
EFF.llmRepoDir >>= \ case
Just (LLM.Root root) ->
realPath root root >>= \ case
Right fap ->
( \case
Right txt -> (Right . lines) txt
Left err -> Left err
)
<$> gitBranchPullOrigin fap
Left err ->
pure $ Left err
Nothing ->
pure $ Left noLlmConf
llmRepoDel =
EFF.llmRepoDir >>= \ case
Just (LLM.Root root) ->
realPath root root >>= \ case
-- TODO: DRY
Right fap ->
EFF.llmRepoGet >>= \ case
Right (LLM.Branch (LLM.UUID tid) _ _) ->
( \case
Right txt -> (Right . lines) txt
Left err -> Left err
)
<$> gitBranchRemove False fap tid
Left e ->
pure $ Left e
Left err ->
pure $ Left err
Nothing ->
pure $ Left noLlmConf
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
class
EFF.LlmConf m
=> LlmCodeRoot m
where
llmCodeDir
:: m String
instance
( EFF.LlmConf RIO
, EFF.LlmCodeRoot RIO
)
=> LlmCodeRoot RIO
where
llmCodeDir = pure "src"
--------------------------------------------------------------------------------
class
EFF.LlmCodeMask m
=> LlmCodeMask m
where
llmCodeMsk
:: m [String]
instance
( EFF.LlmConf RIO
, EFF.LlmCodeMask RIO
)
=> LlmCodeMask RIO
where
llmCodeMsk =
pure [ "*.hs" ]
--------------------------------------------------------------------------------
class
EFF.LlmCodeTmpl m
=> LlmCodeTmpl m
where
llmCodeIns
:: m (Either [String] [LLM.File])
llmCodeExa
:: m [LLM.File]
instance
( EFF.LlmConf RIO
, EFF.LlmCodeTmpl RIO
)
=> LlmCodeTmpl RIO
where
llmCodeIns =
-- NOTE: No instructions are not an error as such
EFF.llmPathCWD >>= \ case
Just (LLM.Root root) ->
realPath root "llm" >>= \ case
-- TODO: DRY
Right fap ->
findFiles fap "*code_instructions_*.json" >>= \ case
Right afps ->
let
dfs =
mapM
( \ abspath ->
( \ json ->
case LLM.decodeJsonArray json of
Left err -> Left err
Right fls -> Right $ LLM.File (abspath, fls)
)
<$> readFileStrict abspath
) afps
in
dfs >>= \ fs ->
case partitionEithers fs of
([], rs) -> pure $ Right rs
(ls, __) -> pure $ Left $ map show ls
Left __ ->
pure $ Right [ ]
Left ____ ->
pure $ Right [ ]
Nothing ->
pure $ Right [ ]
llmCodeExa =
EFF.llmPathCWD >>= \ case
Just (LLM.Root root) ->
realPath root "llm" >>= \ case
-- TODO: DRY
Right fap ->
findFiles fap "*code_examples_*.md" >>= \ case
Right afps ->
mapM
( \ abspath ->
LLM.File . (,) abspath . lines
<$> readFileStrict abspath
) afps
Left __ ->
pure []
Left ____ ->
pure []
Nothing ->
pure []
--------------------------------------------------------------------------------
class
( EFF.LlmConf m
, EFF.LlmRepoRoot m
, EFF.LlmCodeRoot m
, EFF.LlmCodeMask m
)
=> LlmCodeRead m
where
llmCodeSeq
:: Maybe LLM.Filter
-> m (Either [String] LLM.FilePaths)
llmCodeGet
:: LLM.AbsoluteFilePath
-> m (Either String LLM.File)
instance
( EFF.LlmConf RIO
, EFF.LlmRepoRoot RIO
, EFF.LlmCodeRoot RIO
, EFF.LlmCodeMask RIO
)
=> LlmCodeRead RIO
where
llmCodeSeq mfilter =
EFF.llmPathCWD >>= \ case
Just (LLM.Root root) ->
EFF.llmCodeDir >>= \ cdir ->
EFF.llmCodeMsk >>= \ cmsk ->
realPath root cdir >>= \ case
-- TODO: DRY
Right fap ->
( \ case
([], rs) -> Right $ LLM.FilePaths $ mconcat rs
(ls, __) -> Left ls
)
. partitionEithers
<$> mapM (\ msk -> findFiles fap ("*" ++ fil ++ "*" ++ msk)) cmsk
Left err ->
pure $ Left [err]
Nothing ->
pure $ Left [noLlmConf]
where
fil =
case mfilter of
Just (LLM.Filter f) -> f
Nothing -> [ ]
llmCodeGet (LLM.AbsoluteFilePath abspath) =
EFF.llmPathCWD >>= \ ocwd ->
EFF.llmCodeDir >>= \ cdir ->
case ocwd of
-- TODO: DRY
Just (LLM.Root root) ->
realPath root cdir >>= \ case
Right fap ->
if fap `isPrefixOf` abspath then
-- NOTE: Root relative path
Right . LLM.File . (,) (drop len abspath) . lines
<$> readFileStrict abspath
else
pure $ Left $ notPrefixRootAndMode fap abspath LLM.Code
Left err ->
pure $ Left err
where
len = length root
Nothing ->
pure $ Left noLlmConf
--------------------------------------------------------------------------------
class
( EFF.LlmConf m
, EFF.LlmRepoRoot m
, EFF.LlmCodeRoot m
)
=> LlmCodeSave m
where
llmCodePut
:: LLM.Context a
-> Maybe LLM.UUID
-> String
-> LLM.Files
-> m (Either String String)
instance
( EFF.LlmConf RIO
, EFF.LlmRepoRoot RIO
, EFF.LlmCodeRoot RIO
)
=> LlmCodeSave RIO
where
-- TODO: Needs some refactoring at some point …
llmCodePut _ _ _ (LLM.Files []) =
pure $ Left "No files provided, therefore no action performed"
llmCodePut ctx ouid txt (LLM.Files fs) =
EFF.llmRepoDir >>= \ ocwd ->
EFF.llmCodeDir >>= \ cdir ->
case ocwd of
Just (LLM.Root root) ->
realPath root root >>= \ case
Right fap ->
gitExist fap >>= \ igit ->
gitignoreTmp fap >>= \ itmp ->
case (igit, itmp) of
(True, True) ->
timestampUTC >>= \ case
Just ts ->
realPath root "tmp" >>= \ case
Right tmp ->
gitWorktreeAdd fap ts tap ouid >>= \ ewta ->
( mapM
( \ (LLM.File (fp, fls)) ->
let
fil = tap ++ "/" ++ fp
len = length $ tap ++ "/"
in
if dir `isPrefixOf` fil then
ensureFolderPath tap fil >>= \ eefp ->
writeFileStrict fil (unlines fls) >>= \ ewfs ->
case (eefp, ewfs) of
(Right efp, Right wfs) ->
pure $ Right $ unlines
[ "* Ensuring folder exists:"
, drop len efp
, "* Writing file to folder:"
, drop len wfs
]
______________________ ->
pure $ Left $ unlines
[ "* Ensuring folder exists:"
, fromLeft "No error" eefp
, "* Writing file to folder:"
, fromLeft "No error" ewfs
]
else
pure
$ Left
( drop len fil ++
" doesn't start with " ++
drop len dir
)
)
fs
) >>= \ ewfs ->
gitAddCommit tap txt >>= \ ewcf ->
gitWorktreeRem fap tap >>= \ ewrf ->
case
( ewta
, partitionEithers ewfs
, ewcf
, ewrf
)
of
( Right wta
, ( []
, xs
)
, Right wcf
, Right wrf
) ->
gitBranchDescUpdate fap ts pfx >>= \ case
Right _ ->
pure $ Right $ unlines
[ "# Temporary worktree branch:"
, "## Adding:"
, wta
, "## Saving files:"
, concat xs
, "## Adding files and committing :"
, wcf
, "## Removing:"
, wrf
]
Left e -> pure $ Left e
where
pfx = "[" ++ mod ++ "] " ++ txt
mod = map toUpper $ show $ LLM.mode ctx
( _, (es,__), _, _) ->
gitBranchDescUpdate fap ts err >>= \ ewtb ->
case ewtb of
Right _ ->
pure $ Left $ unlines
[ "# Temporary worktree branch error(s):"
, "## Adding:"
, fromLeft "No error" ewta
, "## Adding description:"
, fromLeft "No error" ewtb
, "## Saving files:"
, unlines es
, "## Committing:"
, fromLeft "No error" ewcf
, "## Removing:"
, fromLeft "No error" ewrf
]
Left e -> pure $ Left e
where
err = "[FAIL] " ++ txt
where
tap = tmp ++ "/" ++ ts
dir = tap ++ "/" ++ cdir
Left e ->
pure $ Left e
_______ ->
pure $ Left "No timestamp"
(False, ____) ->
pure $ Left "No GIT repo initialized"
(____, False) ->
pure $ Left "No /tmp/ folder added to the .gitignore file"
Left err ->
pure $ Left err
Nothing ->
pure $ Left noLlmConf
--------------------------------------------------------------------------------
class
( EFF.LlmConf m
, EFF.LlmCodeConf m
)
=> LlmCodeConf m
where
llmCodeAPI
:: m (Maybe String)
llmCodeKey
:: m (Maybe String)
instance
( EFF.LlmConf RIO
, EFF.LlmCodeConf RIO
)
=> LlmCodeConf RIO
where
llmCodeAPI = getEnvVar "LLM_CODE_LOCALHOST_API"
llmCodeKey = pure Nothing
--------------------------------------------------------------------------------
class
( EFF.LlmConf m
, EFF.LlmCodeConf m
)
=> LlmCodePost m
where
llmCodeWeb
:: String
-> m (Either String String)
instance
( EFF.LlmConf RIO
, EFF.LlmCodeConf RIO
)
=> LlmCodePost RIO
where
llmCodeWeb json =
EFF.llmCodeAPI >>= \ mapi ->
EFF.llmCodeKey >>= \ mkey ->
llmCurlChatCompletions json mapi mkey
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
class
EFF.LlmPlanRoot m
=> LlmPlanRoot m
where
llmPlanDir
:: m String
instance
EFF.LlmPlanRoot RIO
=> LlmPlanRoot RIO
where
llmPlanDir = pure "."
--------------------------------------------------------------------------------
class
EFF.LlmPlanMask m
=> LlmPlanMask m
where
llmPlanMsk
:: m [String]
instance
EFF.LlmPlanMask RIO
=> LlmPlanMask RIO
where
llmPlanMsk =
pure
[ "*.org"
, "*.md"
]
--------------------------------------------------------------------------------
class
( EFF.LlmConf m
, EFF.LlmPlanRoot m
, EFF.LlmPlanMask m
, EFF.LlmCodeRead m
)
=> LlmPlanRead m
where
llmPlanSeq
:: Maybe LLM.Filter
-> m (Either [String] LLM.FilePaths)
llmPlanGet
:: String
-> m (Either String LLM.File)
instance
( EFF.LlmConf RIO
, EFF.LlmPlanRoot RIO
, EFF.LlmPlanMask RIO
, EFF.LlmCodeRead RIO
)
=> LlmPlanRead RIO
where
llmPlanSeq mfilter =
EFF.llmPathCWD >>= \ case
Just (LLM.Root root) ->
EFF.llmPlanDir >>= \ pdir ->
EFF.llmPlanMsk >>= \ pmsk ->
realPath root pdir >>= \ case
-- TODO: DRY
Right fap ->
( \ case
([], rs) -> Right $ LLM.FilePaths $ mconcat rs
(ls, __) -> Left ls
)
. partitionEithers
<$> mapM (\ msk -> findFiles fap ("*" ++ fil ++ "*" ++ msk)) pmsk
Left err ->
pure $ Left [err]
Nothing ->
pure $ Left [noLlmConf]
where
fil =
case mfilter of
Just (LLM.Filter f) -> f
Nothing -> [ ]
llmPlanGet abspath =
EFF.llmPathCWD >>= \ ocwd ->
EFF.llmPlanDir >>= \ pdir ->
case ocwd of
-- TODO: DRY
Just (LLM.Root root) ->
realPath root pdir >>= \ case
Right fap ->
if fap `isPrefixOf` abspath then
-- NOTE: Root relative path
Right . LLM.File . (,) (drop len abspath) . lines
<$> readFileStrict abspath
else
pure $ Left $ notPrefixRootAndMode fap abspath LLM.Plan
Left err ->
pure $ Left err
where
len = length root
Nothing ->
pure $ Left noLlmConf
--------------------------------------------------------------------------------
class
EFF.LlmPlanConf m
=> LlmPlanConf m
where
llmPlanAPI
:: m (Maybe String)
llmPlanKey
:: m (Maybe String)
instance
EFF.LlmPlanConf RIO
=> LlmPlanConf RIO
where
llmPlanAPI = getEnvVar "LLM_PLAN_LOCALHOST_API"
llmPlanKey = pure Nothing
--------------------------------------------------------------------------------
class
EFF.LlmPlanConf m
=> LlmPlanPost m
where
llmPlanWeb
:: String
-> m (Either String String)
instance
EFF.LlmPlanConf RIO
=> LlmPlanPost RIO
where
llmPlanWeb json =
EFF.llmPlanAPI >>= \ mapi ->
EFF.llmPlanKey >>= \ mkey ->
llmCurlChatCompletions json mapi mkey
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
class
EFF.LlmSpecConf m
=> LlmSpecConf m
where
llmSpecLib
:: m String
llmSpecMod
:: m String
llmSpecFun
:: m String
llmSpecDep
:: m [ String ]
llmSpecOto
:: m (Maybe Int)
instance
EFF.LlmSpecConf RIO
=> LlmSpecConf RIO
where
llmSpecLib = pure "spec"
llmSpecMod = pure "Spec.Core"
llmSpecFun = pure "testSuite"
llmSpecDep = pure [ "core", "common", "utils" ]
llmSpecOto = pure Nothing
--------------------------------------------------------------------------------
class
( EFF.LlmRepoAtom m
, EFF.LlmRepoTail m
, EFF.LlmCodeRoot m
, EFF.LlmSpecConf m
)
=> LlmSpecTest m
where
llmSpecRun
:: LLM.UUID
-> m (Either String LLM.TestCases)
instance
( EFF.LlmRepoAtom RIO
, EFF.LlmRepoTail RIO
, EFF.LlmCodeRoot RIO
, EFF.LlmSpecConf RIO
)
=> LlmSpecTest RIO
where
llmSpecRun (LLM.UUID uid) =
EFF.llmRepoDir >>= \ case
Just (LLM.Root root) ->
realPath root root >>= \ case
-- TODO: DRY
Right fap ->
EFF.llmRepoGet >>= \ case
Right (LLM.Branch pid@(LLM.UUID tid) _ _) ->
EFF.llmSpecLib >>= \ lib ->
EFF.llmSpecMod >>= \ mod ->
EFF.llmSpecFun >>= \ fun ->
EFF.llmSpecDep >>= \ dep ->
EFF.llmSpecOto >>= \ oto ->
EFF.llmCodeDir >>= \ dir ->
if tid == uid then
gitDiffFilesChanged fap ohd tid dir >>= \ efps ->
let
len =
-- NOTE: "src/"
length dir + 1
fsp =
case efps of
Right fps -> fps
Left ___ -> []
pts =
map
( ("Test." ++) .
map ( \c -> if c == '/' then '.' else c) .
takeWhile (/= '.') .
drop len
)
fsp
in
( \case
Right r -> Right r
Left e -> Left $ unlines e
)
<$> quickCheckSpec pid fap lib mod fun dep oto sep pts
else
EFF.llmRepoBrs >>= \ case
Right (LLM.Branches bs) ->
( \ (ls, rs) ->
if null ls then
Right $ foldl (<>) et rs
else
Left $ unlines $ concat ls
)
<$> eb
where
et = LLM.TestCases []
fb =
filter
( \ (LLM.Branch (LLM.UUID bid) _ _) ->
bid == uid
) bs
eb =
partitionEithers
<$> mapM
( \ (LLM.Branch bid@(LLM.UUID uid_) _ _) ->
gitDiffFilesChanged fap tid uid_ dir >>= \ efps ->
let
len =
-- NOTE: "src/"
length dir + 1
fsp =
case efps of
Right fps -> fps
Left ___ -> []
pts =
map
( ("Test." ++) .
map ( \c -> if c == '/' then '.' else c) .
takeWhile (/= '.') .
drop len
)
fsp
in
quickCheckSpec bid fap lib mod fun dep oto sep pts
) fb
Left es ->
pure $ Left $ unlines es
Left e ->
pure $ Left e
Left err ->
pure $ Left err
Nothing ->
pure $ Left noLlmConf
where
ohd = "origin/HEAD"
sep = '.'
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
class
EFF.LlmConf m
=> LlmHoneRoot m
where
llmHoneDir
:: m (Maybe LLM.Root)
instance
( EFF.LlmConf RIO
, EFF.LlmHoneRoot RIO
)
=> LlmHoneRoot RIO
where
llmHoneDir =
EFF.llmPathCWD >>= \ ocwd ->
case ocwd of
Just (LLM.Root root) ->
realPath root root >>= \ case
-- TODO: DRY
Right fap ->
-- NOTE: There MUST be only a single .cabal file in root (cwd)
findFiles fap "*.cabal" >>= \ case
Right fs ->
if 1 == length fs then
pure ocwd
else
pure Nothing
Left __ ->
pure Nothing
Left ____ ->
pure Nothing
Nothing ->
pure Nothing
--------------------------------------------------------------------------------
class
EFF.LlmHoneMask m
=> LlmHoneMask m
where
llmHoneMsk
:: m LLM.Mask
instance
( EFF.LlmConf RIO
, EFF.LlmHoneMask RIO
)
=> LlmHoneMask RIO
where
llmHoneMsk =
LLM.Mask . filter ( \ m -> "*.hs" == m || "*.lhs" == m )
<$> EFF.llmCodeMsk
--------------------------------------------------------------------------------
class
( EFF.LlmCodeRoot m
, EFF.LlmHoneRoot m
, EFF.LlmRepoTail m
, EFF.LlmHoneMask m
)
=> LlmHoneRead m
where
llmHoneSeq
:: Maybe LLM.Filter
-> m (Either [String] LLM.FilePaths)
llmHoneGet
:: LLM.AbsoluteFilePath
-> m (Either String LLM.File)
instance
( EFF.LlmCodeRoot RIO
, EFF.LlmHoneRoot RIO
, EFF.LlmRepoTail RIO
, EFF.LlmHoneMask RIO
)
=> LlmHoneRead RIO
where
llmHoneSeq mfilter =
EFF.llmCodeDir >>= \ cdir ->
EFF.llmHoneMsk >>= \ (LLM.Mask hmsk) ->
EFF.llmHoneDir >>= \ case
Just (LLM.Root cwd) ->
--
EFF.llmRepoGet >>= \ case
Right (LLM.Branch uid@(LLM.UUID tid) _ _) ->
--
realPath cwd cwd >>= \ efap ->
realPath cwd "tmp" >>= \ etmp ->
case (efap, etmp) of
(Right fap, Right tmp) ->
gitWorktreeAdd fap lid tap (Just uid) >>= \ case
Right _ ->
mapM
(\ msk ->
findFiles cap ("*" ++ fil ++ "*" ++ msk)
) hmsk >>= \ efs ->
case partitionEithers efs of
([], rs) ->
gitWorktreeRem fap tap >>
gitBranchRemove True fap lid >>
( pure
. Right
. LLM.FilePaths
. map
( \ filepath ->
fap ++ "/" ++ (drop . length) tap filepath
)
. mconcat
) rs
(ls, __) ->
gitWorktreeRem fap tap >>
gitBranchRemove True fap lid >>
(pure . Left) ls
Left e ->
-- NOTE: Ensure worktree branch is always removed
gitWorktreeRem fap tap >>
gitBranchRemove True fap lid >>
(pure . Left . lines) e
where
lid = (++ "_") $ map toLower tid
tap = tmp ++ "/" ++ lid ++ "/"
cap = tap ++ cdir ++ "/"
fil =
case mfilter of
Just (LLM.Filter f) -> f
Nothing -> [ ]
(other1, other2) ->
(pure . Left . lefts) [other1, other2]
--
Left e -> (pure . Left) [e]
--
Nothing ->
pure $ Left [noLlmConf]
llmHoneGet (LLM.AbsoluteFilePath abspath) =
EFF.llmHoneDir >>= \ case
Just (LLM.Root cwd) ->
--
EFF.llmRepoGet >>= \ case
Right (LLM.Branch uid@(LLM.UUID tid) _ _) ->
--
realPath cwd cwd >>= \ efap ->
realPath cwd "tmp" >>= \ etmp ->
case (efap, etmp) of
(Right fap, Right tmp) ->
gitWorktreeAdd fap lid tap (Just uid) >>= \ case
Right _ ->
--
readFileStrict tap_ >>= \ txt ->
if tap `isPrefixOf` tap_ then
-- NOTE: Ensure worktree branch is always removed
gitWorktreeRem fap tap >>
gitBranchRemove True fap lid >>
-- NOTE: Root relative path
( pure
. Right
. LLM.File
. (,) (drop len abspath)
. lines
) txt
else
-- NOTE: Ensure worktree branch is always removed
gitWorktreeRem fap tap >>
gitBranchRemove True fap lid >>
( pure
. Left
) (notPrefixRootAndMode fap abspath LLM.Hone)
Left e ->
-- NOTE: Ensure worktree branch is always removed
gitWorktreeRem fap tap >>
gitBranchRemove True fap lid >>
(pure . Left) e
where
lid = (++ "_") $ map toLower tid
tap = tmp ++ "/" ++ lid ++ "/"
tap_ = tap ++ drop (length cwd) abspath
len = length cwd
(other1, other2) ->
( pure
. Left
) ( (show . length) other1 ++ (show . length) other2
)
--
Left e -> (pure . Left) e
--
Nothing ->
pure $ Left noLlmConf
--------------------------------------------------------------------------------
class
( EFF.LlmConf m
, EFF.LlmRepoTail m
, EFF.LlmCodeRoot m
, EFF.LlmHoneRoot m
)
=> LlmHoneSave m
where
llmHonePut
:: LLM.Context a
-> String
-> LLM.Files
-> m (Either String String)
instance
( EFF.LlmConf RIO
, EFF.LlmRepoTail RIO
, EFF.LlmCodeRoot RIO
, EFF.LlmHoneRoot RIO
)
=> LlmHoneSave RIO
where
llmHonePut ctx txt fs =
EFF.llmRepoGet >>= \ case
Right (LLM.Branch uid _ _) ->
EFF.llmHoneDir >>=
( \case
Just __ -> llmCodePut ctx (Just uid) txt fs
Nothing -> (pure . Left) err
)
Left e -> pure $ Left e
where
-- TODO: DRY
err = "There MUST be only a single .cabal file in root (cwd)"
--------------------------------------------------------------------------------
class
( EFF.LlmConf m
, EFF.LlmHoneConf m
)
=> LlmHoneConf m
where
llmHoneSOM
:: m (Maybe String)
llmHoneKey
:: m (Maybe String)
instance
( EFF.LlmConf RIO
, EFF.LlmHoneConf RIO
)
=> LlmHoneConf RIO
where
llmHoneSOM = getEnvVar "LLM_HSOM_LOCALHOST_SOM"
llmHoneKey = pure Nothing
--------------------------------------------------------------------------------
class
( EFF.LlmConf m
, EFF.LlmHoneConf m
)
=> LlmHonePost m
where
llmHoneWeb
:: String
-> m (Either String String)
instance
( EFF.LlmConf RIO
, EFF.LlmHoneConf RIO
)
=> LlmHonePost RIO
where
llmHoneWeb json =
EFF.llmHoneSOM >>= \ msom ->
EFF.llmHoneKey >>= \ mkey ->
llmCurlSystemOne json msom mkey
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
-- HELPERS (public)
getEnvVar
:: String
-> RIO (Maybe String)
getEnvVar =
RestrictedIO . ENV.getEnv
--------------------------------------------------------------------------------
-- HELPERS (private)
timeout
:: Int
-> RIO a
-> RIO (Maybe a)
timeout secs rio =
RestrictedIO (ST.timeout (secs * 1_000_000) io)
where
(RestrictedIO io) = rio
findFiles
:: FilePath
-> String
-> RIO (Either String [String])
findFiles path mask =
-- NOTE: Remove any '\NUL` from filepaths
-- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/10110
( \case
Right str ->
Right
-- NOTE: We use absolute paths, but, only show relative
$ map (filter (/= '\NUL'))
$ lines str
Left err ->
Left err
)
<$> withExitCodeCwd path "find"
-- NOTE: Use -ipath and -iname (case insensitive) instead?
[ path
-- NOTE: Limit to files, excluding symbolic links
, "-type", "f"
-- NOTE: Exclude tmp folder
, "-not"
, "-path"
, path ++ "/tmp/*"
, "-and"
-- NOTE: Exclude llm tpl folder
, "-not"
, "-ipath"
, path ++ "/llm/*"
, "-and"
-- NOTE: Exclude dot files and hereby tmp Emacs files (.*#)
, "-not"
, "-name"
, ".*"
, "-and"
-- NOTE: Look for filter mask
, "-path"
, mask
, "-print"
]
noLlmConf :: String
noLlmConf =
"No EFF.LlmConf instance is defined."
notPrefixRootAndMode
:: FilePath
-> FilePath
-> LLM.Mode
-> String
notPrefixRootAndMode rpath apath mode =
rpath ++ " is not a prefix of " ++ apath ++ " for: " ++ show mode
gitExist
:: FilePath
-> RIO Bool
gitExist path =
( \case
Right _ -> True
Left _ -> False
)
<$> withExitCodeCwd path "git"
[ "status"
]
gitignoreTmp
:: FilePath
-> RIO Bool
gitignoreTmp path =
elem "/tmp/" . lines
<$> readFileStrict gi
where
gi = path ++ "/.gitignore"
gitWorktreeAdd
:: FilePath
-> String
-> FilePath
-> Maybe LLM.UUID
-> RIO (Either String String)
gitWorktreeAdd root ts path ouid =
withExitCodeCwd root "git"
( [ "worktree"
, "add"
, path
]
++ maybe [] ( \ (LLM.UUID uid) -> [uid]) ouid ++
[ "-b", ts
]
)
gitAddCommit
:: FilePath
-> String
-> RIO (Either String String)
gitAddCommit root mesg =
withExitCodeCwd root "git"
[ "commit"
, "-a"
, "-m"
, mesg
]
gitWorktreeRem
:: FilePath
-> FilePath
-> RIO (Either String String)
gitWorktreeRem root path =
withExitCodeCwd root "git"
[ "worktree"
, "remove"
, path
]
gitWorktreeMer
:: FilePath
-> [LLM.UUID]
-> RIO (Either String String)
gitWorktreeMer root bids =
if null bids then
(pure . Left) "No non-failing branches are provided to merge"
else
withExitCodeCwd root "git"
( [ "merge"
, "--no-edit"
, "-s", "octopus"
]
++ map ( \ (LLM.UUID uid) -> uid) bids
)
gitFetchMerge
:: FilePath
-> String
-> String
-> RIO (Either String String)
gitFetchMerge root ts origin =
withExitCodeCwd root "git"
[ "fetch"
, "."
, ts ++ ":" ++ origin
]
gitDiff
:: FilePath
-> String
-> String
-> RIO (Either [String] [String])
gitDiff root origin ts {- dir -} =
( \ es eds ecs epa ->
case (es, eds, ecs, epa) of
(Right sf, Right sd, Right cs, Right c) ->
Right
$ lines
$ bs ++ "\n" ++ fs ++ "\n" ++ ds ++ "\n" ++ ms ++ "\n" ++ am
where
bs = "# Diff between: '" ++ ts ++ "' and '" ++ origin ++ "'"
fs = "## Files:\n" ++ sf
ds = "## Directories:\n" ++ sd
ms = "## Commits:\n" ++ cs
am = "## Merging:\n" ++
( case c of
LT ->
" Parent: '" ++ origin ++
"' is ahead of child: '" ++ ts ++ "'\n" ++
" and therefore, it can't be auto-merged."
EQ ->
" Parent: '" ++ origin ++
"' is the same as child: '" ++ ts ++ "'\n" ++
" and therefore, it makes no sense to merge."
GT ->
" Parent: '" ++ origin ++
"' isn't ahead of child: '" ++ ts ++ "'\n" ++
" and therefore, it can be auto-merged."
)
_______________________________________ ->
Left $ lefts [es, eds, ecs ] ++ lefts [ epa ]
)
<$> withExitCodeCwd root "git"
[ "diff"
, "--stat"
, "--stat-graph-width", "80"
, origin
, ts
-- , dir
]
<*> withExitCodeCwd root "git"
[ "diff"
, "--dirstat=files"
, origin
, ts
-- , dir
]
<*> withExitCodeCwd root "git"
[ "cherry", "-v"
, origin
, ts
]
<*> gitBranchAheadParent root ts origin
gitDiffFilesChanged
:: FilePath
-> String
-> String
-> String
-> RIO (Either String [String])
gitDiffFilesChanged root origin ts dir =
-- NOTE: «… Added (A), …, Modified (M) …»
-- https://git-scm.com/docs/git-diff#Documentation/git-diff.txt---diff-filterACDMRTUXB
( \case
Right txt ->
case LLM.gd2fps txt of
Right fps ->
Right $ filter (dir `isPrefixOf`) fps
Left err ->
Left $ show err
Left err ->
Left err
)
<$> withExitCodeCwd root "git"
[ "diff"
, "--name-status"
, "--diff-filter=AM"
, origin ++ ".." ++ ts
]
gitBranch
:: FilePath
-> String
-> String
-> RIO (Either String ())
gitBranch root ts origin =
( \case
Right _ -> Right ()
Left err -> Left err
)
<$> withExitCodeCwd root "git"
[ "branch"
, ts
, origin
]
gitBranchesDesc
:: FilePath
-> RIO (Either String [String])
gitBranchesDesc root =
( \case
Right txt -> (Right . lines) txt
Left err ->
-- NOTE: "Returns error code 1 if key is not present".
--
-- https://git-scm.com/docs/git-config#Documentation/git-config.txt-get
if null err then
Right []
else
Left err
)
<$> withExitCodeCwd root "git"
[ "config"
, "--local"
, "--get-regexp"
, "branch.*.description"
]
gitBranchDescUpdate
:: FilePath
-> String
-> String
-> RIO (Either String String)
gitBranchDescUpdate path ts desc =
withExitCodeCwd path "git"
[ "config"
, "--local"
, "branch." ++ ts ++ ".description"
, desc
]
gitBranchAheadParent
:: FilePath
-> String
-> String
-> RIO (Either String Ordering)
gitBranchAheadParent root child parent =
( \ eap ebp ->
case (eap, ebp) of
(Right ap, Right bp) ->
case (map_, mbp) of
(Just a, Just b) ->
case (a, b) of
-- NOTE:
-- a) If they are equal, they are the same
-- b) If it's not behind, it's ahead
-- c) If it's not ahead, it's behind
-- d) It can't be both ahead and behind (Unexpected error)
(0,0) -> Right EQ
(_,0) -> Right LT
(0,_) -> Right GT
_____ -> Left "Unexpected error"
_______________ -> Left "Unexpected error"
where
map_ = (readMaybe . UTL.trim) ap :: Maybe Int
mbp = (readMaybe . UTL.trim) bp :: Maybe Int
(other1, other2) ->
Left $ unlines $ lefts [other1, other2]
)
<$> withExitCodeCwd root "git"
[ "rev-list", "--count"
, child ++ ".." ++ parent
]
<*> withExitCodeCwd root "git"
[ "rev-list", "--count"
, parent ++ ".." ++ child
]
gitBranchRemove
:: Bool
-> FilePath
-> String
-> RIO (Either String String)
gitBranchRemove force root ts =
( \case
Right txt ->
Right $ UTL.trim txt
Left err ->
Left err
)
<$> withExitCodeCwd root "git"
[ "branch"
, if force then "-D" else "-d"
, ts
]
gitBranchPushOrigin
:: FilePath
-> String
-> RIO (Either String String)
gitBranchPushOrigin root ts =
( \case
Right txt ->
Right $ UTL.trim txt
Left err ->
Left err
)
<$> withExitCodeCwd root "git"
[ "push"
, "--set-upstream"
, "origin"
, ts
]
gitBranchPullOrigin
:: FilePath
-> RIO (Either String String)
gitBranchPullOrigin root =
( \ ef ep ->
case (ef, ep) of
(Right f, Right p) ->
Right $ UTL.trim f ++ "\n" ++ UTL.trim p
(other1, other2) ->
(Left . unlines . lefts) [other1, other2]
)
<$> withExitCodeCwd root "git"
[ "fetch"
, "origin"
, "--prune"
]
<*> withExitCodeCwd root "git"
[ "pull"
]
{-
gitBranchCreatedFrom
:: FilePath
-> String
-> RIO (Maybe String)
gitBranchCreatedFrom root ts =
( \case
Right txt ->
case idxOf pat txt of
Just idx -> Just $ drop (len idx) txt
Nothing -> Nothing
where
pat = "@{0}: branch: "
len i = length pat + i
Left ___ -> Nothing
)
<$> withExitCodeCwd root "git"
[ "reflog"
, "show"
, ts
]
where
idxOf pat txt
| null pat = Just 0
| otherwise = aux 0 txt
where
aux _ [ ] = Nothing
aux i cs@(_:rs)
| pat `isPrefixOf` cs = Just i
| otherwise = aux (i + 1) rs
-}
llmCurlChatCompletions
:: String
-> Maybe String
-> Maybe String
-> RIO (Either String String)
llmCurlChatCompletions json mapi mkey =
case (mapi, mkey) of
(Nothing, _ ) ->
RestrictedIO $ pure $ Left "No API address was provided"
(Just api, Nothing) ->
withExitCodeStdInOCwd
False
Nothing
"curl"
( [ -- "--verbose"
"--silent"
, "--show-error"
]
++ hs ++
[ -- NOTE: https://curl.se/docs/manpage.html#--json
"--json", "@-"
, api ++ "/chat/completions"
]
)
json
(Just api, Just key) ->
withExitCodeStdInOCwd
False
Nothing
"curl"
( [ --"--verbose"
"--silent"
, "--show-error"
, "--header", "Authorization: " ++ key
]
++ hs ++
[ -- NOTE: https://curl.se/docs/manpage.html#--json
"--json", "@-"
, api ++ "/chat/completions"
]
)
json
where
hs =
[ "--header" , "Accept: application/json"
, "--header" , "Accept-Encoding: gzip, deflate, br"
, "--header" , "Content-Type: application/json; charset=utf-8"
, "--header" , "User-Agent: Λ-gent/0.11"
]
llmCurlSystemOne
:: String
-> Maybe String
-> Maybe String
-> RIO (Either String String)
llmCurlSystemOne json msom mkey =
case (msom, mkey) of
(Nothing, _ ) ->
RestrictedIO $ pure $ Left "No SOM address was provided"
(Just som, Nothing) ->
withExitCodeStdInOCwd
False
Nothing
"curl"
( [ -- "--verbose"
"--silent"
, "--show-error"
]
++ hs ++
[ -- NOTE: https://curl.se/docs/manpage.html#--json
"--json", "@-"
, som ++ "/systemone"
]
)
json
(Just som, Just key) ->
withExitCodeStdInOCwd
False
Nothing
"curl"
( [ --"--verbose"
"--silent"
, "--show-error"
, "--header", "Authorization: " ++ key
]
++ hs ++
[ -- NOTE: https://curl.se/docs/manpage.html#--json
"--json", "@-"
, som ++ "/systemone"
]
)
json
where
hs =
[ "--header" , "Accept: application/json"
, "--header" , "Accept-Encoding: gzip, deflate, br"
, "--header" , "Content-Type: application/json; charset=utf-8"
, "--header" , "User-Agent: Λ-gent/0.11"
]
typedHolesDev
:: Maybe LLM.UUID
-> FilePath
-> RIO (Either [String] [LLM.GhcError])
typedHolesDev Nothing _ =
pure $ Left [ "No TAIL exists" ]
typedHolesDev mpid@(Just (LLM.UUID tid)) cwd =
-- NOTE: Filter out anything else than Typed-Hole errors
--
-- https://errors.haskell.org/messages/GHC-88464/
-- TODO: DRY
realPath cwd cwd >>= \ efap ->
realPath cwd "tmp" >>= \ etmp ->
case (efap, etmp) of
(Right fap, Right tmp) ->
gitWorktreeAdd fap lid tap mpid >>= \ case
Right _ ->
aux tap >>= \ case
Right ts ->
fts >>= \ efts ->
let
(lfts, rfts) = partitionEithers efts
in
-- NOTE: Ensure worktree branch is always removed
gitWorktreeRem fap tap >>
gitBranchRemove True fap lid >>
( if null lfts then
pure $ Right rfts
else
pure $ Left lfts
)
where
fts =
mapM
( \ ghcerr ->
let
(f, l, c) = LLM.getGhcErrorLocation ghcerr
in
realPath fap (drop len f) >>= \ case
Right f_ ->
pure $ Right $ LLM.setGhcErrorLocation (f_, l, c) ghcerr
Left l_ ->
pure $ Left l_
)
ts
Left l ->
-- NOTE: Ensure worktree branch is always removed
gitWorktreeRem fap tap >>
gitBranchRemove True fap lid >>
(pure . Left) l
Left e ->
pure $ Left $ lines e
where
lid = (++ "_") $ map toLower tid
tap = tmp ++ "/" ++ lid ++ "/"
len = length tap
(other1, other2) ->
pure $ Left $ lefts [other1, other2]
where
aux wcwd =
( \case
Right txt ->
case LLM.txt2ghces $ lines $ cabalUpdateWarning txt of
Right rs -> Right $ filter LLM.ghcErrorHole rs
Left ls -> Left $ map show ls
Left err -> Left [err]
)
<$> withExitCodeStdInOCwd
True -- NOTE: Only read from stderr
(Just wcwd)
"cabal"
[ "repl"
, "-O0"
, "--enable-multi-repl"
, "--repl-options=" ++ unwords rops
]
quit
where
-- NOTE: It seems that if you pass `stdin` to `cabal repl` it will
-- automatically exit. Therefore, it doesn't seem necesary to pass ":q"
--
-- NOTE: `-fdiagnostics-as-json` flag is introduced in ghc-9.10,
-- however, we support ghc-9.6.7 and ghc-9.8.4 as well, therefore, we
-- can't use it.
quit = []
rops =
[ --
"-ignore-dot-ghci"
-- NOTE: Limit number of typed-holes per file. Ideally it SHOULD be
-- by project, but for now, will take it
, "-fmax-errors=5"
--
, "-fno-code"
-- NOTE: Avoid the `Some … suppressed` message
, "-fno-max-relevant-binds"
, "-fno-max-valid-hole-fits"
, "-fno-max-refinement-hole-fits"
-- NOTE: Try with n = 1, 2, 4 or 8 (n = number of args for a function)
, "-frefinement-level-hole-fits=8"
--
, "-fsort-by-subsumption-hole-fits"
, "-funclutter-valid-hole-fits"
]
quickCheckSpec
:: LLM.UUID
-> FilePath
-> String
-> String
-> String
-> [String]
-> Maybe Int
-> Char
-> [String]
-> RIO (Either [String] LLM.TestCases)
quickCheckSpec pid@(LLM.UUID bid) cwd lib mod fun dep oto sep pts =
-- TODO: DRY
realPath cwd cwd >>= \ efap ->
realPath cwd "tmp" >>= \ etmp ->
case (efap, etmp) of
(Right fap, Right tmp) ->
gitWorktreeAdd fap lid tap (Just pid) >>= \ case
Right _ ->
aux tap >>= \ case
Right tcs ->
-- NOTE: Ensure worktree branch is always removed
gitWorktreeRem fap tap >>
gitBranchRemove True fap lid >>
(pure . Right) tcs
Left l ->
-- NOTE: Ensure worktree branch is always removed
gitWorktreeRem fap tap >>
gitBranchRemove True fap lid >>
(pure . Left) l
Left e ->
pure $ Left $ lines e
where
lid = (++ "_") $ map toLower bid
tap = tmp ++ "/" ++ lid ++ "/"
(other1, other2) ->
pure $ Left $ lefts [other1, other2]
where
aux wcwd =
if escs then
( \case
Right txt ->
case etcs of
Right tcs -> Right tcs
Left des -> Left $ map show des
where
etcs =
LLM.jsonl2tcs wcwd
$ filter (isPrefixOf "{\"label\":\"Test")
$ lines
$ cabalUpdateWarning txt
Left err ->
Left [err]
)
<$> withExitCodeStdInOCwd
False -- NOTE: Only read from stdout
(Just wcwd)
"cabal"
( [ "repl"
, lib
] ++ dep ++
[ "-O0"
, "--enable-multi-repl"
, "--ghc-option=" ++ unwords gops
, "--repl-options=" ++ unwords rops
]
)
(unlines exec)
else
(pure . Left)
[ "The provided LlmSpecConf values: " ++
"llmSpecLib, llmSpecMod, llmSpecFun and/or llmSpecDep, " ++
"do not comply with the naming mask of: [azAZ-_]."
]
where
-- NOTE: It seems that if you pass `stdin` to `cabal repl` it will
-- automatically exit. Therefore, it doesn't seem necesary to pass ":q"
exec =
[ ":set prompt \"\""
, ":set prompt-cont \"\""
, "import Data.Maybe (Maybe (Just, Nothing))"
, "import Prelude (mapM_, putStrLn, (>>=))"
, "import System.IO (hSetEncoding, stderr, stdout, utf8)"
, "import Test.QuickCheck.Silent (quickCheckSilentSuiteJSON)"
, "hSetEncoding stderr utf8"
, "hSetEncoding stdout utf8"
, "putStrLn []"
, "quickCheckSilentSuiteJSON"
++ " " ++ t ++ " " ++ s ++ " " ++ p ++ " " ++ f ++ " " ++ m
]
where
t = "(" ++ show oto ++ ")"
s = "'" ++ [sep] ++ "'"
p = "[" ++ csp ++ "]"
where
csp =
-- NOTE: `foldl1` throws an Exception on empty lists
case map ( \ p_ -> "\"" ++ p_ ++ "\"" ) pts of
[] -> []
xs -> foldl1 ( \ x y -> x ++ "," ++ y) xs
f = " " ++ mod ++ [sep] ++ fun
m = ">>= mapM_ putStrLn"
gops =
[ "-package quickcheck-silent-0.11.0.17"
]
rops =
[ -- NOTE: Since we don't use the `-fno-code` flag, this trick:
-- `--ghc-options "-osuf dyn_o -hisuf dyn_hi"` might be
-- relevant. More info: https://jade.fyi/blog/cabal-test-dev-trick/
"-osuf dyn_o"
, "-hisuf dyn_hi"
--
, "-ignore-dot-ghci"
-- NOTE: Limit number of typed-holes per file. Ideally it SHOULD be
-- by project, but for now, will take it
, "-fmax-errors=5"
-- NOTE: Allow for runtime typed-holes and ensure warnings
, "-Wwarn"
, "-fdefer-typed-holes"
-- NOTE: Only trust QC and dependencies
, "-fpackage-trust"
, "-trust=base"
, "-trust=QuickCheck"
, "-trust=array"
, "-trust=containers"
, "-trust=deepseq"
, "-trust=ghc-prim"
, "-trust=random"
, "-trust=splitmix"
]
escs =
-- NOTE: Naive implementatoin of "Exploits of a Mom":
-- - https://xkcd.com/327/ (Little Bobby Tables)
all vcs lib &&
all vcs mod &&
all vcs fun &&
( all id . map (all vcs)
) dep
where
vcs =
\ c ->
'a' <= c && c <= 'z' ||
'A' <= c && c <= 'Z' ||
c == '-' ||
c == '_'
cabalUpdateWarning
:: String
-> String
cabalUpdateWarning txt =
-- NOTE: Remove annoying warning from cabal:
--
-- Warning: The package list for 'hackage.haskell.org' is 26 days old.
-- Run 'cabal update' to get the latest list of available packages.
unlines
$ filter ( not . (upd `isInfixOf`))
$ filter
( \ l ->
not (pre `isPrefixOf` l && suf `isSuffixOf` l)
)
$ lines txt
where
pre = "Warning: The package list for 'hackage.haskell.org' is"
suf = "days old."
upd = "Run 'cabal update' to get the latest list of available packages."
readFileStrict
:: FilePath
-> RIO String
readFileStrict path =
-- TODO: Refactor `RIO String` to `RIO (Either String String)`
RestrictedIO $
do
eproc <-
try aux :: IO (Either SomeException String)
case eproc of
Right txt -> pure txt
Left ___ -> pure []
where
aux =
readFile path >>= \cs ->
length cs `seq` pure cs
writeFileStrict
:: FilePath
-> String
-> RIO (Either String String)
writeFileStrict path txt =
RestrictedIO $
do
eproc <-
try
( writeFile path txt
) :: IO (Either SomeException ())
case eproc of
Right _ ->
pure $ Right path
Left e -> pure $ Left $ show e
realPath
:: FilePath
-> FilePath
-> RIO (Either String String)
realPath cwd path =
-- NOTE: `realpath` removes any trailing '/' for directories
--
-- NOTE: Remove any '\NUL` from filepaths
-- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/10110
( \case
Right str -> Right $ filter (/= '\n') str
Left err -> Left err
)
<$> withExitCodeCwd cwd "realpath"
[ path
]
ensureFolderPath
:: FilePath
-> FilePath
-> RIO (Either String String)
ensureFolderPath root path =
withExitCodeCwd root "dirname" [ path ] >>= \ case
Right adp ->
( \ case
Right _ -> Right sadp
Left e -> Left e
)
<$> withExitCodeCwd root "mkdir" [ "-p", sadp ]
where
sadp = filter (/= '\n') adp
Left err -> pure $ Left err
timestampUTC :: RIO (Maybe String)
timestampUTC =
( \case
Right cs -> Just $ filter ( \ c -> c == '-' || isDigit c ) cs
Left __ -> Nothing
)
<$> withExitCode "date"
[ "-u"
, "+'%Y%m%d-%H%M%S-%N'"
]
withExitCode
:: String
-> [String]
-> RIO (Either String String)
withExitCode cmd args =
RestrictedIO $
do
eproc <-
try
( readProcessWithExitCode cmd args []
) :: IO (Either SomeException (ExitCode, String, String))
case eproc of
Right (exitcode, out, err) ->
case exitcode of
ExitSuccess ->
pure $ Right out
ExitFailure _ ->
pure $ Left err
Left e -> pure $ Left $ show e
withExitCodeCwd
:: String
-> String
-> [String]
-> RIO (Either String String)
withExitCodeCwd path cmd args =
RestrictedIO $
do
eproc <-
try
( readCreateProcessWithExitCode rcp []
) :: IO (Either SomeException (ExitCode, String, String))
case eproc of
Right (exitcode, out, err) ->
case exitcode of
ExitSuccess ->
pure $ Right out
ExitFailure _ ->
pure $ Left err
Left e -> pure $ Left $ show e
where
raw = proc cmd args
rcp = raw { SP.cwd = Just path }
withExitCodeStdInOCwd
:: Bool
-> Maybe String
-> String
-> [String]
-> String
-> RIO (Either String String)
withExitCodeStdInOCwd diag opath cmd args txt =
RestrictedIO $
do
eproc <-
try
aux :: IO (Either SomeException (ExitCode, String, String))
case eproc of
Right (exitcode, out, err) ->
case exitcode of
ExitSuccess ->
-- NOTE: When debugging, ex: `curl`, add the `--verbose` flag,
-- which uses `stderr`. Just combine `err` and `out` like this:
--
--pure $ Right ("[DEBUG]: " ++ err ++ "\n" ++ out)
if diag then
pure $ Right err
else
pure $ Right out
ExitFailure _ ->
pure $ Left err
Left e -> pure $ Left $ show e
where
raw = proc cmd args
rcp =
raw
{ SP.cwd = opath
, std_in = CreatePipe
, std_out = CreatePipe
, std_err = CreatePipe
}
aux =
do
(Just hinp, Just hout, Just herr, ph) <- createProcess rcp
hPutStrLn hinp txt
hClose hinp
-- NOTE: Using strict version of `hGetContents`
out <- hGetContents' hout
err <- hGetContents' herr
exitcode <- waitForProcess ph
return (exitcode, out, err)
dropLastN :: Int -> [a] -> [a]
dropLastN _ [] = []
dropLastN 0 xs = xs
dropLastN n xs = dropLastN (n-1) (init xs)