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