voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

wip

This commit is contained in:
Dmitry Zuikov 2024-07-15 08:16:23 +03:00
parent 9c58a5c98e
commit 2913e8c00c
1 changed files with 35 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

74
hbs2-cli/app/Main.hs
View File

@ -1,29 +1,22 @@
{-# Language AllowAmbiguousTypes #-} {-# Language AllowAmbiguousTypes #-}
{-# Language UndecidableInstances #-} {-# Language UndecidableInstances #-}
{-# Language FunctionalDependencies #-}
module Main where module Main where
import HBS2.Prelude.Plated import HBS2.Prelude.Plated
import HBS2.OrDie import HBS2.OrDie
import HBS2.CLI
import Data.Config.Suckless 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 (HashMap)
import Data.HashMap.Strict qualified as HM import Data.HashMap.Strict qualified as HM
import Data.Maybe
import Data.Kind import Data.Kind
import Control.Monad.State import Control.Monad.Reader
import Control.Monad.Writer import Control.Monad.Writer
import Prettyprinter import Prettyprinter
data BindAction c ( m :: Type -> Type) = BindAction { getAction :: [Syntax c] -> RunM c m (Syntax c) }
data BindAction c m = BindAction { getAction :: [Syntax c] -> m (Syntax c) } data Bind c ( m :: Type -> Type) = Bind
data BindMeta c m = BindMeta
{ bindAction :: BindAction c m { bindAction :: BindAction c m
, bindName :: Id , bindName :: Id
, bindDescShort :: Text , bindDescShort :: Text
@ -31,45 +24,48 @@ data BindMeta c m = BindMeta
deriving newtype instance Hashable Id deriving newtype instance Hashable Id
class IsContext c => Bindable c a m where newtype Dict c m = Dict { fromDict :: HashMap Id (Bind c m) }
bind :: Id -> a -> [BindMeta c m] deriving newtype (Semigroup, Monoid)
newtype PM c m = PM { unPM :: [Syntax c] -> m (Syntax c) } newtype RunM c m a = RunM { fromRunM :: ReaderT (Dict c m) m a }
deriving newtype (Applicative, Functor, Monad, MonadIO, MonadReader (Dict c m))
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
run :: forall c m . (IsContext c, MonadIO m) => Dict c m -> [Syntax c] -> m ()
run d sy = do
runReaderT (fromRunM (mapM_ runExpr sy)) d
where where
runExpr b = \case runExpr :: Syntax c -> RunM c m (Syntax c)
ListVal (SymbolVal what : args) -> do runExpr = \case
args' <- for args $ \a -> runExpr b a ListVal (SymbolVal name : args') -> do
let fn = HM.lookup what b <&> bindAction what <- asks (HM.lookup name . fromDict) `orDie` "JOPA"
case fn of case bindAction what of
Just (BindAction e) -> e args' BindAction e -> do
_ -> error "not matched" mapM runExpr args' >>= e
_ -> error "not matched"
nil = List (noContext @C) [] e -> pure e
bindOne :: Id -> ([Syntax c] -> RunM c m (Syntax c)) -> Dict c m
bindOne n fn = Dict (HM.singleton n (Bind (BindAction fn) n ""))
nil = List noContext []
main :: IO () main :: IO ()
main = do main = do
wat <- getContents wat <- getContents
>>= either (error.show) pure . parseTop >>= either (error.show) pure . parseTop
let i = execWriter do let dict = execWriter do
tell $ bind "hello" $ PM $ \case tell $ bindOne "jopa" $ \case
[SymbolVal s] -> print ("hello" <+> pretty s) >> pure nil [] -> liftIO (print "JOPA") >> pure nil
[LitStrVal s] -> print ("hello" <+> pretty s) >> pure nil _ -> pure nil
_ -> pure nil
tell $ bind "fuck" $ PM $ \case
[] -> print "FUCK" >> pure nil
_ -> pure nil
run i wat tell $ bindOne "help" $ \case
[] -> do
d <- asks (HM.keys . fromDict)
liftIO $ mapM_ (print.pretty) d
pure nil
_ -> pure nil
run dict wat