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
|
{-# Language ImplicitParams #-}
module Fig.Bless.Runtime
( ValueF(..), Value
, 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 v
= ValueInteger Integer
| ValueDouble Double
| ValueString Text
| ValueProgram (Syn.ProgramF t)
| ValueArray [v]
deriving (Show, Eq, Ord, Generic)
instance (Aeson.ToJSON t, Aeson.ToJSON v) => Aeson.ToJSON (ValueF t v)
instance (Pretty t, Pretty v) => Pretty (ValueF t v) 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
[ "["
, Text.intercalate ", " $ pretty <$> vs
, "]"
]
type Value = ValueF (Fix Syn.TermF) (Fix (ValueF (Fix Syn.TermF)))
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 v -> 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 v = (MonadThrow m, Typeable t, Show t)
type Running m t v = (RunningTop m t v, ?term :: Maybe t)
type BuiltinProgram m t v = VM m t v -> m (VM m t v)
type Builtin m t v = (BuiltinProgram m t v, BProgType)
type Builtins m t v = Maybe t -> Map Syn.Word (Builtin m t v)
data VM m t v = VM
{ fuel :: Maybe Integer
, bindings :: Syn.DictionaryF t
, builtins :: Builtins m t v
, stack :: [ValueF t v]
}
initialize :: Running m t v => Maybe Integer -> Syn.DictionaryF t -> Builtins m t v -> VM m t v
initialize fuel bindings builtins = VM{..}
where
stack = []
checkFuel :: Running m t v => VM m t v -> m (VM m t v)
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 v => ValueF t v -> VM m t v -> VM m t v
push v vm = vm
{ stack = v : vm.stack
}
runProgram :: Running m t v => Syn.Extractor m t -> Syn.ProgramF t -> VM m t v -> m (VM m t v)
runProgram f (Syn.Program p) vm = foldM (flip (run f)) vm p
runWord :: Running m t v => Syn.Extractor m t -> Syn.Word -> VM m t v -> m (VM m t v)
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
run :: Running m t v => Syn.Extractor m t -> t -> VM m t v -> m (VM m t v)
run f v vm =
let ?term = Just v in f v >>= \case
Syn.TermLiteral (Syn.LiteralInteger i) -> push (ValueInteger i) <$> checkFuel vm
Syn.TermLiteral (Syn.LiteralDouble i) -> push (ValueDouble i) <$> checkFuel vm
Syn.TermLiteral (Syn.LiteralString i) -> push (ValueString i) <$> checkFuel vm
Syn.TermQuote p -> push (ValueProgram p) <$> checkFuel vm
Syn.TermWord w -> runWord f w =<< checkFuel vm
|
