blob: 2072ea9573ceaeb24273090bbabd798394959470 (
plain)
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
|
{-# 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)
]
|
