wip

hbs2-cli/app/Main.hs

@@ -2,7 +2,10 @@
 {-# Language UndecidableInstances #-}
 module Main where
 
-import HBS2.Prelude.Plated
+import HBS2.CLI.Prelude
+import HBS2.CLI.Run
+import HBS2.CLI.Run.KeyMan
+
 import HBS2.OrDie
 
 import HBS2.Data.Types.Refs
@@ -19,13 +22,9 @@ import HBS2.Peer.RPC.API.Storage
 import HBS2.Peer.RPC.Client.StorageClient
 
 import HBS2.Peer.Proto hiding (request)
-import HBS2.Peer.Proto.RefLog
 import HBS2.Base58
 import HBS2.Net.Auth.Credentials
 import HBS2.Net.Auth.Schema()
-import HBS2.Net.Auth.Credentials
-import HBS2.Net.Auth.Credentials.Sigil
-import HBS2.Data.Types.SignedBox
 
 
 import HBS2.KeyMan.Keys.Direct
@@ -63,187 +62,6 @@ import Prettyprinter
 
 type RefLogId = PubKey 'Sign 'HBS2Basic
 
-pattern StringLike :: forall {c} . String -> Syntax c
-pattern StringLike e <- (stringLike -> Just e)
-
-pattern StringLikeList :: forall {c} . [String] -> [Syntax c]
-pattern StringLikeList e <- (stringLikeList -> e)
-
-class OptionalVal c b where
-  optional :: b -> Syntax c -> b
-
-instance IsContext c => OptionalVal c Int where
-  optional d = \case
-    LitIntVal x -> fromIntegral x
-    _           -> d
-
-stringLike :: Syntax c -> Maybe String
-stringLike = \case
-  LitStrVal s -> Just $ Text.unpack s
-  SymbolVal (Id s) -> Just $ Text.unpack s
-  _ -> Nothing
-
-stringLikeList :: [Syntax c] -> [String]
-stringLikeList syn = [ stringLike s | s <- syn ] & takeWhile isJust & catMaybes
-
-data BindAction c ( m :: Type -> Type)  =
-    BindLambda { fromLambda :: [Syntax c] -> RunM c m (Syntax c) }
-  | BindValue  (Syntax c)
-
-data Bind c ( m :: Type -> Type)  = Bind
-  { bindAction      :: BindAction c m
-  , bindName        :: Id
-  , bindDescShort   :: Text
-  } deriving (Generic)
-
-deriving newtype instance Hashable Id
-
-newtype NameNotBoundException = NameNotBound Id
-                            deriving stock Show
-                            deriving newtype (Generic,Typeable)
-
-
-newtype NotLambda = NotLambda Id
-                    deriving stock Show
-                    deriving newtype (Generic,Typeable)
-
-instance Exception NotLambda
-
-data BadFormException c = BadFormException (Syntax c)
-
-newtype TypeCheckError c = TypeCheckError (Syntax c)
-
-instance Exception (TypeCheckError C)
-
-newtype BadValueException = BadValueException String
-                            deriving stock Show
-                            deriving newtype (Generic,Typeable)
-
-instance Exception NameNotBoundException
-
-instance IsContext c => Show (BadFormException c) where
-  show (BadFormException sy) = show $ "BadFormException" <+> pretty sy
-
-instance IsContext c => Show (TypeCheckError c) where
-  show (TypeCheckError sy) = show $ "TypeCheckError" <+> pretty sy
-
-instance Exception (BadFormException C)
-
-instance Exception BadValueException
-
-newtype Dict c m = Dict { fromDict :: HashMap Id (Bind c m) }
-                   deriving newtype (Semigroup, Monoid)
-
-newtype RunM c m a = RunM { fromRunM :: ReaderT (TVar (Dict c m)) m a }
-                     deriving newtype ( Applicative
-                                      , Functor
-                                      , Monad
-                                      , MonadIO
-                                      , MonadUnliftIO
-                                      , MonadReader (TVar (Dict c m))
-                                      )
-
-
-splitForms :: [String] -> [[String]]
-splitForms s0 = runIdentity $ S.toList_ (go mempty s0)
-  where
-    go acc ( "then" : rest ) = emit acc >> go mempty rest
-    go acc ( "and" : rest ) = emit acc >> go mempty rest
-    go acc ( x : rest ) | isPrefixOf "-"  x =  go ( x : acc ) rest
-    go acc ( x : rest ) | isPrefixOf "--" x =  go ( x : acc ) rest
-    go acc ( x : rest ) = go ( x : acc ) rest
-    go acc [] = emit acc
-
-    emit = S.yield . reverse
-
-apply :: forall c m . ( IsContext c
-                      , MonadUnliftIO m
-                      , Exception (BadFormException c)
-                      )
-      => Id
-      -> [Syntax c]
-      -> RunM c m (Syntax c)
-apply name args' = do
-  -- notice $ red "APPLY" <+> pretty name
-  what <- ask >>=  readTVarIO <&> HM.lookup name . fromDict
-  case bindAction <$> what of
-    Just (BindLambda e) -> mapM runExpr args' >>= e
-    Just (BindValue v)  -> throwIO (NotLambda name)
-    Nothing -> throwIO (NameNotBound name)
-
-
-runExpr :: forall c m . ( IsContext c
-                        , MonadUnliftIO m
-                        , Exception (BadFormException c)
-                        ) => Syntax c -> RunM c m (Syntax c)
-runExpr syn = handle (handleForm syn) $ case syn of
-
-  ListVal [ w, SymbolVal ".", b] -> do
-    pure  $ mkList  [w, b]
-
-  ListVal [ SymbolVal "quot", ListVal b] -> do
-    pure  $ mkList  b
-
-  ListVal [SymbolVal "lambda", arglist, body] -> do
-    pure $ mkForm @c "lambda" [ arglist, body ]
-
-  ListVal (ListVal [SymbolVal "lambda", ListVal decl, body] : args)  -> do
-    error "oopsie"
-    -- d <- ask
-    -- void $ liftIO do
-    --   dd <- readTVarIO d
-    --   undefined
-      -- runReaderT $ runExpr body
-    --   error "FUCK!"
-    -- -- liftIO (run d body)
-    pure nil
-
-  ListVal (SymbolVal name : args') -> do
-    apply name args'
-
-  SymbolVal (Id s) | Text.isPrefixOf ":" s -> do
-    pure (mkSym @c (Text.drop 1 s))
-
-  SymbolVal name -> do
-    what <- ask >>=  readTVarIO
-              <&> HM.lookup name . fromDict
-              <&> maybe (BindValue (mkSym name)) bindAction
-
-    case what of
-      BindValue e  -> pure e
-      BindLambda e -> pure $ mkForm "lambda" [mkSym name, mkSym "..."]
-
-  e -> pure e
-
-  where
-    handleForm syn = \case
-      (BadFormException _  :: BadFormException c) -> do
-        throwIO (BadFormException syn)
-
-run :: forall c m . ( IsContext c
-                    , MonadUnliftIO m
-                    , Exception (BadFormException c)
-                    ) => Dict c m -> [Syntax c] -> m (Syntax c)
-run d sy = do
-  tvd <- newTVarIO d
-  lastDef nil <$> runReaderT (fromRunM (mapM runExpr sy)) tvd
-
-bindMatch :: Id -> ([Syntax c] -> RunM c m (Syntax c)) -> Dict c m
-bindMatch n fn = Dict (HM.singleton n (Bind (BindLambda fn) n ""))
-
-nil :: forall c . IsContext c => Syntax c
-nil = List noContext []
-
-nil_ :: (IsContext c, MonadIO m) =>  (a -> RunM c m b) -> a -> RunM c m (Syntax c)
-nil_ m w = m w >> pure (List noContext [])
-
-bind :: (MonadUnliftIO m, IsContext c) => Id -> Syntax c -> RunM c m (Syntax c)
-bind name expr = do
-  tv <- ask -- >>=  readTVarIO
-  atomically do
-    w@(Dict x) <- readTVar tv
-    writeTVar tv w
-  pure nil
 
 setupLogger :: MonadIO m => m ()
 setupLogger = do
@@ -264,54 +82,6 @@ silence = do
   setLoggingOff @WARN
   setLoggingOff @NOTICE
 
-class Display a where
-  display :: MonadIO m => a -> m ()
-
-instance  {-# OVERLAPPABLE #-} Pretty w => Display w  where
-  display = liftIO . print . pretty
-
-instance Display (Syntax c) where
-  display = \case
-    LitStrVal s -> liftIO $ TIO.putStr s
-    x           -> liftIO $ putStr (show $ pretty x)
-
-instance Display Text where
-  display = liftIO . TIO.putStr
-
-instance Display String where
-  display = liftIO . putStr
-
-display_ :: (MonadIO m, Show a) => a -> m ()
-display_ = liftIO . print
-
-{- HLINT ignore "Functor law" -}
-
-class IsContext c => MkSym c a where
-  mkSym :: a -> Syntax c
-
-instance IsContext c => MkSym c String where
-  mkSym s = Symbol noContext (Id $ Text.pack s)
-
-instance IsContext c => MkSym c Text where
-  mkSym s = Symbol noContext (Id s)
-
-instance IsContext c => MkSym c Id where
-  mkSym = Symbol noContext
-
-class IsContext c => MkStr c s where
-  mkStr :: s -> Syntax c
-
-instance IsContext c => MkStr c String where
-  mkStr s = Literal noContext $ LitStr (Text.pack s)
-
-instance IsContext c => MkStr c Text where
-  mkStr s = Literal noContext $ LitStr s
-
-mkForm :: forall c . IsContext c => String -> [Syntax c] -> Syntax c
-mkForm s sy = List noContext ( mkSym s :  sy )
-
-mkList :: forall c. IsContext c => [Syntax c] -> Syntax c
-mkList = List noContext
 
 getCredentialsForReflog :: MonadUnliftIO m => String -> m (PeerCredentials 'HBS2Basic)
 getCredentialsForReflog reflog = do
@@ -377,6 +147,8 @@ helpList p = do
 
   display_ $ vcat (fmap pretty ks)
 
+
+
 main :: IO ()
 main = do
 
@@ -385,9 +157,12 @@ main = do
   cli <- getArgs <&> unlines . fmap unwords . splitForms
            >>= either (error.show) pure . parseTop
 
-  let dict = execWriter do
+  let dict = makeDict do
 
-        tell $ bindMatch "help" $ nil_ $ \syn -> do
+        internalEntries
+        keymanEntries
+
+        entry $ bindMatch "help" $ nil_ $ \syn -> do
 
             display_ $ "hbs2-cli tool" <> line
 
@@ -403,81 +178,15 @@ main = do
               _ -> helpList Nothing
 
 
-        tell $ bindMatch "concat" $ \syn -> do
+        entry $ bindMatch "debug:show-cli" $ nil_ \case
-
-          case syn of
-            [ListVal (StringLikeList xs)] -> do
-              pure $ mkStr @C ( mconcat xs )
-
-            StringLikeList xs -> do
-              pure $ mkStr ( mconcat xs )
-
-            _ -> throwIO (BadFormException @C nil)
-
-        tell $ bindMatch "list" $ \case
-          es -> do
-            pure $ mkList @C es
-
-        tell $ bindMatch "dict" $ \case
-          es -> do
-            pure $ mkForm "dict" es
-
-        tell $ bindMatch "lambda" $ \case
-          [a, b] -> do
-            pure $ mkForm @C "lamba" [ mkSym "_", mkSym "..." ]
-
-          _ -> error "SHIT"
-
-        tell $ bindMatch "map" $ \syn -> do
-          case syn of
-            [ListVal (SymbolVal "lambda" : SymbolVal fn : _), ListVal rs] -> do
-              mapM (apply fn . List.singleton) rs
-                <&> mkList
-
-            w -> do
-              throwIO (BadFormException @C nil)
-
-        tell $ bindMatch "head" $ \case
-          [ ListVal es ] -> pure (head es)
-          _ -> throwIO (TypeCheckError @C nil)
-
-        tell $ bindMatch "tail" $ \case
-          [] -> pure nil
-          [ListVal []] -> pure nil
-          [ListVal es] -> pure $ mkList @C (tail es)
-          _ -> throwIO (BadFormException @C nil)
-
-        tell $ bindMatch "lookup" $ \case
-          [s, ListVal (SymbolVal "dict" : es) ] -> do
-            let val = headDef nil [ v | ListVal [k, v] <- es, k == s ]
-            pure val
-
-          [StringLike s, ListVal [] ] -> do
-            pure nil
-
-          _ -> throwIO (BadFormException @C nil)
-
-        tell $ bindMatch "display" $ nil_ \case
-          [ sy ] -> display sy
-          ss     -> display (mkList ss)
-
-        tell $ bindMatch "newline" $ nil_ $ \case
-          [] -> liftIO (putStrLn "")
-          _  -> throwIO (BadFormException @C nil)
-
-        tell $ bindMatch "print" $ nil_ $ \case
-          [ sy ] -> display sy >> liftIO (putStrLn "")
-          ss     -> mapM_ display ss >> liftIO (putStrLn "")
-
-        tell $ bindMatch "debug:show-cli" $ nil_ \case
           _ -> display cli
 
-        tell $ bindMatch "hbs2:peer:detect" $ nil_ \case
+        entry $ bindMatch "hbs2:peer:detect" $ nil_ \case
           _ -> do
             so <- detectRPC
             display so
 
-        tell $ bindMatch "hbs2:peer:poke" $ \case
+        entry $ bindMatch "hbs2:peer:poke" $ \case
           _ -> do
             so <- detectRPC `orDie` "hbs2-peer not found"
             r <- newTVarIO nil
@@ -492,7 +201,7 @@ main = do
 
             readTVarIO r
 
-        tell $ bindMatch "hbs2:keyring:list-encryption" $ \syn -> do
+        entry $ bindMatch "hbs2:keyring:list-encryption" $ \syn -> do
           lbs <- case syn of
 
                 [ ListVal [ SymbolVal "file", StringLike fn ] ] -> do
@@ -510,7 +219,7 @@ main = do
 
           pure $ mkList @C e
 
-        tell $ bindMatch "hbs2:keyring:new" $ \syn -> do
+        entry $ bindMatch "hbs2:keyring:new" $ \syn -> do
             n <- case syn of
                   [LitIntVal k] -> pure k
                   []            -> pure 1
@@ -520,13 +229,7 @@ main = do
             cred <- foldM (\cred _ -> addKeyPair Nothing cred) cred0 [1..n]
             pure $ mkStr @C $ show $ pretty $ AsCredFile $ AsBase58 cred
 
-        tell $ bindMatch "hbs2:keyman:list" $ nil_ \case
+        entry $ bindMatch "hbs2:reflog:tx:create-raw" $ \case
-          _ -> do
-            void $ runKeymanClient  $ KeyManClient $ do
-              k <- listKeys
-              display_ $ vcat (fmap pretty k)
-
-        tell $ bindMatch "hbs2:reflog:tx:create-raw" $ \case
           [SymbolVal "stdin", StringLike reflog] -> do
             mkRefLogUpdateFrom ( liftIO BS.getContents ) reflog
 
@@ -535,24 +238,24 @@ main = do
 
           _ -> throwIO (BadFormException @C nil)
 
-        tell $ bindMatch "str:read-stdin" $ \case
+        entry $ bindMatch "str:read-stdin" $ \case
           [] -> liftIO getContents <&> mkStr @C
 
           _ -> throwIO (BadFormException @C nil)
 
-        tell $ bindMatch "str:read-file" $ \case
+        entry $ bindMatch "str:read-file" $ \case
           [StringLike fn] -> liftIO (readFile fn) <&> mkStr @C
 
           _ -> throwIO (BadFormException @C nil)
 
-        tell $ bindMatch "str:save" $ nil_ \case
+        entry $ bindMatch "str:save" $ nil_ \case
           [StringLike fn, StringLike what] ->
             liftIO (writeFile fn what)
 
           _ -> throwIO (BadFormException @C nil)
 
 
-        tell $ bindMatch "hbs2:tree:metadata:get" $ \case
+        entry $ bindMatch "hbs2:tree:metadata:get" $ \case
           [ SymbolVal how, StringLike hash ] -> do
 
             -- FIXME: put-to-the-state
@@ -595,7 +298,7 @@ main = do
 
           _ -> throwIO (BadFormException @C nil)
 
-        tell $ bindMatch "hbs2:tree:metadata:create" $ \syn -> do
+        entry $ bindMatch "hbs2:tree:metadata:create" $ \syn -> do
 
           case syn of
 
@@ -616,7 +319,7 @@ main = do
 
             _ -> throwIO (BadFormException @C nil)
 
-        tell $ bindMatch "cbor:base58" $ \case
+        entry $ bindMatch "cbor:base58" $ \case
           [ LitStrVal x ] -> do
             pure $ mkForm "cbor:base58" [mkStr x]
 

hbs2-cli/hbs2-cli.cabal

@@ -99,6 +99,12 @@ library
 
     exposed-modules:
       HBS2.CLI
+      HBS2.CLI.Prelude
+      HBS2.CLI.Bind
+      HBS2.CLI.Run
+      HBS2.CLI.Run.Internal
+      HBS2.CLI.Run.KeyMan
+      HBS2.CLI.Run.Help
 
     build-depends:    base
 

hbs2-cli/lib/HBS2/CLI/Bind.hs

@@ -0,0 +1,4 @@
+module HBS2.CLI.Bind where
+
+import HBS2.CLI.Prelude
+

hbs2-cli/lib/HBS2/CLI/Prelude.hs

@@ -0,0 +1,18 @@
+module HBS2.CLI.Prelude
+  ( module HBS2.Prelude.Plated
+  , module UnliftIO
+  , module Data.Config.Suckless
+  , module Data.HashMap.Strict
+  , module Control.Monad.Reader
+  , Generic
+  ) where
+
+import HBS2.Prelude.Plated
+
+import Data.HashMap.Strict
+import Data.Config.Suckless
+
+import Control.Monad.Reader
+import UnliftIO
+
+

hbs2-cli/lib/HBS2/CLI/Run.hs

@@ -0,0 +1,9 @@
+{-# Language UndecidableInstances #-}
+module HBS2.CLI.Run
+  ( module HBS2.CLI.Run.Internal
+  ) where
+
+import HBS2.CLI.Run.Internal
+
+
+

hbs2-cli/lib/HBS2/CLI/Run/Help.hs

@@ -0,0 +1 @@
+module HBS2.CLI.Run.Help where

hbs2-cli/lib/HBS2/CLI/Run/Internal.hs

@@ -0,0 +1,333 @@
+{-# Language UndecidableInstances #-}
+module HBS2.CLI.Run.Internal where
+
+import HBS2.CLI.Prelude
+
+import Data.List (isPrefixOf)
+import Data.List qualified as List
+import Data.Kind
+import Data.Maybe
+import Data.HashMap.Strict qualified as HM
+import Data.Text qualified as Text
+import Data.Text.IO qualified as TIO
+import Control.Monad.Identity
+import Control.Monad.Writer
+
+import Streaming.Prelude qualified as S
+
+pattern StringLike :: forall {c} . String -> Syntax c
+pattern StringLike e <- (stringLike -> Just e)
+
+pattern StringLikeList :: forall {c} . [String] -> [Syntax c]
+pattern StringLikeList e <- (stringLikeList -> e)
+
+class Display a where
+  display :: MonadIO m => a -> m ()
+
+instance  {-# OVERLAPPABLE #-} Pretty w => Display w  where
+  display = liftIO . print . pretty
+
+instance Display (Syntax c) where
+  display = \case
+    LitStrVal s -> liftIO $ TIO.putStr s
+    x           -> liftIO $ putStr (show $ pretty x)
+
+instance Display Text where
+  display = liftIO . TIO.putStr
+
+instance Display String where
+  display = liftIO . putStr
+
+display_ :: (MonadIO m, Show a) => a -> m ()
+display_ = liftIO . print
+
+{- HLINT ignore "Functor law" -}
+
+class IsContext c => MkSym c a where
+  mkSym :: a -> Syntax c
+
+instance IsContext c => MkSym c String where
+  mkSym s = Symbol noContext (Id $ Text.pack s)
+
+instance IsContext c => MkSym c Text where
+  mkSym s = Symbol noContext (Id s)
+
+instance IsContext c => MkSym c Id where
+  mkSym = Symbol noContext
+
+class IsContext c => MkStr c s where
+  mkStr :: s -> Syntax c
+
+instance IsContext c => MkStr c String where
+  mkStr s = Literal noContext $ LitStr (Text.pack s)
+
+instance IsContext c => MkStr c Text where
+  mkStr s = Literal noContext $ LitStr s
+
+mkForm :: forall c . IsContext c => String -> [Syntax c] -> Syntax c
+mkForm s sy = List noContext ( mkSym s :  sy )
+
+mkList :: forall c. IsContext c => [Syntax c] -> Syntax c
+mkList = List noContext
+
+
+class OptionalVal c b where
+  optional :: b -> Syntax c -> b
+
+instance IsContext c => OptionalVal c Int where
+  optional d = \case
+    LitIntVal x -> fromIntegral x
+    _           -> d
+
+stringLike :: Syntax c -> Maybe String
+stringLike = \case
+  LitStrVal s -> Just $ Text.unpack s
+  SymbolVal (Id s) -> Just $ Text.unpack s
+  _ -> Nothing
+
+stringLikeList :: [Syntax c] -> [String]
+stringLikeList syn = [ stringLike s | s <- syn ] & takeWhile isJust & catMaybes
+
+data BindAction c ( m :: Type -> Type)  =
+    BindLambda { fromLambda :: [Syntax c] -> RunM c m (Syntax c) }
+  | BindValue  (Syntax c)
+
+data Bind c ( m :: Type -> Type)  = Bind
+  { bindAction      :: BindAction c m
+  , bindName        :: Id
+  , bindDescShort   :: Text
+  } deriving (Generic)
+
+deriving newtype instance Hashable Id
+
+newtype NameNotBoundException =
+  NameNotBound Id
+  deriving stock Show
+  deriving newtype (Generic,Typeable)
+
+newtype NotLambda = NotLambda Id
+                    deriving stock Show
+                    deriving newtype (Generic,Typeable)
+
+instance Exception NotLambda
+
+data BadFormException c = BadFormException (Syntax c)
+
+newtype TypeCheckError c = TypeCheckError (Syntax c)
+
+instance Exception (TypeCheckError C)
+
+newtype BadValueException = BadValueException String
+                            deriving stock Show
+                            deriving newtype (Generic,Typeable)
+
+instance Exception NameNotBoundException
+
+instance IsContext c => Show (BadFormException c) where
+  show (BadFormException sy) = show $ "BadFormException" <+> pretty sy
+
+instance IsContext c => Show (TypeCheckError c) where
+  show (TypeCheckError sy) = show $ "TypeCheckError" <+> pretty sy
+
+instance Exception (BadFormException C)
+
+instance Exception BadValueException
+
+newtype Dict c m = Dict { fromDict :: HashMap Id (Bind c m) }
+                   deriving newtype (Semigroup, Monoid)
+
+newtype RunM c m a = RunM { fromRunM :: ReaderT (TVar (Dict c m)) m a }
+                     deriving newtype ( Applicative
+                                      , Functor
+                                      , Monad
+                                      , MonadIO
+                                      , MonadUnliftIO
+                                      , MonadReader (TVar (Dict c m))
+                                      )
+
+
+
+newtype MakeDictM c m a = MakeDictM { fromMakeDict :: Writer (Dict c m) a }
+                          deriving newtype ( Applicative
+                                           , Functor
+                                           , Monad
+                                           , MonadWriter (Dict c m)
+                                           )
+
+makeDict :: (IsContext c, Monad m) =>  MakeDictM c m () -> Dict c m
+makeDict w = execWriter ( fromMakeDict w )
+
+entry :: Dict c m  -> MakeDictM c m ()
+entry = tell
+
+splitForms :: [String] -> [[String]]
+splitForms s0 = runIdentity $ S.toList_ (go mempty s0)
+  where
+    go acc ( "then" : rest ) = emit acc >> go mempty rest
+    go acc ( "and" : rest ) = emit acc >> go mempty rest
+    go acc ( x : rest ) | isPrefixOf "-"  x =  go ( x : acc ) rest
+    go acc ( x : rest ) | isPrefixOf "--" x =  go ( x : acc ) rest
+    go acc ( x : rest ) = go ( x : acc ) rest
+    go acc [] = emit acc
+
+    emit = S.yield . reverse
+
+apply :: forall c m . ( IsContext c
+                      , MonadUnliftIO m
+                      , Exception (BadFormException c)
+                      )
+      => Id
+      -> [Syntax c]
+      -> RunM c m (Syntax c)
+apply name args' = do
+  -- notice $ red "APPLY" <+> pretty name
+  what <- ask >>=  readTVarIO <&> HM.lookup name . fromDict
+  case bindAction <$> what of
+    Just (BindLambda e) -> mapM runExpr args' >>= e
+    Just (BindValue v)  -> throwIO (NotLambda name)
+    Nothing -> throwIO (NameNotBound name)
+
+
+runExpr :: forall c m . ( IsContext c
+                        , MonadUnliftIO m
+                        , Exception (BadFormException c)
+                        ) => Syntax c -> RunM c m (Syntax c)
+runExpr syn = handle (handleForm syn) $ case syn of
+
+  ListVal [ w, SymbolVal ".", b] -> do
+    pure  $ mkList  [w, b]
+
+  ListVal [ SymbolVal "quot", ListVal b] -> do
+    pure  $ mkList  b
+
+  ListVal [SymbolVal "lambda", arglist, body] -> do
+    pure $ mkForm @c "lambda" [ arglist, body ]
+
+  ListVal (ListVal [SymbolVal "lambda", ListVal decl, body] : args)  -> do
+    error "oopsie"
+    -- d <- ask
+    -- void $ liftIO do
+    --   dd <- readTVarIO d
+    --   undefined
+      -- runReaderT $ runExpr body
+    --   error "FUCK!"
+    -- -- liftIO (run d body)
+    pure nil
+
+  ListVal (SymbolVal name : args') -> do
+    apply name args'
+
+  SymbolVal (Id s) | Text.isPrefixOf ":" s -> do
+    pure (mkSym @c (Text.drop 1 s))
+
+  SymbolVal name -> do
+    what <- ask >>=  readTVarIO
+              <&> HM.lookup name . fromDict
+              <&> maybe (BindValue (mkSym name)) bindAction
+
+    case what of
+      BindValue e  -> pure e
+      BindLambda e -> pure $ mkForm "lambda" [mkSym name, mkSym "..."]
+
+  e -> pure e
+
+  where
+    handleForm syn = \case
+      (BadFormException _  :: BadFormException c) -> do
+        throwIO (BadFormException syn)
+
+run :: forall c m . ( IsContext c
+                    , MonadUnliftIO m
+                    , Exception (BadFormException c)
+                    ) => Dict c m -> [Syntax c] -> m (Syntax c)
+run d sy = do
+  tvd <- newTVarIO d
+  lastDef nil <$> runReaderT (fromRunM (mapM runExpr sy)) tvd
+
+bindMatch :: Id -> ([Syntax c] -> RunM c m (Syntax c)) -> Dict c m
+bindMatch n fn = Dict (HM.singleton n (Bind (BindLambda fn) n ""))
+
+nil :: forall c . IsContext c => Syntax c
+nil = List noContext []
+
+nil_ :: (IsContext c, MonadIO m) =>  (a -> RunM c m b) -> a -> RunM c m (Syntax c)
+nil_ m w = m w >> pure (List noContext [])
+
+bind :: (MonadUnliftIO m, IsContext c) => Id -> Syntax c -> RunM c m (Syntax c)
+bind name expr = do
+  tv <- ask -- >>=  readTVarIO
+  atomically do
+    w@(Dict x) <- readTVar tv
+    writeTVar tv w
+  pure nil
+
+internalEntries :: MonadUnliftIO m => MakeDictM C m ()
+internalEntries = do
+    entry $ bindMatch "concat" $ \syn -> do
+
+      case syn of
+        [ListVal (StringLikeList xs)] -> do
+          pure $ mkStr @C ( mconcat xs )
+
+        StringLikeList xs -> do
+          pure $ mkStr ( mconcat xs )
+
+        _ -> throwIO (BadFormException @C nil)
+
+    entry $ bindMatch "list" $ \case
+      es -> do
+        pure $ mkList @C es
+
+    entry $ bindMatch "dict" $ \case
+      es -> do
+        pure $ mkForm "dict" es
+
+    entry $ bindMatch "lambda" $ \case
+      [a, b] -> do
+        pure $ mkForm @C "lamba" [ mkSym "_", mkSym "..." ]
+
+      _ -> error "SHIT"
+
+    entry $ bindMatch "map" $ \syn -> do
+      case syn of
+        [ListVal (SymbolVal "lambda" : SymbolVal fn : _), ListVal rs] -> do
+          mapM (apply fn . List.singleton) rs
+            <&> mkList
+
+        w -> do
+          throwIO (BadFormException @C nil)
+
+    entry $ bindMatch "head" $ \case
+      [ ListVal es ] -> pure (head es)
+      _ -> throwIO (TypeCheckError @C nil)
+
+    entry $ bindMatch "tail" $ \case
+      [] -> pure nil
+      [ListVal []] -> pure nil
+      [ListVal es] -> pure $ mkList @C (tail es)
+      _ -> throwIO (BadFormException @C nil)
+
+    entry $ bindMatch "lookup" $ \case
+      [s, ListVal (SymbolVal "dict" : es) ] -> do
+        let val = headDef nil [ v | ListVal [k, v] <- es, k == s ]
+        pure val
+
+      [StringLike s, ListVal [] ] -> do
+        pure nil
+
+      _ -> throwIO (BadFormException @C nil)
+
+    entry $ bindMatch "display" $ nil_ \case
+      [ sy ] -> display sy
+      ss     -> display (mkList ss)
+
+    entry $ bindMatch "newline" $ nil_ $ \case
+      [] -> liftIO (putStrLn "")
+      _  -> throwIO (BadFormException @C nil)
+
+    entry $ bindMatch "print" $ nil_ $ \case
+      [ sy ] -> display sy >> liftIO (putStrLn "")
+      ss     -> mapM_ display ss >> liftIO (putStrLn "")
+
+
+

hbs2-cli/lib/HBS2/CLI/Run/KeyMan.hs

@@ -0,0 +1,71 @@
+module HBS2.CLI.Run.KeyMan where
+
+import HBS2.CLI.Prelude
+import HBS2.CLI.Run.Internal
+
+import HBS2.Hash
+import HBS2.System.Dir
+
+import HBS2.KeyMan.Keys.Direct
+import HBS2.KeyMan.State
+import HBS2.KeyMan.App.Types
+
+import Codec.Serialise
+import Data.Either
+import Data.ByteString.Lazy qualified as LBS
+import Data.Text.Encoding qualified as TE
+import Data.Text.IO qualified as TIO
+import System.Process.Typed
+import Text.InterpolatedString.Perl6 (qc)
+
+fixContext :: (IsContext c1, IsContext c2) => Syntax c1 -> Syntax c2
+fixContext = go
+  where
+    go = \case
+      List    _ xs -> List noContext (fmap go xs)
+      Symbol  _ w  -> Symbol noContext w
+      Literal _ l  -> Literal noContext l
+
+
+keymanGetConfig :: (IsContext c, MonadUnliftIO m) => m [Syntax c]
+keymanGetConfig = do
+    (_,lbs,_) <- readProcess (shell [qc|hbs2-keyman config|] & setStderr closed)
+
+    let conf = TE.decodeUtf8 (LBS.toStrict lbs)
+                 & parseTop
+                 & fromRight mempty
+
+    pure $ fmap fixContext conf
+
+keymanUpdate :: MonadUnliftIO m => m ()
+keymanUpdate = do
+  void $ runProcess (shell [qc|hbs2-keyman update|])
+
+keymanEntries :: (MonadUnliftIO m, IsContext c) => MakeDictM c m ()
+keymanEntries = do
+  entry $ bindMatch "hbs2:keyman:list" $ nil_ \case
+    _ -> do
+      void $ runKeymanClient  $ KeyManClient $ do
+        k <- listKeys
+        display_ $ vcat (fmap pretty k)
+
+  entry $ bindMatch "hbs2:keyman:update" $ nil_ $ \_ -> do
+    keymanUpdate
+
+  entry $ bindMatch "hbs2:keyman:config" $ \_ -> do
+    mkForm  "dict" <$> keymanGetConfig
+
+  entry $ bindMatch "hbs2:keyman:keys:add" $ \case
+    [ LitStrVal ke ] -> do
+      conf <- keymanGetConfig @C
+      let path = head [ s | ListVal [ SymbolVal "default-key-path", StringLike s ] <- conf ]
+      mkdir path
+      let n =  hashObject @HbSync (serialise ke) & pretty & show
+      let fname = n `addExtension` ".key"
+      let fpath = path </> fname
+      liftIO $ TIO.writeFile fpath ke
+      keymanUpdate
+      pure $ mkStr fpath
+
+    _ -> throwIO (BadFormException @C nil)
+