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
|
module LTypes where
import Control.Monad.Except
import Data.Map (Map)
import qualified Data.Map as M
import Utils
-- | An LWord is a typed value that can read from the source and
-- pushed onto the stack. LWords are the core data structure.
data LWord
= LSymbol String
| LInteger Integer
| LFloat Double
| LBool Bool
| LChar Char
| LLabel String
| LStringLitRef String
| LPhrase [LWord]
deriving (Show, Eq)
-- | An LWordT represents the type of an 'LWord'. Each LWord has one corresponding LWordT,
-- expect for the LWordT AnyT, which represents any LWord value.
data LWordT = LSymbolT | LIntegerT | LFloatT | LBoolT | LCharT | LLabelT | LPhraseT | AnyT deriving (Show)
-- | Produce an exception referencing an expected 'LWordT' and the encountered 'LWord'
consumeErr wordT word = LException $ "expected " ++ show wordT ++ ", encountered " ++ show word
-- | Attempt to consume one 'LWord' from the supplied stack. If the word at the top of the stack matches
-- the supplied 'LWordT', return that word and the updated stack. If not, return an exception.
consume1 :: LWordT -> [LWord] -> ExceptT LException IO (LWord, [LWord])
consume1 wordT [] =
throwError $ LException $ "expected " ++ show wordT ++ ", encountered empty stack"
consume1 AnyT (word : stack') = pure (word, stack')
consume1 wordT@LSymbolT (word : stack') =
case word of LSymbol _ -> pure (word, stack'); _ -> throwError $ consumeErr wordT word
consume1 wordT@LIntegerT (word : stack') =
case word of LInteger _ -> pure (word, stack'); _ -> throwError $ consumeErr wordT word
consume1 wordT@LFloatT (word : stack') =
case word of LFloat _ -> pure (word, stack'); _ -> throwError $ consumeErr wordT word
consume1 wordT@LBoolT (word : stack') =
case word of LBool _ -> pure (word, stack'); _ -> throwError $ consumeErr wordT word
consume1 wordT@LCharT (word : stack') =
case word of LChar _ -> pure (word, stack'); _ -> throwError $ consumeErr wordT word
consume1 wordT@LLabelT (word : stack') =
case word of LLabel _ -> pure (word, stack'); _ -> throwError $ consumeErr wordT word
consume1 wordT@LPhraseT (word : stack') =
case word of LPhrase _ -> pure (word, stack'); _ -> throwError $ consumeErr wordT word
-- | Invokes 'consume1' twice.
consume2 :: LWordT -> LWordT -> [LWord] -> ExceptT LException IO (LWord, LWord, [LWord])
consume2 wordT1 wordT2 stack = do
(ret1, stack1) <- consume1 wordT1 stack
(ret2, stack2) <- consume1 wordT2 stack1
pure (ret1, ret2, stack2)
-- | Invokes 'consume1' three times.
consume3 :: LWordT -> LWordT -> LWordT -> [LWord] -> ExceptT LException IO (LWord, LWord, LWord, [LWord])
consume3 wordT1 wordT2 wordT3 stack = do
(ret1, stack1) <- consume1 wordT1 stack
(ret2, stack2) <- consume1 wordT2 stack1
(ret3, stack3) <- consume1 wordT3 stack2
pure (ret1, ret2, ret3, stack3)
-- | Convert an 'LWord' to a string representation.
reprWord :: LWord -> String
reprWord (LSymbol a) = a
reprWord (LInteger a) = show a
reprWord (LFloat a) = show a
reprWord (LBool a) = show a
reprWord (LChar a) = show a
reprWord (LLabel a) = a
reprWord (LStringLitRef a) = "StrLit(" ++ a ++ ")"
reprWord (LPhrase a) = "P[ " ++ map reprWord a $> unwords ++ " ]"
-- | Represents the interpreter state. The state changes one processed 'LWord' at a time.
-- Contains:
-- * 'lDict': A mapping from 'LLabel' string values to 'LWord'. Used for storing variables.
-- * 'lStack': A list of 'LWord's, representing the global stack. The first element is the top of the stack.
-- * 'lDefs': A mapping from 'LSymbol' string values to phrases of 'LWord's. Used for defining custom words.
data LState = LState
{ lDict :: Map String LWord,
lStack :: [LWord],
lPhraseDepth :: Int,
lDefs :: Map String [LWord],
lSource :: [LWord],
lStrLitRefMap :: Map String [LWord]
}
deriving (Show)
data Config = Config
{ configFileNameM :: Maybe String,
configDebugMode :: Bool
}
data ExecStep = ExecContinue | ExecExit
debugState Config {configDebugMode = mode} state =
if mode
then do
putStrLn $ "stack: " ++ unwords (map reprWord (lStack state))
putStrLn $ "source: " ++ unwords (map reprWord (lSource state))
putStrLn $ "defs: " ++ unwords (M.keys (lDefs state))
putStrLn $ "dict: " ++ unwords (M.keys (lDict state))
putStrLn $ "lPhraseDepth: " ++ show (lPhraseDepth state)
putStrLn ""
else pure ()
newtype LException = LException String
|
