Cmd handlers from console reworked.

package.yaml

@@ -113,6 +113,7 @@ dependencies:
 - warp
 - http-client
 - http-client-tls
+- data-default
 
 library:
   source-dirs:

src/Hydra/Framework/App/Interpreter.hs

@@ -33,16 +33,6 @@ initKVDB' coreRt cfg@(D.RocksDBConfig _ _ _) dbName =
 initKVDB' coreRt cfg@(D.RedisConfig) dbName =
   R.initRedisDB' (coreRt ^. RLens.redisConns) cfg dbName
 
--- TODO: rework
-callHandler :: R.AppRuntime -> Map Text (String -> L.LangL Text) -> String -> IO Text
-callHandler appRt methods msg = do
-  let tag = T.pack $ takeWhile (/= ' ') msg
-  let coreRt = appRt ^. RLens.coreRuntime
-  case methods ^. at tag of
-    Just method -> Impl.runLangL coreRt $ method msg
-    Nothing     -> pure $ "The method " <> tag <> " isn't supported."
-
-
 connect :: D.DBConfig beM -> IO (D.DBResult (D.SqlConn beM))
 connect cfg = do
   eConn <- try $ R.connect' cfg
@@ -85,22 +75,19 @@ interpretAppF appRt (L.InitSqlDB cfg next) = do
           pure $ next $ Left err
 
 
-interpretAppF appRt (L.StdF completeFunc handlers next) = do
-    methodsMVar <- newMVar Map.empty
-    _ <- Impl.runCmdHandlerL methodsMVar handlers
-    -- TODO: rework. Consider masking the exceptions.
-    -- TODO: add history.
-    void $ forkIO $ do
-        methods <- readMVar methodsMVar
-        let loop = HS.getInputLine "> " >>= \case
-                Nothing   -> pure ()
-                Just line -> do
-                    res <- liftIO $ callHandler appRt methods line
-                    HS.outputStrLn $ T.unpack res
-                    loop
-        let cf = HS.completeWord Nothing " \t" $ pure . completeFunc
-        HS.runInputT (HS.setComplete cf HS.defaultSettings) loop
-    pure $ next ()
+interpretAppF appRt (L.StdF completeFunc stdDef next) = do
+  let coreRt = appRt ^. RLens.coreRuntime
+  -- TODO: add history.
+  void $ forkIO $ do
+    let loop = HS.getInputLine "> " >>= \case
+          Nothing   -> pure ()
+          Just line -> do
+            liftIO $ Impl.runCmdHandlerL coreRt (toText line) stdDef
+            -- HS.outputStrLn $ T.unpack res
+            loop
+    let cf = HS.completeWord Nothing " \t" $ pure . completeFunc
+    HS.runInputT (HS.setComplete cf HS.defaultSettings) loop
+  pure $ next ()
 
 runAppL :: R.AppRuntime -> L.AppL a -> IO a
 runAppL appRt = foldFree (interpretAppF appRt)

src/Hydra/Framework/Cmd/Interpreter.hs

@@ -5,14 +5,15 @@ import           Hydra.Prelude
 import qualified Data.Map as M
 
 import qualified Hydra.Framework.Cmd.Language as L
+import qualified Hydra.Core.Runtime  as R
+import qualified Hydra.Core.Interpreters  as Impl
 
--- TODO: rework.
+interpretCmdHandlerL :: R.CoreRuntime -> Text -> L.CmdHandlerF a -> IO a
 
-interpretCmdHandlerL :: MVar (M.Map Text L.CmdHandler) -> L.CmdHandlerF a -> IO a
-interpretCmdHandlerL methodsMVar (L.CmdHandler name method' next) = do
-  methods <- takeMVar methodsMVar
-  putMVar methodsMVar $ M.insert name method' methods
-  pure $ next ()
+interpretCmdHandlerL coreRt line (L.UserCmd parser cont next) =
+  next <$> case parser line of
+    Nothing -> pure ()
+    Just a  -> Impl.runLangL coreRt $ cont a
 
-runCmdHandlerL :: MVar (Map Text L.CmdHandler) -> L.CmdHandlerL a -> IO a
-runCmdHandlerL m = foldFree (interpretCmdHandlerL m)
+runCmdHandlerL :: R.CoreRuntime -> Text -> L.CmdHandlerL a -> IO a
+runCmdHandlerL coreRt line = foldFree (interpretCmdHandlerL coreRt line)

src/Hydra/Framework/Cmd/Language.hs

@@ -1,37 +1,40 @@
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE GADTs           #-}
 
 -- TODO: rework.
 module Hydra.Framework.Cmd.Language
   ( CmdHandlerF (..)
-  , CmdHandler
   , CmdHandlerL
-  , stdHandler
-  , toTag
+  , userCmd
   ) where
 
 import           Hydra.Prelude
 import qualified Data.Text          as T
 import           Data.Typeable
+import           Data.Data
+import           Data.Default
 
 import qualified Hydra.Core.Language as L
 
-toTag :: Typeable a => a -> Text
-toTag = T.pack . takeWhile (/= ' ') . show . typeOf
-
-data CmdHandlerF a where
-    CmdHandler :: Text -> CmdHandler -> (() -> a)  -> CmdHandlerF a
+data CmdHandlerF next where
+  UserCmd :: (Text -> Maybe a) -> (a -> L.LangL ()) -> (() -> next) -> CmdHandlerF next
 
 instance Functor CmdHandlerF where
-    fmap g (CmdHandler text f next) = CmdHandler text f (g . next)
+    fmap g (UserCmd parser cont next) = UserCmd parser cont (g . next)
 
-type CmdHandler    = String -> L.LangL Text
 type CmdHandlerL a = Free CmdHandlerF a
 
-stdHandler :: (Typeable a, Read a) => (a -> L.LangL Text) -> CmdHandlerL ()
-stdHandler f = liftF $ CmdHandler (toTag f) (makeStdHandler f) id
+userCmd
+  :: forall a
+   . (Read a, Data a, Default a)
+  => Text
+  -> (a -> L.LangL ())
+  -> CmdHandlerL ()
+userCmd cmd handler = liftF $ UserCmd fParse handler id
   where
-    makeStdHandler :: Read a => (a -> L.LangL Text) -> String -> L.LangL Text
-    makeStdHandler f raw = case readMaybe raw of
-      Just req -> f req
-      Nothing  -> pure "Error of request parsing"
+    cName = T.toLower $ toText $ show @String $ toConstr $ def @a
+    fParse :: Text -> Maybe a
+    fParse line = do
+            t <- T.stripPrefix cmd $ T.stripStart line
+            readMaybe $ toString $ T.concat [toText cName, " ", t]