compatibility with Alex 3.0
[ghc.git] / utils / genprimopcode / ParserM.hs
1
2 module ParserM (
3 -- Parser Monad
4 ParserM(..), AlexInput, run_parser,
5 -- Parser state
6 St,
7 StartCode, start_code, set_start_code,
8 inc_brace_depth, dec_brace_depth,
9 -- Tokens
10 Token(..),
11 -- Actions
12 Action, andBegin, mkT, mkTv,
13 -- Positions
14 get_pos, show_pos,
15 -- Input
16 alexGetChar, alexGetByte, alexInputPrevChar, input, position,
17 -- Other
18 happyError
19 ) where
20
21 import Data.Word (Word8)
22 import Data.Char (ord)
23
24 -- Parser Monad
25 newtype ParserM a = ParserM (AlexInput -> St -> Either String (AlexInput, St, a))
26
27 instance Monad ParserM where
28 ParserM m >>= k = ParserM $ \i s -> case m i s of
29 Right (i', s', x) ->
30 case k x of
31 ParserM y -> y i' s'
32 Left err ->
33 Left err
34 return a = ParserM $ \i s -> Right (i, s, a)
35 fail err = ParserM $ \_ _ -> Left err
36
37 run_parser :: ParserM a -> (String -> Either String a)
38 run_parser (ParserM f)
39 = \s -> case f (AlexInput init_pos s) init_state of
40 Left es -> Left es
41 Right (_, _, x) -> Right x
42
43 -- Parser state
44
45 data St = St {
46 start_code :: !StartCode,
47 brace_depth :: !Int
48 }
49 deriving Show
50 type StartCode = Int
51
52 init_state :: St
53 init_state = St {
54 start_code = 0,
55 brace_depth = 0
56 }
57
58 -- Tokens
59
60 data Token = TEOF
61 | TArrow
62 | TEquals
63 | TComma
64 | TOpenParen
65 | TCloseParen
66 | TOpenParenHash
67 | THashCloseParen
68 | TOpenBrace
69 | TCloseBrace
70 | TSection
71 | TPrimop
72 | TPseudoop
73 | TPrimtype
74 | TWith
75 | TDefaults
76 | TTrue
77 | TFalse
78 | TDyadic
79 | TMonadic
80 | TCompare
81 | TGenPrimOp
82 | TThatsAllFolks
83 | TLowerName String
84 | TUpperName String
85 | TString String
86 | TNoBraces String
87 | TInteger Int
88 deriving Show
89
90 -- Actions
91
92 type Action = String -> ParserM Token
93
94 set_start_code :: StartCode -> ParserM ()
95 set_start_code sc = ParserM $ \i st -> Right (i, st { start_code = sc }, ())
96
97 inc_brace_depth :: ParserM ()
98 inc_brace_depth = ParserM $ \i st ->
99 Right (i, st { brace_depth = brace_depth st + 1 }, ())
100
101 dec_brace_depth :: ParserM ()
102 dec_brace_depth = ParserM $ \i st ->
103 let bd = brace_depth st - 1
104 sc = if bd == 0 then 0 else 1
105 in Right (i, st { brace_depth = bd, start_code = sc }, ())
106
107 andBegin :: Action -> StartCode -> Action
108 (act `andBegin` sc) x = do set_start_code sc
109 act x
110
111 mkT :: Token -> Action
112 mkT t = mkTv (const t)
113
114 mkTv :: (String -> Token) -> Action
115 mkTv f str = ParserM (\i st -> Right (i, st, f str))
116
117 -- Positions
118
119 data Pos = Pos !Int{- Line -} !Int{- Column -}
120
121 get_pos :: ParserM Pos
122 get_pos = ParserM $ \i@(AlexInput p _) st -> Right (i, st, p)
123
124 alexMove :: Pos -> Char -> Pos
125 alexMove (Pos l _) '\n' = Pos (l+1) 1
126 alexMove (Pos l c) '\t' = Pos l ((c+8) `div` 8 * 8)
127 alexMove (Pos l c) _ = Pos l (c+1)
128
129 init_pos :: Pos
130 init_pos = Pos 1 1
131
132 show_pos :: Pos -> String
133 show_pos (Pos l c) = "line " ++ show l ++ ", column " ++ show c
134
135 -- Input
136
137 data AlexInput = AlexInput {position :: !Pos, input :: String}
138
139 -- alexGetByte is for Alex >= 3.0, alexGetChar for earlier
140 -- XXX no UTF-8; we should do this properly sometime
141 alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)
142 alexGetByte (AlexInput p (x:xs)) = Just (fromIntegral (ord x),
143 AlexInput (alexMove p x) xs)
144 alexGetByte (AlexInput _ []) = Nothing
145
146 alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
147 alexGetChar (AlexInput p (x:xs)) = Just (x, AlexInput (alexMove p x) xs)
148 alexGetChar (AlexInput _ []) = Nothing
149
150 alexInputPrevChar :: AlexInput -> Char
151 alexInputPrevChar _ = error "Lexer doesn't implement alexInputPrevChar"
152
153 happyError :: ParserM a
154 happyError = do p <- get_pos
155 fail $ "Parse error at " ++ show_pos p
156