wip

hbs2-cli/app/Main.hs

@@ -1,7 +1,75 @@
+{-# Language AllowAmbiguousTypes #-}
+{-# Language UndecidableInstances #-}
+{-# Language FunctionalDependencies #-}
 module Main where
 
+import HBS2.Prelude.Plated
+import HBS2.OrDie
+import HBS2.CLI
+
+import Data.Config.Suckless
+import System.Environment
+import Data.Text qualified as Text
+import Data.Text.IO qualified as TIO
+import Data.HashMap.Strict (HashMap)
+import Data.HashMap.Strict qualified as HM
+import Data.Maybe
+import Data.Kind
+import Control.Monad.State
+import Control.Monad.Writer
+
+import Prettyprinter
+
+
+data BindAction c m = BindAction { getAction :: [Syntax c] -> m (Syntax c) }
+
+data BindMeta c m = BindMeta
+  { bindAction      :: BindAction c m
+  , bindName        :: Id
+  , bindDescShort   :: Text
+  } deriving (Generic)
+
+deriving newtype instance Hashable Id
+
+class IsContext c => Bindable c a m  where
+  bind :: Id -> a -> [BindMeta c m]
+
+newtype PM c m = PM { unPM :: [Syntax c] -> m (Syntax c) }
+
+instance (MonadIO m, IsContext c) => Bindable c (PM c m) m where
+  bind i (PM f) = [BindMeta (BindAction f) i ""]
+
+run :: forall c m . (IsContext c, MonadIO m) => [BindMeta c m] -> [Syntax c] -> m ()
+run  meta syn = do
+  let binds = [ (bindName x,x) | x <- meta ] & HM.fromList
+  mapM_ (runExpr binds) syn
+
+  where
+    runExpr b = \case
+      ListVal (SymbolVal what : args) -> do
+        args' <- for args $ \a -> runExpr b a
+        let fn = HM.lookup what b <&> bindAction
+        case fn of
+          Just (BindAction e) -> e args'
+          _ -> error "not matched"
+      _ -> error "not matched"
+
+nil = List (noContext @C) []
 
 main :: IO ()
 main = do
-  print "yay!"
+  wat <- getContents
+           >>= either (error.show) pure . parseTop
+
+  let i = execWriter do
+            tell $ bind  "hello" $ PM $ \case
+              [SymbolVal s] -> print ("hello" <+> pretty s) >> pure nil
+              [LitStrVal s] -> print ("hello" <+> pretty s) >> pure nil
+              _ -> pure nil
+            tell $ bind  "fuck" $ PM $ \case
+              [] -> print "FUCK" >> pure nil
+              _ -> pure nil
+
+  run i wat
+
 

hbs2-cli/hbs2-cli.cabal

@@ -49,6 +49,8 @@ common shared-properties
                      , TupleSections
                      , TypeApplications
                      , TypeFamilies
+                     , PatternSynonyms
+                     , ViewPatterns
 
 
   build-depends: