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