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 import Syntax
  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            | TEquals
  62            | TComma
  63            | TOpenParen
  64            | TCloseParen
  65            | TOpenParenHash
  66            | THashCloseParen
  67            | TOpenBrace
  68            | TCloseBrace
  69            | TSection
  70            | TPrimop
  71            | TPseudoop
  72            | TPrimtype
  73            | TWith
  74            | TDefaults
  75            | TTrue
  76            | TFalse
  77            | TDyadic
  78            | TMonadic
  79            | TCompare
  80            | TGenPrimOp
  81            | TThatsAllFolks
  82            | TLowerName String
  83            | TUpperName String
  84            | TString String
  85            | TNoBraces String
  86     deriving Show
  87
  88 -- Actions
  89
  90 type Action = String -> ParserM Token
  91
  92 set_start_code :: StartCode -> ParserM ()
  93 set_start_code sc = ParserM $ \i st -> Right (i, st { start_code = sc }, ())
  94
  95 inc_brace_depth :: ParserM ()
  96 inc_brace_depth = ParserM $ \i st ->
  97                   Right (i, st { brace_depth = brace_depth st + 1 }, ())
  98
  99 dec_brace_depth :: ParserM ()
 100 dec_brace_depth = ParserM $ \i st ->
 101                   let bd = brace_depth st - 1
 102                       sc = if bd == 0 then 0 else 1
 103                   in Right (i, st { brace_depth = bd, start_code = sc }, ())
 104
 105 andBegin :: Action -> StartCode -> Action
 106 (act `andBegin` sc) x = do set_start_code sc
 107                            act x
 108
 109 mkT :: Token -> Action
 110 mkT t = mkTv (const t)
 111
 112 mkTv :: (String -> Token) -> Action
 113 mkTv f str = ParserM (\i st -> Right (i, st, f str))
 114
 115 -- Positions
 116
 117 data Pos = Pos !Int{- Line -} !Int{- Column -}
 118
 119 get_pos :: ParserM Pos
 120 get_pos = ParserM $ \i@(AlexInput p _) st -> Right (i, st, p)
 121
 122 alexMove :: Pos -> Char -> Pos
 123 alexMove (Pos l _) '\n' = Pos (l+1) 1
 124 alexMove (Pos l c) '\t' = Pos l ((c+8) `div` 8 * 8)
 125 alexMove (Pos l c) _    = Pos l (c+1)
 126
 127 init_pos :: Pos
 128 init_pos = Pos 1 1
 129
 130 show_pos :: Pos -> String
 131 show_pos (Pos l c) = "line " ++ show l ++ ", column " ++ show c
 132
 133 -- Input
 134
 135 data AlexInput = AlexInput {position :: !Pos, input :: String}
 136
 137 alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
 138 alexGetChar (AlexInput p (x:xs)) = Just (x, AlexInput (alexMove p x) xs)
 139 alexGetChar (AlexInput _ []) = Nothing
 140
 141 alexInputPrevChar :: AlexInput -> Char
 142 alexInputPrevChar _ = error "Lexer doesn't implement alexInputPrevChar"
 143
 144 happyError :: ParserM a
 145 happyError = do p <- get_pos
 146                 fail $ "Parse error at " ++ show_pos p
 147