ParserM.hs 4.28 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14
module ParserM (
    -- Parser Monad
    ParserM(..), AlexInput, run_parser,
    -- Parser state
    St,
    StartCode, start_code, set_start_code,
    inc_brace_depth, dec_brace_depth,
    -- Tokens
    Token(..),
    -- Actions
    Action, andBegin, mkT, mkTv,
    -- Positions
    get_pos, show_pos,
    -- Input
Simon Marlow's avatar
Simon Marlow committed
15
    alexGetChar, alexGetByte, alexInputPrevChar, input, position,
16 17 18 19
    -- Other
    happyError
 ) where

Simon Marlow's avatar
Simon Marlow committed
20 21 22
import Data.Word (Word8)
import Data.Char (ord)

23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85
-- Parser Monad
newtype ParserM a = ParserM (AlexInput -> St -> Either String (AlexInput, St, a))

instance Monad ParserM where
    ParserM m >>= k = ParserM $ \i s -> case m i s of
                                            Right (i', s', x) ->
                                                case k x of
                                                    ParserM y -> y i' s'
                                            Left err ->
                                                Left err
    return a = ParserM $ \i s -> Right (i, s, a)
    fail err = ParserM $ \_ _ -> Left err

run_parser :: ParserM a -> (String -> Either String a)
run_parser (ParserM f)
 = \s -> case f (AlexInput init_pos s) init_state of
             Left es -> Left es
             Right (_, _, x) -> Right x

-- Parser state

data St = St {
              start_code :: !StartCode,
              brace_depth :: !Int
          }
    deriving Show
type StartCode = Int

init_state :: St
init_state = St {
                 start_code = 0,
                 brace_depth = 0
             }

-- Tokens

data Token = TEOF
           | TArrow
           | TEquals
           | TComma
           | TOpenParen
           | TCloseParen
           | TOpenParenHash
           | THashCloseParen
           | TOpenBrace
           | TCloseBrace
           | TSection
           | TPrimop
           | TPseudoop
           | TPrimtype
           | TWith
           | TDefaults
           | TTrue
           | TFalse
           | TDyadic
           | TMonadic
           | TCompare
           | TGenPrimOp
           | TThatsAllFolks
           | TLowerName String
           | TUpperName String
           | TString String
           | TNoBraces String
86
           | TInteger Int
87 88 89 90 91
           | TFixity
           | TInfixN
           | TInfixL
           | TInfixR
           | TNothing
92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142
    deriving Show

-- Actions

type Action = String -> ParserM Token

set_start_code :: StartCode -> ParserM ()
set_start_code sc = ParserM $ \i st -> Right (i, st { start_code = sc }, ())

inc_brace_depth :: ParserM ()
inc_brace_depth = ParserM $ \i st ->
                  Right (i, st { brace_depth = brace_depth st + 1 }, ())

dec_brace_depth :: ParserM ()
dec_brace_depth = ParserM $ \i st ->
                  let bd = brace_depth st - 1
                      sc = if bd == 0 then 0 else 1
                  in Right (i, st { brace_depth = bd, start_code = sc }, ())

andBegin :: Action -> StartCode -> Action
(act `andBegin` sc) x = do set_start_code sc
                           act x

mkT :: Token -> Action
mkT t = mkTv (const t)

mkTv :: (String -> Token) -> Action
mkTv f str = ParserM (\i st -> Right (i, st, f str))

-- Positions

data Pos = Pos !Int{- Line -} !Int{- Column -}

get_pos :: ParserM Pos
get_pos = ParserM $ \i@(AlexInput p _) st -> Right (i, st, p)

alexMove :: Pos -> Char -> Pos
alexMove (Pos l _) '\n' = Pos (l+1) 1
alexMove (Pos l c) '\t' = Pos l ((c+8) `div` 8 * 8)
alexMove (Pos l c) _    = Pos l (c+1)

init_pos :: Pos
init_pos = Pos 1 1

show_pos :: Pos -> String
show_pos (Pos l c) = "line " ++ show l ++ ", column " ++ show c

-- Input

data AlexInput = AlexInput {position :: !Pos, input :: String}

Simon Marlow's avatar
Simon Marlow committed
143 144 145 146 147 148 149
-- alexGetByte is for Alex >= 3.0, alexGetChar for earlier
-- XXX no UTF-8; we should do this properly sometime
alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)
alexGetByte (AlexInput p (x:xs)) = Just (fromIntegral (ord x),
                                         AlexInput (alexMove p x) xs)
alexGetByte (AlexInput _ []) = Nothing

150 151 152 153 154 155 156 157 158 159 160
alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
alexGetChar (AlexInput p (x:xs)) = Just (x, AlexInput (alexMove p x) xs)
alexGetChar (AlexInput _ []) = Nothing

alexInputPrevChar :: AlexInput -> Char
alexInputPrevChar _ = error "Lexer doesn't implement alexInputPrevChar"

happyError :: ParserM a
happyError = do p <- get_pos
                fail $ "Parse error at " ++ show_pos p