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            | TInteger Int
  85     deriving Show
  86
  87 -- Actions
  88
  89 type Action = String -> ParserM Token
  90
  91 set_start_code :: StartCode -> ParserM ()
  92 set_start_code sc = ParserM $ \i st -> Right (i, st { start_code = sc }, ())
  93
  94 inc_brace_depth :: ParserM ()
  95 inc_brace_depth = ParserM $ \i st ->
  96                   Right (i, st { brace_depth = brace_depth st + 1 }, ())
  97
  98 dec_brace_depth :: ParserM ()
  99 dec_brace_depth = ParserM $ \i st ->
 100                   let bd = brace_depth st - 1
 101                       sc = if bd == 0 then 0 else 1
 102                   in Right (i, st { brace_depth = bd, start_code = sc }, ())
 103
 104 andBegin :: Action -> StartCode -> Action
 105 (act `andBegin` sc) x = do set_start_code sc
 106                            act x
 107
 108 mkT :: Token -> Action
 109 mkT t = mkTv (const t)
 110
 111 mkTv :: (String -> Token) -> Action
 112 mkTv f str = ParserM (\i st -> Right (i, st, f str))
 113
 114 -- Positions
 115
 116 data Pos = Pos !Int{- Line -} !Int{- Column -}
 117
 118 get_pos :: ParserM Pos
 119 get_pos = ParserM $ \i@(AlexInput p _) st -> Right (i, st, p)
 120
 121 alexMove :: Pos -> Char -> Pos
 122 alexMove (Pos l _) '\n' = Pos (l+1) 1
 123 alexMove (Pos l c) '\t' = Pos l ((c+8) `div` 8 * 8)
 124 alexMove (Pos l c) _    = Pos l (c+1)
 125
 126 init_pos :: Pos
 127 init_pos = Pos 1 1
 128
 129 show_pos :: Pos -> String
 130 show_pos (Pos l c) = "line " ++ show l ++ ", column " ++ show c
 131
 132 -- Input
 133
 134 data AlexInput = AlexInput {position :: !Pos, input :: String}
 135
 136 alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
 137 alexGetChar (AlexInput p (x:xs)) = Just (x, AlexInput (alexMove p x) xs)
 138 alexGetChar (AlexInput _ []) = Nothing
 139
 140 alexInputPrevChar :: AlexInput -> Char
 141 alexInputPrevChar _ = error "Lexer doesn't implement alexInputPrevChar"
 142
 143 happyError :: ParserM a
 144 happyError = do p <- get_pos
 145                 fail $ "Parse error at " ++ show_pos p
 146