First Types

.gitignore

@@ -22,4 +22,3 @@ cabal.project.local
 cabal.project.local~
 .HTF/
 .ghc.environment.*
-

CHANGELOG.md

@@ -0,0 +1,5 @@
+# Revision history for hagent
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

app/Main.hs

@@ -0,0 +1,53 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Main where
+
+import Agent.Server.Config (Config, configFile, loadConfigOrDefault, saveConfig)
+import Agent.Tools.Time ()
+import Agent.Tools.Tool (Tool, getToolListTH, toMarkdownDL)
+import Control.Concurrent (threadDelay)
+import Control.Exception (AsyncException (UserInterrupt), bracket, catch)
+import Control.Monad (when)
+import qualified Data.ByteString as BS
+import Data.Default
+import Data.Either (fromRight, isRight)
+import Data.Either.Extra (fromRight')
+import Data.Proxy
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+import Data.Yaml (decodeFileThrow)
+import qualified Data.Yaml as YAML
+import Language.Haskell.TH
+import System.IO (hFlush, stdout)
+
+main :: IO ()
+main = do
+  (conf :: Config) <- (configFile >>= maybe (return def) decodeFileThrow)
+
+  let availableTools = ($(getToolListTH) :: [Tool])
+  putStrLn "# HAgent\n"
+  putStrLn "\n## Cofig\n"
+  BS.putStr $ (YAML.encode conf) <> "\n"
+  putStrLn "## Available Tools\n"
+  mapM_ T.putStrLn $ toMarkdownDL <$> availableTools
+  bracket acquireResource releaseResource $ \_ ->
+    mainLoop `catch` handler
+  where
+    acquireResource :: IO ()
+    acquireResource = putStrLn "Acquiring resource..."
+
+    releaseResource :: () -> IO ()
+    releaseResource _ = putStrLn "Releasing resource..."
+
+    mainLoop :: IO ()
+    mainLoop = do
+      putStr "waiting for work ...\r"
+      hFlush stdout
+      -- Simulate work
+      -- Add your main loop logic here
+      threadDelay 1000000
+      mainLoop
+
+    handler :: AsyncException -> IO ()
+    handler UserInterrupt = putStrLn "\nCaught Ctrl-C. Exiting gracefully."

cabal.project

@@ -0,0 +1 @@
+packages: *.cabal

hagent.cabal

@@ -0,0 +1,96 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.38.0.
+--
+-- see: https://github.com/sol/hpack
+
+name:               hagent
+version:            0.1.0.0
+license:            AGPL-3.0
+license-file:       LICENSE
+author:             Nicole Dresselhaus
+maintainer:         nicole@dresselhaus.cloud
+build-type:         Simple
+
+library
+    exposed-modules:
+        Agent.Server.Config
+        Agent.Tools.Tool
+        Agent.Tools.Time
+    other-modules:
+        Paths_hagent
+    build-depends:
+        base >=4.20.0 && <4.21,
+        bytestring,
+        data-default >=0.8.0 && <0.9,
+        directory >=1.3.8 && <1.4,
+        extra ==1.8.*,
+        filepath >=1.5.2 && <1.6,
+        ollama-haskell >=0.1.2 && <0.2,
+        template-haskell,
+        text,
+        yaml >=0.11.11 && <0.12
+    hs-source-dirs:
+        src
+    default-extensions:
+        OverloadedStrings
+        DerivingStrategies
+        DeriveAnyClass
+        DeriveGeneric
+        DerivingVia
+        GADTs
+    default-language: Haskell2010
+
+executable hagent
+    main-is: Main.hs
+    other-modules:
+        Paths_hagent
+    build-depends:
+        base >=4.20.0 && <4.21,
+        bytestring,
+        data-default >=0.8.0 && <0.9,
+        directory >=1.3.8 && <1.4,
+        extra ==1.8.*,
+        filepath >=1.5.2 && <1.6,
+        hagent,
+        ollama-haskell >=0.1.2 && <0.2,
+        template-haskell,
+        text,
+        yaml >=0.11.11 && <0.12
+    hs-source-dirs:
+        app
+    default-extensions:
+        OverloadedStrings
+        DerivingStrategies
+        DeriveAnyClass
+        DeriveGeneric
+        DerivingVia
+        GADTs
+    default-language: Haskell2010
+
+test-suite hagent-test
+    default-language: Haskell2010
+    type: exitcode-stdio-1.0
+    hs-source-dirs:
+        test
+    default-extensions:
+        OverloadedStrings
+        DerivingStrategies
+        DeriveAnyClass
+        DeriveGeneric
+        DerivingVia
+        GADTs
+    main-is: Main.hs
+    other-modules:
+        Paths_hagent
+    build-depends:
+        base >=4.20.0 && <4.21,
+        bytestring,
+        data-default >=0.8.0 && <0.9,
+        directory >=1.3.8 && <1.4,
+        extra ==1.8.*,
+        filepath >=1.5.2 && <1.6,
+        hagent,
+        ollama-haskell >=0.1.2 && <0.2,
+        text,
+        yaml >=0.11.11 && <0.12

package.yaml

@@ -0,0 +1,43 @@
+name: hagent
+version: '0.1.0.0'
+author: Nicole Dresselhaus
+maintainer: nicole@dresselhaus.cloud
+license: AGPL-3.0
+dependencies:
+  - base >= 4.20.0 && < 4.21
+  - data-default >= 0.8.0 && < 0.9
+  - directory >= 1.3.8 && < 1.4
+  - filepath >= 1.5.2 && < 1.6
+  - extra >= 1.8 && < 1.9
+  - ollama-haskell >= 0.1.2 && < 0.2
+  - yaml >= 0.11.11 && < 0.12
+  - text
+  - bytestring
+default-extensions:
+  - OverloadedStrings
+  - DerivingStrategies
+  - DeriveAnyClass
+  - DeriveGeneric
+  - DerivingVia
+  - GADTs
+library:
+  source-dirs: src
+  exposed-modules:
+  - Agent.Server.Config
+  - Agent.Tools.Tool
+  - Agent.Tools.Time
+  dependencies:
+  - template-haskell
+executables:
+  hagent:
+    main: Main.hs
+    source-dirs: app
+    dependencies:
+    - hagent
+    - template-haskell
+tests:
+  hagent-test:
+    main: Main.hs
+    source-dirs: test
+    dependencies:
+    - hagent

src/Agent/Server/Config.hs

@@ -0,0 +1,92 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Agent.Server.Config
+  ( configPath,
+    loadConfig,
+    loadConfigOrDefault,
+    saveConfig,
+    Config (..),
+    OllamaConfig (..),
+    NoConfigFoundException,
+    configFile,
+  )
+where
+
+import Control.Exception (Exception (..))
+import Control.Monad.Extra (whenMaybeM)
+import Data.Default (Default (..))
+import Data.Text (Text (..))
+import Data.Yaml (FromJSON, ParseException (..), ToJSON, decodeFileEither, decodeFileThrow, encodeFile)
+import GHC.Generics (Generic)
+import System.Directory (XdgDirectory (..), createDirectoryIfMissing, doesFileExist, getXdgDirectory)
+import System.FilePath ((</>))
+
+data Config = Config
+  { startOllama :: Bool,
+    ollama :: OllamaConfig
+  }
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (FromJSON, ToJSON)
+
+instance Default Config where
+  def =
+    Config
+      { startOllama = False,
+        ollama = def
+      }
+
+data OllamaConfig = OllamaConfig
+  { host :: Text,
+    port :: Int,
+    cmdExtra :: Text
+  }
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (FromJSON, ToJSON)
+
+instance Default OllamaConfig where
+  def =
+    OllamaConfig
+      { host = "localhost",
+        port = 11434,
+        cmdExtra = ""
+      }
+
+data NoConfigFoundException = NotFound FilePath
+  deriving (Show)
+
+instance Exception NoConfigFoundException
+
+configPath :: FilePath
+configPath = "hAgent"
+
+configName :: FilePath
+configName = "config.yaml"
+
+configFile :: IO (Maybe FilePath)
+configFile = do
+  filepath <- (getXdgDirectory XdgConfig (configPath </> configName))
+  whenMaybeM (doesFileExist filepath) (return filepath)
+
+loadConfig :: IO (Either ParseException Config)
+loadConfig = do
+  filepath <- (getXdgDirectory XdgConfig (configPath </> configName))
+  confFile <- configFile
+  case confFile of
+    Just f -> decodeFileEither f
+    Nothing -> return $ Left $ OtherParseException $ toException $ NotFound $ filepath
+
+loadConfigOrDefault :: IO (Either ParseException Config)
+loadConfigOrDefault = do
+  confFile <- configFile
+  case confFile of
+    Just f -> decodeFileEither f
+    Nothing -> return $ Right $ def
+
+saveConfig :: Config -> IO ()
+saveConfig conf = do
+  getXdgDirectory XdgConfig configPath >>= createDirectoryIfMissing True
+  confPath <- (getXdgDirectory XdgConfig (configPath </> configName))
+  encodeFile confPath conf

src/Agent/Tools/Time.hs

@@ -0,0 +1,26 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+module Agent.Tools.Time where
+
+import Agent.Tools.Tool
+import Agent.Tools.Tool (Tool)
+import Control.Monad.IO.Class
+import Data.Proxy
+import Data.Text
+
+data CurrentTimeTool
+
+instance KnownTool CurrentTimeTool where
+  toolVal _ =
+    Tool
+      { name = "current_time",
+        call = "",
+        description = "Get the current Time"
+      }
+
+instance Dispatchable CurrentTimeTool () where
+  dispatch :: (MonadIO m) => Proxy t -> () -> m Text
+  dispatch Proxy () = return "Current Timed: 09.03.2025 14:38"
+  parseArgs _ _ = ()

src/Agent/Tools/Tool.hs

@@ -0,0 +1,46 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Agent.Tools.Tool where
+
+import Control.Monad.IO.Class
+import qualified Data.Kind as DK (Type)
+import Data.Proxy
+import Data.Text
+import Language.Haskell.TH
+
+data Tool = Tool
+  { name :: Text,
+    description :: Text,
+    call :: Text
+  }
+  deriving (Show)
+
+toMarkdownDL :: Tool -> Text
+toMarkdownDL t = "- " <> name t <> "(" <> call t <> ")\n: " <> description t
+
+-- | This type represents unknown type-level tools.
+data SomeTool = forall t. (KnownTool t) => SomeTool (Proxy t)
+
+-- | This class gives the tool associated with a type-level tool.
+-- There are instances of the class for every concrete tool included.
+class KnownTool (t :: DK.Type) where
+  toolVal :: Proxy t -> Tool
+
+class (KnownTool t) => Dispatchable t a where
+  dispatch :: (MonadIO m) => Proxy t -> a -> m Text
+  parseArgs :: Proxy t -> Text -> a
+
+getToolListTH :: Q Exp
+getToolListTH = do
+  ClassI _ instances <- reify ''Dispatchable
+  let toolExps =
+        [ [|toolVal (Proxy :: Proxy $(return t))|]
+        | InstanceD _ _ (AppT (AppT _ t) _) _ <-
+            instances
+        ]
+  listE toolExps

test/Main.hs

@@ -0,0 +1,4 @@
+module Main (main) where
+
+main :: IO ()
+main = putStrLn "Test suite not yet implemented."