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