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
|
module LTypes where
import Control.Monad.Except
import Data.Map (Map)
import qualified Data.Map as M
import Utils
data LWord
= LSymbol String
| LInteger Integer
| LFloat Double
| LBool Bool
| LChar Char
| LLabel String
| LStringLitRef String
| LPhrase [LWord]
deriving (Show, Eq)
data LWordT = LSymbolT | LIntegerT | LFloatT | LBoolT | LCharT | LLabelT | LPhraseT | AnyT deriving (Show)
consumeErr wordT word = LException $ "expected " ++ show wordT ++ ", encountered " ++ show word
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
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)
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)
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 ++ " ]"
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
|
