From d91c6bb446d0284f096cc6cfc9a7f9ac7f8afb1e Mon Sep 17 00:00:00 2001
From: LLLL Colonq <llll@colonq>
Date: Sun, 14 Jan 2024 19:01:03 -0500
Subject: Add fig-bless

---
 fig-bless/src/Fig/Bless/Builtins.hs | 82 +++++++++++++++++++++++++++++++++++++
 1 file changed, 82 insertions(+)
 create mode 100644 fig-bless/src/Fig/Bless/Builtins.hs

(limited to 'fig-bless/src/Fig/Bless/Builtins.hs')

diff --git a/fig-bless/src/Fig/Bless/Builtins.hs b/fig-bless/src/Fig/Bless/Builtins.hs
new file mode 100644
index 0000000..2072ea9
--- /dev/null
+++ b/fig-bless/src/Fig/Bless/Builtins.hs
@@ -0,0 +1,82 @@
+{-# Language ImplicitParams #-}
+
+module Fig.Bless.Builtins
+  ( arithmetic
+  ) where
+
+import Fig.Prelude
+
+import Control.Monad.State.Strict (execStateT, StateT)
+
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+
+import qualified Fig.Bless.Syntax as Syn
+import Fig.Bless.Runtime
+
+-- * Helper functions
+stateful :: Running m t v => StateT (VM m t v) m a -> Builtin m t v
+stateful = execStateT
+
+push :: (Running m t v, MonadState (VM m' t v) m) => ValueF t v -> m ()
+push v = state \vm -> ((), vm { stack = v : vm.stack })
+
+pop :: (Running m t v, MonadState (VM m' t v) m) => m (ValueF t v)
+pop = get >>= \case
+  vm | x:xs <- vm.stack -> do
+         put vm { stack = xs }
+         pure x
+     | otherwise -> throwM $ RuntimeErrorStackUnderflow ?term
+
+int :: Running m t v => ValueF t v -> m Integer
+int (ValueInteger i) = pure i
+int v = throwM $ RuntimeErrorSortMismatch ?term ValueSortInteger (valueSort v)
+
+double :: Running m t v => ValueF t v -> m Double
+double (ValueDouble d) = pure d
+double v = throwM $ RuntimeErrorSortMismatch ?term ValueSortDouble (valueSort v)
+
+string :: Running m t v => ValueF t v -> m Text
+string (ValueString s) = pure s
+string v = throwM $ RuntimeErrorSortMismatch ?term ValueSortString (valueSort v)
+
+program :: Running m t v => ValueF t v -> m (Syn.ProgramF t)
+program (ValueProgram p) = pure p
+program v = throwM $ RuntimeErrorSortMismatch ?term ValueSortProgram (valueSort v)
+
+array :: Running m t v => ValueF t v -> m [v]
+array (ValueArray a) = pure a
+array v = throwM $ RuntimeErrorSortMismatch ?term ValueSortProgram (valueSort v)
+
+-- * Arithmetic builtins
+add :: Running m t v => Builtin m t v
+add = stateful do
+  y <- int =<< pop
+  x <- int =<< pop
+  push . ValueInteger $ x + y
+
+mul :: Running m t v => Builtin m t v
+mul = stateful do
+  y <- int =<< pop
+  x <- int =<< pop
+  push . ValueInteger $ x * y
+
+sub :: Running m t v => Builtin m t v
+sub = stateful do
+  y <- int =<< pop
+  x <- int =<< pop
+  push . ValueInteger $ x - y
+
+div :: Running m t v => Builtin m t v
+div = stateful do
+  y <- int =<< pop
+  x <- int =<< pop
+  push . ValueInteger $ quot x y
+
+arithmetic :: RunningTop m t v => Builtins m t v
+arithmetic t = let ?term = t in Map.fromList
+  [ ("+", add)
+  , ("*", mul)
+  , ("-", sub)
+  , ("/", div)
+  ]
-- 
cgit v1.2.3