never executed always true always false

    1 module PureClaw.Agent.Compaction
    2   ( -- * Compaction
    3     compactContext
    4   , CompactionResult (..)
    5     -- * Configuration
    6   , defaultTokenLimit
    7   , defaultKeepRecent
    8   ) where
    9 
   10 import Control.Exception
   11 import Data.Text (Text)
   12 import Data.Text qualified as T
   13 
   14 import PureClaw.Agent.Context
   15 import PureClaw.Core.Types
   16 import PureClaw.Providers.Class
   17 
   18 -- | Result of a compaction attempt.
   19 data CompactionResult
   20   = Compacted Int Int     -- ^ old message count, new message count
   21   | NotNeeded             -- ^ context is below threshold
   22   | CompactionError Text -- ^ provider error during summarization
   23   deriving stock (Show, Eq)
   24 
   25 -- | Default context window token limit (200k for Claude).
   26 defaultTokenLimit :: Int
   27 defaultTokenLimit = 200000
   28 
   29 -- | Default number of recent messages to keep uncompacted.
   30 defaultKeepRecent :: Int
   31 defaultKeepRecent = 10
   32 
   33 -- | Compact a context by summarizing old messages via the provider.
   34 --
   35 -- Keeps the most recent @keepRecent@ messages intact and asks the
   36 -- provider to summarize the older ones into a single message. The
   37 -- summary replaces the old messages in the context.
   38 --
   39 -- Returns 'NotNeeded' if the context is below the token threshold.
   40 compactContext
   41   :: Provider p
   42   => p
   43   -> ModelId
   44   -> Int        -- ^ token threshold (compact when estimated tokens exceed this)
   45   -> Int        -- ^ number of recent messages to keep
   46   -> Context
   47   -> IO (Context, CompactionResult)
   48 compactContext provider model threshold keepRecent ctx
   49   | contextTokenEstimate ctx < threshold = pure (ctx, NotNeeded)
   50   | contextMessageCount ctx <= keepRecent = pure (ctx, NotNeeded)
   51   | otherwise = do
   52       let msgs = contextMessages ctx
   53           oldCount = length msgs - keepRecent
   54           (oldMsgs, recentMsgs) = splitAt oldCount msgs
   55           summaryPrompt = buildSummaryPrompt oldMsgs
   56       summaryResult <- summarize provider model summaryPrompt
   57       case summaryResult of
   58         Left err -> pure (ctx, CompactionError err)
   59         Right summaryText ->
   60           let summaryMsg = textMessage User ("[Context summary] " <> summaryText)
   61               newMsgs = summaryMsg : recentMsgs
   62               ctx' = replaceMessages newMsgs ctx
   63           in pure (ctx', Compacted (length msgs) (length newMsgs))
   64 
   65 -- | Build a prompt asking the provider to summarize conversation history.
   66 buildSummaryPrompt :: [Message] -> Text
   67 buildSummaryPrompt msgs =
   68   "Summarize the following conversation history concisely. "
   69   <> "Preserve key facts, decisions, file paths, and context needed "
   70   <> "to continue the conversation. Be brief but complete.\n\n"
   71   <> T.intercalate "\n\n" (map formatMessage msgs)
   72 
   73 -- | Format a message for the summary prompt.
   74 formatMessage :: Message -> Text
   75 formatMessage msg =
   76   let role = case _msg_role msg of
   77         User      -> "User"
   78         Assistant -> "Assistant"
   79       content = T.intercalate " " [extractText b | b <- _msg_content msg]
   80   in role <> ": " <> content
   81 
   82 -- | Extract text content from a block.
   83 extractText :: ContentBlock -> Text
   84 extractText (TextBlock t) = t
   85 extractText (ToolUseBlock _ name _) = "[tool:" <> name <> "]"
   86 extractText (ImageBlock mediaType _) = "[image:" <> mediaType <> "]"
   87 extractText (ToolResultBlock _ parts _) = "[result:" <> T.take 100 (partsText parts) <> "]"
   88 
   89 -- | Extract text from tool result parts.
   90 partsText :: [ToolResultPart] -> Text
   91 partsText ps = T.intercalate " " [t | TRPText t <- ps]
   92 
   93 -- | Call the provider to generate a summary.
   94 summarize :: Provider p => p -> ModelId -> Text -> IO (Either Text Text)
   95 summarize provider model prompt = do
   96   let req = CompletionRequest
   97         { _cr_model        = model
   98         , _cr_messages     = [textMessage User prompt]
   99         , _cr_systemPrompt = Just "You are a conversation summarizer. Produce a concise summary."
  100         , _cr_maxTokens    = Just 1024
  101         , _cr_tools        = []
  102         , _cr_toolChoice   = Nothing
  103         }
  104   result <- try @SomeException (complete provider req)
  105   case result of
  106     Left e -> pure (Left (T.pack (show e)))
  107     Right resp ->
  108       let text = responseText resp
  109       in if T.null (T.strip text)
  110            then pure (Left "Provider returned empty summary")
  111            else pure (Right text)