Add some string and array builtins, add array literals

1 files changed, 68 insertions, 19 deletions

diff --git a/fig-bless/src/Fig/Bless/Builtins.hs b/fig-bless/src/Fig/Bless/Builtins.hs
index 1246e57..8e199d7 100644
--- a/fig-bless/src/Fig/Bless/Builtins.hs
+++ b/fig-bless/src/Fig/Bless/Builtins.hs
@@ -9,48 +9,52 @@ import Fig.Prelude
 import Control.Monad.State.Strict (execStateT, StateT)
 
 import qualified Data.Map.Strict as Map
+import qualified Data.Text as Text
 
 import qualified Fig.Bless.Syntax as Syn
 import Fig.Bless.Types
 import Fig.Bless.Runtime
 
 -- * Helper functions
-stateful :: Running m t v => [BType] -> [BType] -> StateT (VM m t v) m a -> Builtin m t v
+stateful :: Running m t => [BType] -> [BType] -> StateT (VM m t) m a -> Builtin m t
 stateful inp out f = (execStateT f, BProgType {..})
 
-push :: (Running m t v, MonadState (VM m' t v) m) => ValueF t v -> m ()
+push :: (Running m t, MonadState (VM m' t) m) => ValueF t -> 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 :: (Running m t, MonadState (VM m' t) m) => m (ValueF t)
 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
+effect :: (Running m t, MonadState (VM m' t) m) => EffectF t -> m ()
+effect e = state \vm -> ((), vm { effects = e : vm.effects })
+
+int :: Running m t => ValueF t -> 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 :: Running m t => ValueF t -> 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 :: Running m t => ValueF t -> 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 :: Running m t => ValueF t -> 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 :: Running m t => ValueF t -> m [ValueF t]
 array (ValueArray a) = pure a
 array v = throwM $ RuntimeErrorSortMismatch ?term ValueSortProgram (valueSort v)
 
 -- * Stack operations
-stackops :: RunningTop m t v => Builtins m t v
-stackops t = let ?term = t in Map.fromList
+stackOps :: RunningTop m t => Builtins m t
+stackOps t = let ?term = t in Map.fromList
   [ ( "dup", stateful [BTypeVariable "a"] [BTypeVariable "a", BTypeVariable "a"] do
         x <- pop
         push x
@@ -65,41 +69,86 @@ stackops t = let ?term = t in Map.fromList
   ]
 
 -- * Arithmetic builtins
-add :: Running m t v => Builtin m t v
+add :: Running m t => Builtin m t
 add = stateful [BTypeInteger, BTypeInteger] [BTypeInteger] do
   y <- int =<< pop
   x <- int =<< pop
   push . ValueInteger $ x + y
 
-mul :: Running m t v => Builtin m t v
+mul :: Running m t => Builtin m t
 mul = stateful [BTypeInteger, BTypeInteger] [BTypeInteger] do
   y <- int =<< pop
   x <- int =<< pop
   push . ValueInteger $ x * y
 
-sub :: Running m t v => Builtin m t v
+sub :: Running m t => Builtin m t
 sub = stateful [BTypeInteger, BTypeInteger] [BTypeInteger] do
   y <- int =<< pop
   x <- int =<< pop
   push . ValueInteger $ x - y
 
-div :: Running m t v => Builtin m t v
+div :: Running m t => Builtin m t
 div = stateful [BTypeInteger, BTypeInteger] [BTypeInteger] 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
+arithmeticOps :: RunningTop m t => Builtins m t
+arithmeticOps t = let ?term = t in Map.fromList
   [ ("+", add)
   , ("*", mul)
   , ("-", sub)
   , ("/", div)
   ]
 
+-- * String builtins
+stringOps :: RunningTop m t => Builtins m t
+stringOps t = let ?term = t in Map.fromList
+  [ ( "s-append", stateful [BTypeString, BTypeString] [BTypeString] do
+        y <- string =<< pop
+        x <- string =<< pop
+        push . ValueString $ x <> y
+    )
+  , ( "s-split", stateful [BTypeString, BTypeString] [BTypeArray BTypeString] do
+        sep <- string =<< pop
+        s <- string =<< pop
+        push . ValueArray $ ValueString <$> Text.splitOn sep s
+    )
+  ]
+
+-- * Array builtins
+arrayOps :: RunningTop m t => Builtins m t
+arrayOps t = let ?term = t in Map.fromList
+  [ ( "a-append", stateful [BTypeArray (BTypeVariable "a"), BTypeArray (BTypeVariable "a")] [BTypeArray (BTypeVariable "a")] do
+        y <- array =<< pop
+        x <- array =<< pop
+        push . ValueArray $ x <> y
+    )
+  ]
+
+-- * Side effects
+sideeffectOps :: RunningTop m t => Builtins m t
+sideeffectOps t = let ?term = t in Map.fromList
+  [ ( "print", stateful [BTypeVariable "a"] [] do
+        x <- pop
+        effect $ EffectPrint x
+    )
+  , ( "soundboard", stateful [BTypeString] [] do
+        x <- pop
+        effect $ EffectSoundboard x
+    )
+  , ( "toggle", stateful [BTypeString] [] do
+        x <- pop
+        effect $ EffectModelToggle x
+    )
+  ]
+
 -- * All builtins
-builtins :: RunningTop m t v => Builtins m t v
+builtins :: RunningTop m t => Builtins m t
 builtins t = Map.unions @[]
-  [ stackops t
-  , arithmetic t
+  [ stackOps t
+  , arithmeticOps t
+  , stringOps t
+  , arrayOps t
+  , sideeffectOps t
   ]