/hhydra/HydraParser.hs

http://hhydra.googlecode.com/ · Haskell · 422 lines · 217 code · 107 blank · 98 comment · 3 complexity · a0b7d4a8379681eea0f7e6b438e94f90 MD5 · raw file

  1. {-
  2. Copyright (c) 2007, Enrico Franchi
  3. All rights reserved.
  4. Redistribution and use in source and binary forms, with or without
  5. modification, are permitted provided that the following conditions are
  6. met:
  7. 1) Redistributions of source code must retain the above copyright
  8. notice, this list of conditions and the following disclaimer.
  9. 2) Redistributions in binary form must reproduce the above copyright
  10. notice, this list of conditions and the following disclaimer in the
  11. documentation and/or other materials provided with the distribution.
  12. 3) Neither my name nor the names of its contributors may be used to
  13. endorse or promote products derived from this software without specific
  14. prior written permission.
  15. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
  16. IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
  17. TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
  18. PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
  19. OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
  20. EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
  21. PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
  22. PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
  23. LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  24. NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  25. SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  26. -}
  27. module HydraParser
  28. where
  29. import Hydra
  30. -- parser produced by Happy Version 1.16
  31. data HappyAbsSyn t4 t5 t6 t7 t8
  32. = HappyTerminal Token
  33. | HappyErrorToken Int
  34. | HappyAbsSyn4 t4
  35. | HappyAbsSyn5 t5
  36. | HappyAbsSyn6 t6
  37. | HappyAbsSyn7 t7
  38. | HappyAbsSyn8 t8
  39. action_0 (9) = happyShift action_4
  40. action_0 (4) = happyGoto action_3
  41. action_0 _ = happyFail
  42. action_1 (9) = happyShift action_2
  43. action_1 _ = happyFail
  44. action_2 (10) = happyShift action_9
  45. action_2 _ = happyFail
  46. action_3 (11) = happyAccept
  47. action_3 _ = happyFail
  48. action_4 (9) = happyShift action_8
  49. action_4 (10) = happyShift action_9
  50. action_4 (5) = happyGoto action_5
  51. action_4 (6) = happyGoto action_6
  52. action_4 (8) = happyGoto action_7
  53. action_4 _ = happyFail
  54. action_5 (9) = happyShift action_8
  55. action_5 (5) = happyGoto action_5
  56. action_5 (6) = happyGoto action_6
  57. action_5 (7) = happyGoto action_15
  58. action_5 (8) = happyGoto action_14
  59. action_5 _ = happyReduce_5
  60. action_6 (9) = happyShift action_8
  61. action_6 (5) = happyGoto action_5
  62. action_6 (6) = happyGoto action_6
  63. action_6 (7) = happyGoto action_13
  64. action_6 (8) = happyGoto action_14
  65. action_6 _ = happyReduce_5
  66. action_7 (10) = happyShift action_12
  67. action_7 _ = happyFail
  68. action_8 (9) = happyShift action_8
  69. action_8 (10) = happyShift action_11
  70. action_8 (5) = happyGoto action_5
  71. action_8 (6) = happyGoto action_6
  72. action_8 (8) = happyGoto action_10
  73. action_8 _ = happyFail
  74. action_9 _ = happyReduce_1
  75. action_10 (10) = happyShift action_16
  76. action_10 _ = happyFail
  77. action_11 _ = happyReduce_3
  78. action_12 _ = happyReduce_2
  79. action_13 _ = happyReduce_7
  80. action_14 _ = happyReduce_6
  81. action_15 _ = happyReduce_8
  82. action_16 _ = happyReduce_4
  83. happyReduce_1 = happySpecReduce_2 4 happyReduction_1
  84. happyReduction_1 _
  85. _
  86. = HappyAbsSyn4
  87. (Root []
  88. )
  89. happyReduce_2 = happySpecReduce_3 4 happyReduction_2
  90. happyReduction_2 _
  91. (HappyAbsSyn8 happy_var_2)
  92. _
  93. = HappyAbsSyn4
  94. (Root happy_var_2
  95. )
  96. happyReduction_2 _ _ _ = notHappyAtAll
  97. happyReduce_3 = happySpecReduce_2 5 happyReduction_3
  98. happyReduction_3 _
  99. _
  100. = HappyAbsSyn5
  101. (Head 0 0
  102. )
  103. happyReduce_4 = happySpecReduce_3 6 happyReduction_4
  104. happyReduction_4 _
  105. (HappyAbsSyn8 happy_var_2)
  106. _
  107. = HappyAbsSyn6
  108. (Body 0 0 happy_var_2
  109. )
  110. happyReduction_4 _ _ _ = notHappyAtAll
  111. happyReduce_5 = happySpecReduce_0 7 happyReduction_5
  112. happyReduction_5 = HappyAbsSyn7
  113. ([]
  114. )
  115. happyReduce_6 = happySpecReduce_1 7 happyReduction_6
  116. happyReduction_6 (HappyAbsSyn8 happy_var_1)
  117. = HappyAbsSyn7
  118. (happy_var_1
  119. )
  120. happyReduction_6 _ = notHappyAtAll
  121. happyReduce_7 = happySpecReduce_2 8 happyReduction_7
  122. happyReduction_7 (HappyAbsSyn7 happy_var_2)
  123. (HappyAbsSyn6 happy_var_1)
  124. = HappyAbsSyn8
  125. (happy_var_1:happy_var_2
  126. )
  127. happyReduction_7 _ _ = notHappyAtAll
  128. happyReduce_8 = happySpecReduce_2 8 happyReduction_8
  129. happyReduction_8 (HappyAbsSyn7 happy_var_2)
  130. (HappyAbsSyn5 happy_var_1)
  131. = HappyAbsSyn8
  132. (happy_var_1:happy_var_2
  133. )
  134. happyReduction_8 _ _ = notHappyAtAll
  135. happyNewToken action sts stk [] =
  136. action 11 11 notHappyAtAll (HappyState action) sts stk []
  137. happyNewToken action sts stk (tk:tks) =
  138. let cont i = action i i tk (HappyState action) sts stk tks in
  139. case tk of {
  140. LParen -> cont 9;
  141. RParen -> cont 10;
  142. _ -> happyError' (tk:tks)
  143. }
  144. happyError_ tk tks = happyError' (tk:tks)
  145. newtype HappyIdentity a = HappyIdentity a
  146. happyIdentity = HappyIdentity
  147. happyRunIdentity (HappyIdentity a) = a
  148. instance Monad HappyIdentity where
  149. return = HappyIdentity
  150. (HappyIdentity p) >>= q = q p
  151. happyThen :: () => HappyIdentity a -> (a -> HappyIdentity b) -> HappyIdentity b
  152. happyThen = (>>=)
  153. happyReturn :: () => a -> HappyIdentity a
  154. happyReturn = (return)
  155. happyThen1 m k tks = (>>=) m (\a -> k a tks)
  156. happyReturn1 :: () => a -> b -> HappyIdentity a
  157. happyReturn1 = \a tks -> (return) a
  158. happyError' :: () => [Token] -> HappyIdentity a
  159. happyError' = HappyIdentity . parseError
  160. parse tks = happyRunIdentity happySomeParser where
  161. happySomeParser = happyThen (happyParse action_0 tks) (\x -> case x of {HappyAbsSyn4 z -> happyReturn z; _other -> notHappyAtAll })
  162. happySeq = happyDontSeq
  163. parseError :: [Token] -> a
  164. parseError _ = error "Parse error"
  165. data Token = RParen | LParen
  166. deriving (Eq, Show)
  167. type TokenStream = [Token]
  168. tokenize :: [Char] -> [Token]
  169. tokenize [] = []
  170. tokenize ('(':cs) = (LParen : tokenize cs)
  171. tokenize (')':cs) = (RParen : tokenize cs)
  172. tokenize (c:cs) = tokenize cs
  173. -- hydra :: String -> Hydra a b
  174. hydra = parse . tokenize
  175. {-# LINE 1 "GenericTemplate.hs" #-}
  176. {-# LINE 1 "<built-in>" #-}
  177. {-# LINE 1 "<command line>" #-}
  178. {-# LINE 1 "GenericTemplate.hs" #-}
  179. -- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp
  180. {-# LINE 28 "GenericTemplate.hs" #-}
  181. {-# LINE 49 "GenericTemplate.hs" #-}
  182. {-# LINE 59 "GenericTemplate.hs" #-}
  183. {-# LINE 68 "GenericTemplate.hs" #-}
  184. infixr 9 `HappyStk`
  185. data HappyStk a = HappyStk a (HappyStk a)
  186. -----------------------------------------------------------------------------
  187. -- starting the parse
  188. happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll
  189. -----------------------------------------------------------------------------
  190. -- Accepting the parse
  191. -- If the current token is (1), it means we've just accepted a partial
  192. -- parse (a %partial parser). We must ignore the saved token on the top of
  193. -- the stack in this case.
  194. happyAccept (1) tk st sts (_ `HappyStk` ans `HappyStk` _) =
  195. happyReturn1 ans
  196. happyAccept j tk st sts (HappyStk ans _) =
  197. (happyReturn1 ans)
  198. -----------------------------------------------------------------------------
  199. -- Arrays only: do the next action
  200. {-# LINE 155 "GenericTemplate.hs" #-}
  201. -----------------------------------------------------------------------------
  202. -- HappyState data type (not arrays)
  203. newtype HappyState b c = HappyState
  204. (Int -> -- token number
  205. Int -> -- token number (yes, again)
  206. b -> -- token semantic value
  207. HappyState b c -> -- current state
  208. [HappyState b c] -> -- state stack
  209. c)
  210. -----------------------------------------------------------------------------
  211. -- Shifting a token
  212. happyShift new_state (1) tk st sts stk@(x `HappyStk` _) =
  213. let i = (case x of { HappyErrorToken (i) -> i }) in
  214. -- trace "shifting the error token" $
  215. new_state i i tk (HappyState (new_state)) ((st):(sts)) (stk)
  216. happyShift new_state i tk st sts stk =
  217. happyNewToken new_state ((st):(sts)) ((HappyTerminal (tk))`HappyStk`stk)
  218. -- happyReduce is specialised for the common cases.
  219. happySpecReduce_0 i fn (1) tk st sts stk
  220. = happyFail (1) tk st sts stk
  221. happySpecReduce_0 nt fn j tk st@((HappyState (action))) sts stk
  222. = action nt j tk st ((st):(sts)) (fn `HappyStk` stk)
  223. happySpecReduce_1 i fn (1) tk st sts stk
  224. = happyFail (1) tk st sts stk
  225. happySpecReduce_1 nt fn j tk _ sts@(((st@(HappyState (action))):(_))) (v1`HappyStk`stk')
  226. = let r = fn v1 in
  227. happySeq r (action nt j tk st sts (r `HappyStk` stk'))
  228. happySpecReduce_2 i fn (1) tk st sts stk
  229. = happyFail (1) tk st sts stk
  230. happySpecReduce_2 nt fn j tk _ ((_):(sts@(((st@(HappyState (action))):(_))))) (v1`HappyStk`v2`HappyStk`stk')
  231. = let r = fn v1 v2 in
  232. happySeq r (action nt j tk st sts (r `HappyStk` stk'))
  233. happySpecReduce_3 i fn (1) tk st sts stk
  234. = happyFail (1) tk st sts stk
  235. happySpecReduce_3 nt fn j tk _ ((_):(((_):(sts@(((st@(HappyState (action))):(_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')
  236. = let r = fn v1 v2 v3 in
  237. happySeq r (action nt j tk st sts (r `HappyStk` stk'))
  238. happyReduce k i fn (1) tk st sts stk
  239. = happyFail (1) tk st sts stk
  240. happyReduce k nt fn j tk st sts stk
  241. = case happyDrop (k - ((1) :: Int)) sts of
  242. sts1@(((st1@(HappyState (action))):(_))) ->
  243. let r = fn stk in -- it doesn't hurt to always seq here...
  244. happyDoSeq r (action nt j tk st1 sts1 r)
  245. happyMonadReduce k nt fn (1) tk st sts stk
  246. = happyFail (1) tk st sts stk
  247. happyMonadReduce k nt fn j tk st sts stk =
  248. happyThen1 (fn stk tk) (\r -> action nt j tk st1 sts1 (r `HappyStk` drop_stk))
  249. where sts1@(((st1@(HappyState (action))):(_))) = happyDrop k ((st):(sts))
  250. drop_stk = happyDropStk k stk
  251. happyMonad2Reduce k nt fn (1) tk st sts stk
  252. = happyFail (1) tk st sts stk
  253. happyMonad2Reduce k nt fn j tk st sts stk =
  254. happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))
  255. where sts1@(((st1@(HappyState (action))):(_))) = happyDrop k ((st):(sts))
  256. drop_stk = happyDropStk k stk
  257. new_state = action
  258. happyDrop (0) l = l
  259. happyDrop n ((_):(t)) = happyDrop (n - ((1) :: Int)) t
  260. happyDropStk (0) l = l
  261. happyDropStk n (x `HappyStk` xs) = happyDropStk (n - ((1)::Int)) xs
  262. -----------------------------------------------------------------------------
  263. -- Moving to a new state after a reduction
  264. {-# LINE 253 "GenericTemplate.hs" #-}
  265. happyGoto action j tk st = action j j tk (HappyState action)
  266. -----------------------------------------------------------------------------
  267. -- Error recovery ((1) is the error token)
  268. -- parse error if we are in recovery and we fail again
  269. happyFail (1) tk old_st _ stk =
  270. -- trace "failing" $
  271. happyError_ tk
  272. {- We don't need state discarding for our restricted implementation of
  273. "error". In fact, it can cause some bogus parses, so I've disabled it
  274. for now --SDM
  275. -- discard a state
  276. happyFail (1) tk old_st (((HappyState (action))):(sts))
  277. (saved_tok `HappyStk` _ `HappyStk` stk) =
  278. -- trace ("discarding state, depth " ++ show (length stk)) $
  279. action (1) (1) tk (HappyState (action)) sts ((saved_tok`HappyStk`stk))
  280. -}
  281. -- Enter error recovery: generate an error token,
  282. -- save the old token and carry on.
  283. happyFail i tk (HappyState (action)) sts stk =
  284. -- trace "entering error recovery" $
  285. action (1) (1) tk (HappyState (action)) sts ( (HappyErrorToken (i)) `HappyStk` stk)
  286. -- Internal happy errors:
  287. notHappyAtAll = error "Internal Happy error\n"
  288. -----------------------------------------------------------------------------
  289. -- Hack to get the typechecker to accept our action functions
  290. -----------------------------------------------------------------------------
  291. -- Seq-ing. If the --strict flag is given, then Happy emits
  292. -- happySeq = happyDoSeq
  293. -- otherwise it emits
  294. -- happySeq = happyDontSeq
  295. happyDoSeq, happyDontSeq :: a -> b -> b
  296. happyDoSeq a b = a `seq` b
  297. happyDontSeq a b = b
  298. -----------------------------------------------------------------------------
  299. -- Don't inline any functions from the template. GHC has a nasty habit
  300. -- of deciding to inline happyGoto everywhere, which increases the size of
  301. -- the generated parser quite a bit.
  302. {-# LINE 317 "GenericTemplate.hs" #-}
  303. {-# NOINLINE happyShift #-}
  304. {-# NOINLINE happySpecReduce_0 #-}
  305. {-# NOINLINE happySpecReduce_1 #-}
  306. {-# NOINLINE happySpecReduce_2 #-}
  307. {-# NOINLINE happySpecReduce_3 #-}
  308. {-# NOINLINE happyReduce #-}
  309. {-# NOINLINE happyMonadReduce #-}
  310. {-# NOINLINE happyGoto #-}
  311. {-# NOINLINE happyFail #-}
  312. -- end of Happy Template.