1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
|
{-# Language ImplicitParams #-}
module Fig.Bless.Builtins
( builtins
) where
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 => [BType] -> [BType] -> StateT (VM m t) m a -> Builtin m t
stateful inp out f = (execStateT f, BProgType {..})
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, 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
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 => ValueF t -> m Double
double (ValueDouble d) = pure d
double v = throwM $ RuntimeErrorSortMismatch ?term ValueSortDouble (valueSort v)
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 => ValueF t -> m (Syn.ProgramF t)
program (ValueProgram p) = pure p
program v = throwM $ RuntimeErrorSortMismatch ?term ValueSortProgram (valueSort 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 => Builtins m t
stackOps t = let ?term = t in Map.fromList
[ ( "dup", stateful [BTypeVariable "a"] [BTypeVariable "a", BTypeVariable "a"] do
x <- pop
push x
push x
)
, ( "swap", stateful [BTypeVariable "a", BTypeVariable "b"] [BTypeVariable "b", BTypeVariable "a"] do
x <- pop
y <- pop
push x
push y
)
]
-- * Arithmetic builtins
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 => Builtin m t
mul = stateful [BTypeInteger, BTypeInteger] [BTypeInteger] do
y <- int =<< pop
x <- int =<< pop
push . ValueInteger $ x * y
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 => Builtin m t
div = stateful [BTypeInteger, BTypeInteger] [BTypeInteger] do
y <- int =<< pop
x <- int =<< pop
push . ValueInteger $ quot x y
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 => Builtins m t
builtins t = Map.unions @[]
[ stackOps t
, arithmeticOps t
, stringOps t
, arrayOps t
, sideeffectOps t
]
|
