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