1
2module ParserM (
3    -- Parser Monad
4    ParserM(..), AlexInput, run_parser,
5    -- Parser state
6    St, StartCode, start_code, set_start_code,
7    -- Tokens
8    Token(..),
9    -- Tree
10    Tree(..),
11    -- Actions
12    Action, andBegin, mkT,
13    -- Positions
14    get_pos, show_pos,
15    -- Input
16    alexGetByte, alexInputPrevChar, input, position,
17    -- Other
18    happyError
19 ) where
20
21import Control.Applicative (Applicative(..))
22import Control.Monad (ap, liftM)
23import Control.Monad.Except (throwError)
24import Control.Monad.State (StateT, evalStateT, get, put)
25import Control.Monad.Trans (lift)
26import Data.Char (ord)
27import Data.Word (Word8)
28
29-- Parser Monad
30newtype ParserM a = ParserM (AlexInput -> StateT St (Either String) (AlexInput, a))
31
32instance Functor ParserM where
33    fmap = liftM
34
35instance Applicative ParserM where
36    pure a = ParserM $ \i -> return (i, a)
37    (<*>) = ap
38
39instance Monad ParserM where
40    return = pure
41    ParserM m >>= k = ParserM $ \i -> do (i', x) <- m i
42                                         case k x of
43                                             ParserM y -> y i'
44    fail err = ParserM $ \_ -> fail err
45
46run_parser :: ParserM a -> (String -> Either String a)
47run_parser (ParserM p)
48 = \s -> case evalStateT (p (AlexInput init_pos s)) init_state of
49             Left es -> throwError es
50             Right (_, x) -> return x
51
52-- Parser state
53
54data St = St {start_code :: !StartCode}
55type StartCode = Int
56
57init_state :: St
58init_state = St 0
59
60-- Tokens
61
62data Token = TEOF
63           | TFork
64           | TLeaf
65
66-- Tree
67
68data Tree = Leaf
69          | Fork Tree Tree
70    deriving Show
71
72-- Actions
73
74type Action = (AlexInput, String) -> StateT St (Either String) (Token, AlexInput)
75
76set_start_code :: StartCode -> StateT St (Either String) ()
77set_start_code sc = do st <- get
78                       put $ st { start_code = sc }
79
80andBegin :: Action -> StartCode -> Action
81(act `andBegin` sc) x = do set_start_code sc
82                           act x
83
84mkT :: Token -> Action
85mkT t (p,_) = lift $ return (t, p)
86
87-- Positions
88
89data Pos = Pos !Int{- Line -} !Int{- Column -}
90
91get_pos :: ParserM Pos
92get_pos = ParserM $ \i@(AlexInput p _) -> return (i, p)
93
94alexMove :: Pos -> Char -> Pos
95alexMove (Pos l _) '\n' = Pos (l+1) 1
96alexMove (Pos l c) '\t' = Pos l ((c+8) `div` 8 * 8)
97alexMove (Pos l c) _    = Pos l (c+1)
98
99init_pos :: Pos
100init_pos = Pos 1 1
101
102show_pos :: Pos -> String
103show_pos (Pos l c) = "line " ++ show l ++ ", column " ++ show c
104
105-- Input
106
107data AlexInput = AlexInput {position :: !Pos, input :: String}
108
109alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)
110alexGetByte (AlexInput p (x:xs)) = Just (fromIntegral (ord x),
111                                         AlexInput (alexMove p x) xs)
112alexGetByte (AlexInput _ []) = Nothing
113
114alexInputPrevChar :: AlexInput -> Char
115alexInputPrevChar _ = error "Lexer doesn't implement alexInputPrevChar"
116
117happyError :: ParserM a
118happyError = do p <- get_pos
119                fail $ "Parse error at " ++ show_pos p
120
121