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