blob: ca1fa48fe238a9ff92ef0b0f3ccf12bcfa6b6094 (
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
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
|
module DSL where
import Data.Char (isDigit, isSpace)
import Parsers
------------------------------------------------------------------------------
-- Data types / instances
------------------------------------------------------------------------------
data StackData
= StackInt Integer
| StackBool Bool
instance Show StackData where
show (StackInt x) = show x
show (StackBool True) = "true"
show (StackBool False) = "false"
type Stack = [StackData]
data Intrinsic
= I_DUMP
deriving (Show, Eq)
data Operation
= OpPushData StackData
| OpIntrinsic Intrinsic
deriving (Show)
type Program = [Operation]
data TokenData
= T_WHITESPACE
| T_INT_LITERAL Integer
| T_INTRINSIC Intrinsic
deriving (Show, Eq)
data DSLToken = DSLToken { tStr :: String -- original text
, tData :: TokenData -- actual data
} deriving (Show)
type DSLLexer = Parser Char DSLToken
type DSLParser = Parser DSLToken
------------------------------------------------------------------------------
-- Lexing
------------------------------------------------------------------------------
buildDSLLexer :: (Parser Char [Char]) -> ([Char] -> TokenData) -> DSLLexer
buildDSLLexer p f = do
str <- p
return DSLToken { tStr=str
, tData=f str
}
intrinsicL :: String -> Intrinsic -> DSLLexer
intrinsicL s i = buildDSLLexer (list s) (const $ T_INTRINSIC i)
wsL :: DSLLexer
wsL = buildDSLLexer (mult1 $ satisfy isSpace) (const T_WHITESPACE)
intLiteralL :: DSLLexer
intLiteralL = buildDSLLexer (mult1 $ satisfy isDigit) (T_INT_LITERAL . read)
mainLexer :: Parser Char [DSLToken]
mainLexer = phrase $ mult1 $ firstOf subLexers
where
subLexers = [wsL] ++ literals ++ intrinsics
literals = [ intLiteralL
]
intrinsics = map (uncurry intrinsicL) [ (".", I_DUMP)
]
------------------------------------------------------------------------------
-- Parsing
------------------------------------------------------------------------------
wsP :: DSLParser ()
wsP = do
t <- anyToken
case tData t of
T_WHITESPACE -> result ()
_ -> flunk
dataLiteralP :: DSLParser StackData
dataLiteralP = do
t <- anyToken
case tData t of
T_INT_LITERAL x -> result $ StackInt x
_ -> flunk
pushDataP :: DSLParser Operation
pushDataP = OpPushData <$> dataLiteralP
intrinsicP :: DSLParser Operation
intrinsicP = do
t <- anyToken
case tData t of
T_INTRINSIC i -> result $ OpIntrinsic i
_ -> flunk
operationP :: DSLParser Operation
operationP = firstOf [ pushDataP
, intrinsicP
]
programP :: DSLParser Program
programP = do
optional wsP
ops <- operationP `sepBy1` wsP
optional wsP
eof
return ops
stringToProgram :: String -> Maybe Program
stringToProgram str = do
(_, tokens) <- parse mainLexer str
(_, program) <- parse programP tokens
return program
|
