ParserM.hs 4.67 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
    -- Other
    happyError
 ) where
19 20
import Control.Applicative
import Control.Monad (ap, liftM)
Simon Marlow's avatar
Simon Marlow committed
21 22 23
import Data.Word (Word8)
import Data.Char (ord)

24 25 26
-- Parser Monad
newtype ParserM a = ParserM (AlexInput -> St -> Either String (AlexInput, St, a))

27 28 29 30 31 32 33
instance Functor ParserM where
  fmap = liftM

instance Applicative ParserM where
  pure  = return
  (<*>) = ap

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
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
69
           | TDArrow
70 71 72 73 74 75 76 77
           | TEquals
           | TComma
           | TOpenParen
           | TCloseParen
           | TOpenParenHash
           | THashCloseParen
           | TOpenBrace
           | TCloseBrace
78 79 80 81
           | TOpenBracket
           | TCloseBracket
           | TOpenAngle
           | TCloseAngle
82 83 84 85
           | TSection
           | TPrimop
           | TPseudoop
           | TPrimtype
86
           | TPrimclass
87 88 89 90 91 92 93 94 95 96 97 98 99
           | TWith
           | TDefaults
           | TTrue
           | TFalse
           | TDyadic
           | TMonadic
           | TCompare
           | TGenPrimOp
           | TThatsAllFolks
           | TLowerName String
           | TUpperName String
           | TString String
           | TNoBraces String
100
           | TInteger Int
101 102 103 104 105
           | TFixity
           | TInfixN
           | TInfixL
           | TInfixR
           | TNothing
106 107 108 109
           | TVector
           | TSCALAR
           | TVECTOR
           | TVECTUPLE
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 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160
    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
161 162 163 164 165 166 167
-- 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

168 169 170 171 172 173 174 175 176 177 178
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