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
155
156
157
158
159
160
161
162
163
164
165
166
167
|
{-# Language ImplicitParams #-}
module Fig.Bless.Runtime
( ValueF(..)
, EffectF(..)
, ValueSort(..), valueSort
, RuntimeError(..)
, RunningTop, Running
, BuiltinProgram, Builtin, Builtins
, VM(..)
, initialize
, runProgram, runWord, run
) where
import Fig.Prelude
import Control.Exception.Safe (Typeable)
import qualified Data.Text as Text
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import qualified Data.Aeson as Aeson
import Fig.Bless.Types
import qualified Fig.Bless.Syntax as Syn
data ValueF t
= ValueInteger Integer
| ValueDouble Double
| ValueString Text
| ValueProgram (Syn.ProgramF t)
| ValueArray [ValueF t]
deriving (Show, Eq, Ord, Generic)
instance Aeson.ToJSON t => Aeson.ToJSON (ValueF t)
instance Pretty t => Pretty (ValueF t) where
pretty (ValueInteger i) = tshow i
pretty (ValueDouble d) = tshow d
pretty (ValueString s) = tshow s
pretty (ValueProgram p) = pretty p
pretty (ValueArray vs) = mconcat
[ "{"
, unwords $ pretty <$> vs
, "}"
]
data EffectF t
= EffectPrint (ValueF t)
| EffectPrintBackwards (ValueF t)
| EffectSoundboard (ValueF t)
| EffectModelToggle (ValueF t)
deriving (Show, Eq, Ord, Generic)
instance Aeson.ToJSON t => Aeson.ToJSON (EffectF t)
instance Pretty t => Pretty (EffectF t) where
pretty (EffectPrint x) = "(print " <> pretty x <> ")"
pretty (EffectPrintBackwards x) = "(print-backwards " <> pretty x <> ")"
pretty (EffectSoundboard x) = "(soundboard " <> pretty x <> ")"
pretty (EffectModelToggle x) = "(moddle-toggle " <> pretty x <> ")"
data ValueSort
= ValueSortInteger
| ValueSortDouble
| ValueSortString
| ValueSortWord
| ValueSortProgram
| ValueSortArray
deriving (Show, Eq, Ord, Generic)
instance Aeson.ToJSON ValueSort
instance Pretty ValueSort where
pretty ValueSortInteger = "integer"
pretty ValueSortDouble = "double"
pretty ValueSortString = "string"
pretty ValueSortWord = "word"
pretty ValueSortProgram = "program"
pretty ValueSortArray = "list"
valueSort :: ValueF t -> ValueSort
valueSort (ValueInteger _) = ValueSortInteger
valueSort (ValueDouble _) = ValueSortDouble
valueSort (ValueString _) = ValueSortString
valueSort (ValueProgram _) = ValueSortProgram
valueSort (ValueArray _) = ValueSortArray
data RuntimeError t
= RuntimeErrorWordNotFound (Maybe t) Syn.Word
| RuntimeErrorOutOfFuel (Maybe t)
| RuntimeErrorStackUnderflow (Maybe t)
| RuntimeErrorSortMismatch (Maybe t) ValueSort ValueSort
deriving (Show, Eq, Ord, Generic)
instance (Show t, Typeable t) => Exception (RuntimeError t)
instance Aeson.ToJSON t => Aeson.ToJSON (RuntimeError t)
runtimeErrorPrefix :: Pretty t => Maybe t -> Text
runtimeErrorPrefix Nothing = ""
runtimeErrorPrefix (Just t) = mconcat
[ "while evaluating term: ", pretty t, "\n"
]
instance Pretty t => Pretty (RuntimeError t) where
pretty (RuntimeErrorWordNotFound t w) = mconcat
[ runtimeErrorPrefix t
, "word definition not found for: ", pretty w
]
pretty (RuntimeErrorOutOfFuel t) = mconcat
[ runtimeErrorPrefix t
, "out of fuel"
]
pretty (RuntimeErrorStackUnderflow t) = mconcat
[ runtimeErrorPrefix t
, "stack underflow"
]
pretty (RuntimeErrorSortMismatch t expected actual) = mconcat
[ runtimeErrorPrefix t
, "sort mismatch at runtime (this probably shouldn't happen, please report it as a bug):\n"
, "expected: ", pretty expected, "\n"
, "actual: ", pretty actual
]
type RunningTop m t = (MonadThrow m, Typeable t, Show t)
type Running m t = (RunningTop m t, ?term :: Maybe t)
type BuiltinProgram m t = VM m t -> m (VM m t)
type Builtin m t = (BuiltinProgram m t, BProgType)
type Builtins m t = Maybe t -> Map Syn.Word (Builtin m t)
data VM m t = VM
{ fuel :: Maybe Integer
, bindings :: Syn.DictionaryF t
, builtins :: Builtins m t
, stack :: [ValueF t]
, effects :: [EffectF t]
}
initialize :: Running m t => Maybe Integer -> Syn.DictionaryF t -> Builtins m t -> VM m t
initialize fuel bindings builtins = VM{..}
where
stack = []
effects = []
checkFuel :: Running m t => VM m t -> m (VM m t)
checkFuel vm
| Just f <- vm.fuel
= if f <= 0
then throwM $ RuntimeErrorOutOfFuel ?term
else pure vm { fuel = Just $ f - 1 }
checkFuel vm = pure vm
push :: Running m t => ValueF t -> VM m t -> VM m t
push v vm = vm
{ stack = v : vm.stack
}
runProgram :: Running m t => Syn.Extractor m t -> Syn.ProgramF t -> VM m t -> m (VM m t)
runProgram f (Syn.Program p) vm = foldM (flip (run f)) vm p
runWord :: Running m t => Syn.Extractor m t -> Syn.Word -> VM m t -> m (VM m t)
runWord _ w vm | Just (b, _) <- Map.lookup w $ vm.builtins ?term = b vm
runWord f w vm | Just p <- lookup w vm.bindings.defs = runProgram f p vm
runWord _ w _ = throwM $ RuntimeErrorWordNotFound ?term w
literalValue :: Syn.LiteralF t -> ValueF t
literalValue (Syn.LiteralInteger i) = ValueInteger i
literalValue (Syn.LiteralDouble i) = ValueDouble i
literalValue (Syn.LiteralString i) = ValueString i
literalValue (Syn.LiteralArray xs) = ValueArray $ literalValue <$> xs
literalValue (Syn.LiteralQuote p) = ValueProgram p
run :: Running m t => Syn.Extractor m t -> t -> VM m t -> m (VM m t)
run f v vm =
let ?term = Just v in f v >>= \case
Syn.TermLiteral l -> push (literalValue l) <$> checkFuel vm
Syn.TermWord w -> runWord f w =<< checkFuel vm
|
