/hhydra/HydraParser.hs
http://hhydra.googlecode.com/ · Haskell · 422 lines · 217 code · 107 blank · 98 comment · 3 complexity · a0b7d4a8379681eea0f7e6b438e94f90 MD5 · raw file
- {-
- Copyright (c) 2007, Enrico Franchi
- All rights reserved.
- Redistribution and use in source and binary forms, with or without
- modification, are permitted provided that the following conditions are
- met:
- 1) Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
- 2) Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer in the
- documentation and/or other materials provided with the distribution.
- 3) Neither my name nor the names of its contributors may be used to
- endorse or promote products derived from this software without specific
- prior written permission.
- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
- -}
- module HydraParser
- where
- import Hydra
- -- parser produced by Happy Version 1.16
- data HappyAbsSyn t4 t5 t6 t7 t8
- = HappyTerminal Token
- | HappyErrorToken Int
- | HappyAbsSyn4 t4
- | HappyAbsSyn5 t5
- | HappyAbsSyn6 t6
- | HappyAbsSyn7 t7
- | HappyAbsSyn8 t8
- action_0 (9) = happyShift action_4
- action_0 (4) = happyGoto action_3
- action_0 _ = happyFail
- action_1 (9) = happyShift action_2
- action_1 _ = happyFail
- action_2 (10) = happyShift action_9
- action_2 _ = happyFail
- action_3 (11) = happyAccept
- action_3 _ = happyFail
- action_4 (9) = happyShift action_8
- action_4 (10) = happyShift action_9
- action_4 (5) = happyGoto action_5
- action_4 (6) = happyGoto action_6
- action_4 (8) = happyGoto action_7
- action_4 _ = happyFail
- action_5 (9) = happyShift action_8
- action_5 (5) = happyGoto action_5
- action_5 (6) = happyGoto action_6
- action_5 (7) = happyGoto action_15
- action_5 (8) = happyGoto action_14
- action_5 _ = happyReduce_5
- action_6 (9) = happyShift action_8
- action_6 (5) = happyGoto action_5
- action_6 (6) = happyGoto action_6
- action_6 (7) = happyGoto action_13
- action_6 (8) = happyGoto action_14
- action_6 _ = happyReduce_5
- action_7 (10) = happyShift action_12
- action_7 _ = happyFail
- action_8 (9) = happyShift action_8
- action_8 (10) = happyShift action_11
- action_8 (5) = happyGoto action_5
- action_8 (6) = happyGoto action_6
- action_8 (8) = happyGoto action_10
- action_8 _ = happyFail
- action_9 _ = happyReduce_1
- action_10 (10) = happyShift action_16
- action_10 _ = happyFail
- action_11 _ = happyReduce_3
- action_12 _ = happyReduce_2
- action_13 _ = happyReduce_7
- action_14 _ = happyReduce_6
- action_15 _ = happyReduce_8
- action_16 _ = happyReduce_4
- happyReduce_1 = happySpecReduce_2 4 happyReduction_1
- happyReduction_1 _
- _
- = HappyAbsSyn4
- (Root []
- )
- happyReduce_2 = happySpecReduce_3 4 happyReduction_2
- happyReduction_2 _
- (HappyAbsSyn8 happy_var_2)
- _
- = HappyAbsSyn4
- (Root happy_var_2
- )
- happyReduction_2 _ _ _ = notHappyAtAll
- happyReduce_3 = happySpecReduce_2 5 happyReduction_3
- happyReduction_3 _
- _
- = HappyAbsSyn5
- (Head 0 0
- )
- happyReduce_4 = happySpecReduce_3 6 happyReduction_4
- happyReduction_4 _
- (HappyAbsSyn8 happy_var_2)
- _
- = HappyAbsSyn6
- (Body 0 0 happy_var_2
- )
- happyReduction_4 _ _ _ = notHappyAtAll
- happyReduce_5 = happySpecReduce_0 7 happyReduction_5
- happyReduction_5 = HappyAbsSyn7
- ([]
- )
- happyReduce_6 = happySpecReduce_1 7 happyReduction_6
- happyReduction_6 (HappyAbsSyn8 happy_var_1)
- = HappyAbsSyn7
- (happy_var_1
- )
- happyReduction_6 _ = notHappyAtAll
- happyReduce_7 = happySpecReduce_2 8 happyReduction_7
- happyReduction_7 (HappyAbsSyn7 happy_var_2)
- (HappyAbsSyn6 happy_var_1)
- = HappyAbsSyn8
- (happy_var_1:happy_var_2
- )
- happyReduction_7 _ _ = notHappyAtAll
- happyReduce_8 = happySpecReduce_2 8 happyReduction_8
- happyReduction_8 (HappyAbsSyn7 happy_var_2)
- (HappyAbsSyn5 happy_var_1)
- = HappyAbsSyn8
- (happy_var_1:happy_var_2
- )
- happyReduction_8 _ _ = notHappyAtAll
- happyNewToken action sts stk [] =
- action 11 11 notHappyAtAll (HappyState action) sts stk []
- happyNewToken action sts stk (tk:tks) =
- let cont i = action i i tk (HappyState action) sts stk tks in
- case tk of {
- LParen -> cont 9;
- RParen -> cont 10;
- _ -> happyError' (tk:tks)
- }
- happyError_ tk tks = happyError' (tk:tks)
- newtype HappyIdentity a = HappyIdentity a
- happyIdentity = HappyIdentity
- happyRunIdentity (HappyIdentity a) = a
- instance Monad HappyIdentity where
- return = HappyIdentity
- (HappyIdentity p) >>= q = q p
- happyThen :: () => HappyIdentity a -> (a -> HappyIdentity b) -> HappyIdentity b
- happyThen = (>>=)
- happyReturn :: () => a -> HappyIdentity a
- happyReturn = (return)
- happyThen1 m k tks = (>>=) m (\a -> k a tks)
- happyReturn1 :: () => a -> b -> HappyIdentity a
- happyReturn1 = \a tks -> (return) a
- happyError' :: () => [Token] -> HappyIdentity a
- happyError' = HappyIdentity . parseError
- parse tks = happyRunIdentity happySomeParser where
- happySomeParser = happyThen (happyParse action_0 tks) (\x -> case x of {HappyAbsSyn4 z -> happyReturn z; _other -> notHappyAtAll })
- happySeq = happyDontSeq
- parseError :: [Token] -> a
- parseError _ = error "Parse error"
- data Token = RParen | LParen
- deriving (Eq, Show)
- type TokenStream = [Token]
- tokenize :: [Char] -> [Token]
- tokenize [] = []
- tokenize ('(':cs) = (LParen : tokenize cs)
- tokenize (')':cs) = (RParen : tokenize cs)
- tokenize (c:cs) = tokenize cs
- -- hydra :: String -> Hydra a b
- hydra = parse . tokenize
- {-# LINE 1 "GenericTemplate.hs" #-}
- {-# LINE 1 "<built-in>" #-}
- {-# LINE 1 "<command line>" #-}
- {-# LINE 1 "GenericTemplate.hs" #-}
- -- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp
- {-# LINE 28 "GenericTemplate.hs" #-}
- {-# LINE 49 "GenericTemplate.hs" #-}
- {-# LINE 59 "GenericTemplate.hs" #-}
- {-# LINE 68 "GenericTemplate.hs" #-}
- infixr 9 `HappyStk`
- data HappyStk a = HappyStk a (HappyStk a)
- -----------------------------------------------------------------------------
- -- starting the parse
- happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll
- -----------------------------------------------------------------------------
- -- Accepting the parse
- -- If the current token is (1), it means we've just accepted a partial
- -- parse (a %partial parser). We must ignore the saved token on the top of
- -- the stack in this case.
- happyAccept (1) tk st sts (_ `HappyStk` ans `HappyStk` _) =
- happyReturn1 ans
- happyAccept j tk st sts (HappyStk ans _) =
- (happyReturn1 ans)
- -----------------------------------------------------------------------------
- -- Arrays only: do the next action
- {-# LINE 155 "GenericTemplate.hs" #-}
- -----------------------------------------------------------------------------
- -- HappyState data type (not arrays)
- newtype HappyState b c = HappyState
- (Int -> -- token number
- Int -> -- token number (yes, again)
- b -> -- token semantic value
- HappyState b c -> -- current state
- [HappyState b c] -> -- state stack
- c)
- -----------------------------------------------------------------------------
- -- Shifting a token
- happyShift new_state (1) tk st sts stk@(x `HappyStk` _) =
- let i = (case x of { HappyErrorToken (i) -> i }) in
- -- trace "shifting the error token" $
- new_state i i tk (HappyState (new_state)) ((st):(sts)) (stk)
- happyShift new_state i tk st sts stk =
- happyNewToken new_state ((st):(sts)) ((HappyTerminal (tk))`HappyStk`stk)
- -- happyReduce is specialised for the common cases.
- happySpecReduce_0 i fn (1) tk st sts stk
- = happyFail (1) tk st sts stk
- happySpecReduce_0 nt fn j tk st@((HappyState (action))) sts stk
- = action nt j tk st ((st):(sts)) (fn `HappyStk` stk)
- happySpecReduce_1 i fn (1) tk st sts stk
- = happyFail (1) tk st sts stk
- happySpecReduce_1 nt fn j tk _ sts@(((st@(HappyState (action))):(_))) (v1`HappyStk`stk')
- = let r = fn v1 in
- happySeq r (action nt j tk st sts (r `HappyStk` stk'))
- happySpecReduce_2 i fn (1) tk st sts stk
- = happyFail (1) tk st sts stk
- happySpecReduce_2 nt fn j tk _ ((_):(sts@(((st@(HappyState (action))):(_))))) (v1`HappyStk`v2`HappyStk`stk')
- = let r = fn v1 v2 in
- happySeq r (action nt j tk st sts (r `HappyStk` stk'))
- happySpecReduce_3 i fn (1) tk st sts stk
- = happyFail (1) tk st sts stk
- happySpecReduce_3 nt fn j tk _ ((_):(((_):(sts@(((st@(HappyState (action))):(_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')
- = let r = fn v1 v2 v3 in
- happySeq r (action nt j tk st sts (r `HappyStk` stk'))
- happyReduce k i fn (1) tk st sts stk
- = happyFail (1) tk st sts stk
- happyReduce k nt fn j tk st sts stk
- = case happyDrop (k - ((1) :: Int)) sts of
- sts1@(((st1@(HappyState (action))):(_))) ->
- let r = fn stk in -- it doesn't hurt to always seq here...
- happyDoSeq r (action nt j tk st1 sts1 r)
- happyMonadReduce k nt fn (1) tk st sts stk
- = happyFail (1) tk st sts stk
- happyMonadReduce k nt fn j tk st sts stk =
- happyThen1 (fn stk tk) (\r -> action nt j tk st1 sts1 (r `HappyStk` drop_stk))
- where sts1@(((st1@(HappyState (action))):(_))) = happyDrop k ((st):(sts))
- drop_stk = happyDropStk k stk
- happyMonad2Reduce k nt fn (1) tk st sts stk
- = happyFail (1) tk st sts stk
- happyMonad2Reduce k nt fn j tk st sts stk =
- happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))
- where sts1@(((st1@(HappyState (action))):(_))) = happyDrop k ((st):(sts))
- drop_stk = happyDropStk k stk
- new_state = action
- happyDrop (0) l = l
- happyDrop n ((_):(t)) = happyDrop (n - ((1) :: Int)) t
- happyDropStk (0) l = l
- happyDropStk n (x `HappyStk` xs) = happyDropStk (n - ((1)::Int)) xs
- -----------------------------------------------------------------------------
- -- Moving to a new state after a reduction
- {-# LINE 253 "GenericTemplate.hs" #-}
- happyGoto action j tk st = action j j tk (HappyState action)
- -----------------------------------------------------------------------------
- -- Error recovery ((1) is the error token)
- -- parse error if we are in recovery and we fail again
- happyFail (1) tk old_st _ stk =
- -- trace "failing" $
- happyError_ tk
- {- We don't need state discarding for our restricted implementation of
- "error". In fact, it can cause some bogus parses, so I've disabled it
- for now --SDM
- -- discard a state
- happyFail (1) tk old_st (((HappyState (action))):(sts))
- (saved_tok `HappyStk` _ `HappyStk` stk) =
- -- trace ("discarding state, depth " ++ show (length stk)) $
- action (1) (1) tk (HappyState (action)) sts ((saved_tok`HappyStk`stk))
- -}
- -- Enter error recovery: generate an error token,
- -- save the old token and carry on.
- happyFail i tk (HappyState (action)) sts stk =
- -- trace "entering error recovery" $
- action (1) (1) tk (HappyState (action)) sts ( (HappyErrorToken (i)) `HappyStk` stk)
- -- Internal happy errors:
- notHappyAtAll = error "Internal Happy error\n"
- -----------------------------------------------------------------------------
- -- Hack to get the typechecker to accept our action functions
- -----------------------------------------------------------------------------
- -- Seq-ing. If the --strict flag is given, then Happy emits
- -- happySeq = happyDoSeq
- -- otherwise it emits
- -- happySeq = happyDontSeq
- happyDoSeq, happyDontSeq :: a -> b -> b
- happyDoSeq a b = a `seq` b
- happyDontSeq a b = b
- -----------------------------------------------------------------------------
- -- Don't inline any functions from the template. GHC has a nasty habit
- -- of deciding to inline happyGoto everywhere, which increases the size of
- -- the generated parser quite a bit.
- {-# LINE 317 "GenericTemplate.hs" #-}
- {-# NOINLINE happyShift #-}
- {-# NOINLINE happySpecReduce_0 #-}
- {-# NOINLINE happySpecReduce_1 #-}
- {-# NOINLINE happySpecReduce_2 #-}
- {-# NOINLINE happySpecReduce_3 #-}
- {-# NOINLINE happyReduce #-}
- {-# NOINLINE happyMonadReduce #-}
- {-# NOINLINE happyGoto #-}
- {-# NOINLINE happyFail #-}
- -- end of Happy Template.