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
|
module ParserM (
-- Parser Monad
ParserM(..), AlexInput, run_parser,
-- Parser state
St,
StartCode, start_code, set_start_code,
inc_brace_depth, dec_brace_depth,
-- Tokens
Token(..),
-- Actions
Action, andBegin, mkT, mkTv,
-- Positions
get_pos, show_pos,
-- Input
alexGetChar, alexInputPrevChar, input, position,
-- Other
happyError
) where
-- Parser Monad
newtype ParserM a = ParserM (AlexInput -> St -> Either String (AlexInput, St, a))
instance Monad ParserM where
ParserM m >>= k = ParserM $ \i s -> case m i s of
Right (i', s', x) ->
case k x of
ParserM y -> y i' s'
Left err ->
Left err
return a = ParserM $ \i s -> Right (i, s, a)
fail err = ParserM $ \_ _ -> Left err
run_parser :: ParserM a -> (String -> Either String a)
run_parser (ParserM f)
= \s -> case f (AlexInput init_pos s) init_state of
Left es -> Left es
Right (_, _, x) -> Right x
-- Parser state
data St = St {
start_code :: !StartCode,
brace_depth :: !Int
}
deriving Show
type StartCode = Int
init_state :: St
init_state = St {
start_code = 0,
brace_depth = 0
}
-- Tokens
data Token = TEOF
| TArrow
| TEquals
| TComma
| TOpenParen
| TCloseParen
| TOpenParenHash
| THashCloseParen
| TOpenBrace
| TCloseBrace
| TSection
| TPrimop
| TPseudoop
| TPrimtype
| TWith
| TDefaults
| TTrue
| TFalse
| TDyadic
| TMonadic
| TCompare
| TGenPrimOp
| TThatsAllFolks
| TLowerName String
| TUpperName String
| TString String
| TNoBraces String
deriving Show
-- Actions
type Action = String -> ParserM Token
set_start_code :: StartCode -> ParserM ()
set_start_code sc = ParserM $ \i st -> Right (i, st { start_code = sc }, ())
inc_brace_depth :: ParserM ()
inc_brace_depth = ParserM $ \i st ->
Right (i, st { brace_depth = brace_depth st + 1 }, ())
dec_brace_depth :: ParserM ()
dec_brace_depth = ParserM $ \i st ->
let bd = brace_depth st - 1
sc = if bd == 0 then 0 else 1
in Right (i, st { brace_depth = bd, start_code = sc }, ())
andBegin :: Action -> StartCode -> Action
(act `andBegin` sc) x = do set_start_code sc
act x
mkT :: Token -> Action
mkT t = mkTv (const t)
mkTv :: (String -> Token) -> Action
mkTv f str = ParserM (\i st -> Right (i, st, f str))
-- Positions
data Pos = Pos !Int{- Line -} !Int{- Column -}
get_pos :: ParserM Pos
get_pos = ParserM $ \i@(AlexInput p _) st -> Right (i, st, p)
alexMove :: Pos -> Char -> Pos
alexMove (Pos l _) '\n' = Pos (l+1) 1
alexMove (Pos l c) '\t' = Pos l ((c+8) `div` 8 * 8)
alexMove (Pos l c) _ = Pos l (c+1)
init_pos :: Pos
init_pos = Pos 1 1
show_pos :: Pos -> String
show_pos (Pos l c) = "line " ++ show l ++ ", column " ++ show c
-- Input
data AlexInput = AlexInput {position :: !Pos, input :: String}
alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
alexGetChar (AlexInput p (x:xs)) = Just (x, AlexInput (alexMove p x) xs)
alexGetChar (AlexInput _ []) = Nothing
alexInputPrevChar :: AlexInput -> Char
alexInputPrevChar _ = error "Lexer doesn't implement alexInputPrevChar"
happyError :: ParserM a
happyError = do p <- get_pos
fail $ "Parse error at " ++ show_pos p
|
