happy-meta (empty) → 0.1.1
raw patch · 23 files changed
+6382/−0 lines, 23 filesdep +arraydep +basedep +containerssetup-changed
Dependencies added: array, base, containers, haskell-src-meta, mtl, template-haskell, th-lift
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- Text/Happy/Quote.hs +41/−0
- dist/build/AttrGrammarParser.hs +595/−0
- dist/build/Parser.hs +982/−0
- happy-meta.cabal +49/−0
- src/AbsSyn.lhs +137/−0
- src/AttrGrammar.lhs +107/−0
- src/AttrGrammarParser.ly +68/−0
- src/First.lhs +67/−0
- src/GenUtils.lhs +224/−0
- src/Grammar.lhs +594/−0
- src/LALR.lhs +662/−0
- src/Lexer.lhs +251/−0
- src/NameSet.hs +10/−0
- src/ParamRules.hs +92/−0
- src/ParseMonad.lhs +22/−0
- src/Parser.ly +146/−0
- src/ProduceCode.lhs +1211/−0
- src/ProduceGLRCode.lhs +703/−0
- src/Target.lhs +13/−0
- src/Text/Happy.hs +170/−0
- src/Text/Happy/HappyTemplate.hs +206/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2010, Jonas Duregard, Andy Gill, Simon Marlow + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * 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. + + * Neither the name of Jonas Duregard nor the names of other + 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ Text/Happy/Quote.hs view
@@ -0,0 +1,41 @@+module Text.Happy.Quote ( + parseHappy + , compileHappy + , happy + , HappyStk(..) + ) where + +import Text.Happy(runHappy) +import Text.Happy.HappyTemplate + +import Language.Haskell.TH.Quote +import Language.Haskell.TH +import Language.Haskell.TH.Lift + +import Language.Haskell.Meta + +-- Runtime +data HappyStk a = HappyStk a (HappyStk a) +infixr 9 `HappyStk` + + +type Happy = String + +compileHappy :: Happy -> Q [Dec] +compileHappy = return . either error id . parseDecs + +happy :: QuasiQuoter +happy = QuasiQuoter (lift . parseHappy) (error "happy: pattern quoting is not supported") + +parseHappy :: String -> Happy +parseHappy s = subst old "" $ fst (runHappy [] s) ++ "\n" ++ happyTemplate + where + old = unlines ["infixr 9 `HappyStk`", + "data HappyStk a = HappyStk a (HappyStk a)"] + +subst _ _ [ ] = [] +subst from to xs@(a:as) = + if isPrefixOf from xs + then to ++ drop (length from) xs + else a : subst from to as + where isPrefixOf as bs = and $ zipWith (==) as bs
+ dist/build/AttrGrammarParser.hs view
@@ -0,0 +1,595 @@+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} +{-# OPTIONS -fglasgow-exts -cpp #-} +{-# OPTIONS_GHC -w #-} +module AttrGrammarParser (agParser) where +import ParseMonad +import AttrGrammar +import qualified Data.Array as Happy_Data_Array +import qualified GHC.Exts as Happy_GHC_Exts + +-- parser produced by Happy Version 1.18.5 + +newtype HappyAbsSyn = HappyAbsSyn HappyAny +#if __GLASGOW_HASKELL__ >= 607 +type HappyAny = Happy_GHC_Exts.Any +#else +type HappyAny = forall a . a +#endif +happyIn4 :: ([AgRule]) -> (HappyAbsSyn ) +happyIn4 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn4 #-} +happyOut4 :: (HappyAbsSyn ) -> ([AgRule]) +happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut4 #-} +happyIn5 :: ([AgRule]) -> (HappyAbsSyn ) +happyIn5 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn5 #-} +happyOut5 :: (HappyAbsSyn ) -> ([AgRule]) +happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut5 #-} +happyIn6 :: (AgRule) -> (HappyAbsSyn ) +happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn6 #-} +happyOut6 :: (HappyAbsSyn ) -> (AgRule) +happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut6 #-} +happyIn7 :: ([AgToken]) -> (HappyAbsSyn ) +happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn7 #-} +happyOut7 :: (HappyAbsSyn ) -> ([AgToken]) +happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut7 #-} +happyIn8 :: ([AgToken]) -> (HappyAbsSyn ) +happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn8 #-} +happyOut8 :: (HappyAbsSyn ) -> ([AgToken]) +happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut8 #-} +happyInTok :: (AgToken) -> (HappyAbsSyn ) +happyInTok x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyInTok #-} +happyOutTok :: (HappyAbsSyn ) -> (AgToken) +happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOutTok #-} + + +happyActOffsets :: HappyAddr +happyActOffsets = HappyA# "\x0f\x00\x0f\x00\x00\x00\x30\x00\x0a\x00\x2e\x00\x2d\x00\x2b\x00\x14\x00\x0a\x00\x0a\x00\x0a\x00\x00\x00\x01\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x0a\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x00\x0a\x00\x00\x00\x01\x00\x00\x00\x00\x00"# + +happyGotoOffsets :: HappyAddr +happyGotoOffsets = HappyA# "\x18\x00\x1a\x00\x00\x00\x00\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x29\x00\x28\x00\x27\x00\x00\x00\x25\x00\x24\x00\x23\x00\x22\x00\x21\x00\x20\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1d\x00\x1c\x00\x1b\x00\x19\x00\x0c\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\xfd\xff\x00\x00\x00\x00"# + +happyDefActions :: HappyAddr +happyDefActions = HappyA# "\xfb\xff\x00\x00\xfe\xff\xfc\xff\xf0\xff\x00\x00\x00\x00\x00\x00\x00\x00\xf0\xff\xf0\xff\xf0\xff\xf7\xff\xe8\xff\xf0\xff\xf0\xff\xf0\xff\xf0\xff\xf0\xff\xfb\xff\xfd\xff\xf1\xff\xf2\xff\xf3\xff\xf4\xff\xf5\xff\x00\x00\xe8\xff\xe8\xff\xe8\xff\xe8\xff\xe8\xff\xf0\xff\xe8\xff\xfa\xff\xf9\xff\xf8\xff\xe9\xff\xea\xff\xeb\xff\xec\xff\xee\xff\xed\xff\x00\x00\xf0\xff\xf6\xff\xe8\xff\xef\xff"# + +happyCheck :: HappyAddr +happyCheck = HappyA# "\xff\xff\x04\x00\x01\x00\x04\x00\x03\x00\x04\x00\x03\x00\x06\x00\x07\x00\x08\x00\x09\x00\x01\x00\x01\x00\x02\x00\x04\x00\x03\x00\x06\x00\x07\x00\x08\x00\x09\x00\x05\x00\x06\x00\x07\x00\x08\x00\x00\x00\x01\x00\x02\x00\x01\x00\x02\x00\x04\x00\x0a\x00\x04\x00\x04\x00\x04\x00\x04\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x02\x00\x04\x00\x03\x00\x03\x00\x03\x00\x03\x00\x02\x00\x04\x00\xff\xff\x04\x00\x04\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +happyTable :: HappyAddr +happyTable = HappyA# "\x00\x00\x2f\x00\x1c\x00\x25\x00\x1d\x00\x1e\x00\x2d\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x0e\x00\x14\x00\x03\x00\x0f\x00\x26\x00\x10\x00\x11\x00\x12\x00\x13\x00\x05\x00\x06\x00\x07\x00\x08\x00\x08\x00\x02\x00\x03\x00\x02\x00\x03\x00\x27\x00\xff\xff\x28\x00\x29\x00\x2a\x00\x2b\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x2f\x00\x1a\x00\x22\x00\x23\x00\x24\x00\x0c\x00\x2d\x00\x0a\x00\x00\x00\x0b\x00\x0c\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyReduceArr = Happy_Data_Array.array (1, 23) [ + (1 , happyReduce_1), + (2 , happyReduce_2), + (3 , happyReduce_3), + (4 , happyReduce_4), + (5 , happyReduce_5), + (6 , happyReduce_6), + (7 , happyReduce_7), + (8 , happyReduce_8), + (9 , happyReduce_9), + (10 , happyReduce_10), + (11 , happyReduce_11), + (12 , happyReduce_12), + (13 , happyReduce_13), + (14 , happyReduce_14), + (15 , happyReduce_15), + (16 , happyReduce_16), + (17 , happyReduce_17), + (18 , happyReduce_18), + (19 , happyReduce_19), + (20 , happyReduce_20), + (21 , happyReduce_21), + (22 , happyReduce_22), + (23 , happyReduce_23) + ] + +happy_n_terms = 11 :: Int +happy_n_nonterms = 5 :: Int + +happyReduce_1 = happySpecReduce_1 0# happyReduction_1 +happyReduction_1 happy_x_1 + = case happyOut5 happy_x_1 of { happy_var_1 -> + happyIn4 + (happy_var_1 + )} + +happyReduce_2 = happySpecReduce_3 1# happyReduction_2 +happyReduction_2 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut6 happy_x_1 of { happy_var_1 -> + case happyOut5 happy_x_3 of { happy_var_3 -> + happyIn5 + (happy_var_1 : happy_var_3 + )}} + +happyReduce_3 = happySpecReduce_1 1# happyReduction_3 +happyReduction_3 happy_x_1 + = case happyOut6 happy_x_1 of { happy_var_1 -> + happyIn5 + (happy_var_1 : [] + )} + +happyReduce_4 = happySpecReduce_0 1# happyReduction_4 +happyReduction_4 = happyIn5 + ([] + ) + +happyReduce_5 = happySpecReduce_3 2# happyReduction_5 +happyReduction_5 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut7 happy_x_3 of { happy_var_3 -> + happyIn6 + (SelfAssign (selfRefVal happy_var_1) happy_var_3 + )}} + +happyReduce_6 = happySpecReduce_3 2# happyReduction_6 +happyReduction_6 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut7 happy_x_3 of { happy_var_3 -> + happyIn6 + (SubAssign (subRefVal happy_var_1) happy_var_3 + )}} + +happyReduce_7 = happySpecReduce_3 2# happyReduction_7 +happyReduction_7 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut7 happy_x_3 of { happy_var_3 -> + happyIn6 + (RightmostAssign (rightRefVal happy_var_1) happy_var_3 + )}} + +happyReduce_8 = happySpecReduce_2 2# happyReduction_8 +happyReduction_8 happy_x_2 + happy_x_1 + = case happyOut7 happy_x_2 of { happy_var_2 -> + happyIn6 + (Conditional happy_var_2 + )} + +happyReduce_9 = happyReduce 4# 3# happyReduction_9 +happyReduction_9 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut8 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut7 happy_x_4 of { happy_var_4 -> + happyIn7 + ([happy_var_1] ++ happy_var_2 ++ [happy_var_3] ++ happy_var_4 + ) `HappyStk` happyRest}}}} + +happyReduce_10 = happySpecReduce_2 3# happyReduction_10 +happyReduction_10 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut7 happy_x_2 of { happy_var_2 -> + happyIn7 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_11 = happySpecReduce_2 3# happyReduction_11 +happyReduction_11 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut7 happy_x_2 of { happy_var_2 -> + happyIn7 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_12 = happySpecReduce_2 3# happyReduction_12 +happyReduction_12 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut7 happy_x_2 of { happy_var_2 -> + happyIn7 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_13 = happySpecReduce_2 3# happyReduction_13 +happyReduction_13 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut7 happy_x_2 of { happy_var_2 -> + happyIn7 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_14 = happySpecReduce_2 3# happyReduction_14 +happyReduction_14 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut7 happy_x_2 of { happy_var_2 -> + happyIn7 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_15 = happySpecReduce_0 3# happyReduction_15 +happyReduction_15 = happyIn7 + ([] + ) + +happyReduce_16 = happyReduce 4# 4# happyReduction_16 +happyReduction_16 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut8 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut8 happy_x_4 of { happy_var_4 -> + happyIn8 + ([happy_var_1] ++ happy_var_2 ++ [happy_var_3] ++ happy_var_4 + ) `HappyStk` happyRest}}}} + +happyReduce_17 = happySpecReduce_2 4# happyReduction_17 +happyReduction_17 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut8 happy_x_2 of { happy_var_2 -> + happyIn8 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_18 = happySpecReduce_2 4# happyReduction_18 +happyReduction_18 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut8 happy_x_2 of { happy_var_2 -> + happyIn8 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_19 = happySpecReduce_2 4# happyReduction_19 +happyReduction_19 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut8 happy_x_2 of { happy_var_2 -> + happyIn8 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_20 = happySpecReduce_2 4# happyReduction_20 +happyReduction_20 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut8 happy_x_2 of { happy_var_2 -> + happyIn8 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_21 = happySpecReduce_2 4# happyReduction_21 +happyReduction_21 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut7 happy_x_2 of { happy_var_2 -> + happyIn8 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_22 = happySpecReduce_2 4# happyReduction_22 +happyReduction_22 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut8 happy_x_2 of { happy_var_2 -> + happyIn8 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_23 = happySpecReduce_0 4# happyReduction_23 +happyReduction_23 = happyIn8 + ([] + ) + +happyNewToken action sts stk + = agLexer(\tk -> + let cont i = happyDoAction i tk action sts stk in + case tk of { + AgTok_EOF -> happyDoAction 10# tk action sts stk; + AgTok_LBrace -> cont 1#; + AgTok_RBrace -> cont 2#; + AgTok_Semicolon -> cont 3#; + AgTok_Eq -> cont 4#; + AgTok_Where -> cont 5#; + AgTok_SelfRef _ -> cont 6#; + AgTok_SubRef _ -> cont 7#; + AgTok_RightmostRef _ -> cont 8#; + AgTok_Unknown _ -> cont 9#; + _ -> happyError' tk + }) + +happyError_ tk = happyError' tk + +happyThen :: () => P a -> (a -> P b) -> P b +happyThen = (>>=) +happyReturn :: () => a -> P a +happyReturn = (return) +happyThen1 = happyThen +happyReturn1 :: () => a -> P a +happyReturn1 = happyReturn +happyError' :: () => (AgToken) -> P a +happyError' tk = (\token -> happyError) tk + +agParser = happySomeParser where + happySomeParser = happyThen (happyParse 0#) (\x -> happyReturn (happyOut4 x)) + +happySeq = happyDontSeq + + +happyError :: P a +happyError = fail ("Parse error\n") +{-# LINE 1 "templates\GenericTemplate.hs" #-} +{-# LINE 1 "templates\\GenericTemplate.hs" #-} +{-# LINE 1 "<built-in>" #-} +{-# LINE 1 "<command line>" #-} +{-# LINE 1 "templates\\GenericTemplate.hs" #-} +-- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp + +{-# LINE 30 "templates\\GenericTemplate.hs" #-} + + +data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList + + + + + +{-# LINE 51 "templates\\GenericTemplate.hs" #-} + +{-# LINE 61 "templates\\GenericTemplate.hs" #-} + +{-# LINE 70 "templates\\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 0#, 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 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = + happyReturn1 ans +happyAccept j tk st sts (HappyStk ans _) = + (happyTcHack j (happyTcHack st)) (happyReturn1 ans) + +----------------------------------------------------------------------------- +-- Arrays only: do the next action + + + +happyDoAction i tk st + = {- nothing -} + + + case action of + 0# -> {- nothing -} + happyFail i tk st + -1# -> {- nothing -} + happyAccept i tk st + n | (n Happy_GHC_Exts.<# (0# :: Happy_GHC_Exts.Int#)) -> {- nothing -} + + (happyReduceArr Happy_Data_Array.! rule) i tk st + where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#)))))) + n -> {- nothing -} + + + happyShift new_state i tk st + where !(new_state) = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) + where !(off) = indexShortOffAddr happyActOffsets st + !(off_i) = (off Happy_GHC_Exts.+# i) + check = if (off_i Happy_GHC_Exts.>=# (0# :: Happy_GHC_Exts.Int#)) + then (indexShortOffAddr happyCheck off_i Happy_GHC_Exts.==# i) + else False + !(action) + | check = indexShortOffAddr happyTable off_i + | otherwise = indexShortOffAddr happyDefActions st + +{-# LINE 130 "templates\\GenericTemplate.hs" #-} + + +indexShortOffAddr (HappyA# arr) off = + Happy_GHC_Exts.narrow16Int# i + where + !i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) + !high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) + !low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) + !off' = off Happy_GHC_Exts.*# 2# + + + + + +data HappyAddr = HappyA# Happy_GHC_Exts.Addr# + + + + +----------------------------------------------------------------------------- +-- HappyState data type (not arrays) + +{-# LINE 163 "templates\\GenericTemplate.hs" #-} + +----------------------------------------------------------------------------- +-- Shifting a token + +happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = + let !(i) = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in +-- trace "shifting the error token" $ + happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) + +happyShift new_state i tk st sts stk = + happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) + +-- happyReduce is specialised for the common cases. + +happySpecReduce_0 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_0 nt fn j tk st@((action)) sts stk + = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) + +happySpecReduce_1 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') + = let r = fn v1 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_2 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') + = let r = fn v1 v2 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_3 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') + = let r = fn v1 v2 v3 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happyReduce k i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyReduce k nt fn j tk st sts stk + = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of + sts1@((HappyCons (st1@(action)) (_))) -> + let r = fn stk in -- it doesn't hurt to always seq here... + happyDoSeq r (happyGoto nt j tk st1 sts1 r) + +happyMonadReduce k nt fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyMonadReduce k nt fn j tk st sts stk = + happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) + where !(sts1@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts)) + drop_stk = happyDropStk k stk + +happyMonad2Reduce k nt fn 0# tk st sts stk + = happyFail 0# 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@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts)) + drop_stk = happyDropStk k stk + + !(off) = indexShortOffAddr happyGotoOffsets st1 + !(off_i) = (off Happy_GHC_Exts.+# nt) + !(new_state) = indexShortOffAddr happyTable off_i + + + + +happyDrop 0# l = l +happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t + +happyDropStk 0# l = l +happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs + +----------------------------------------------------------------------------- +-- Moving to a new state after a reduction + + +happyGoto nt j tk st = + {- nothing -} + happyDoAction j tk new_state + where !(off) = indexShortOffAddr happyGotoOffsets st + !(off_i) = (off Happy_GHC_Exts.+# nt) + !(new_state) = indexShortOffAddr happyTable off_i + + + + +----------------------------------------------------------------------------- +-- Error recovery (0# is the error token) + +-- parse error if we are in recovery and we fail again +happyFail 0# 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 0# tk old_st (HappyCons ((action)) (sts)) + (saved_tok `HappyStk` _ `HappyStk` stk) = +-- trace ("discarding state, depth " ++ show (length stk)) $ + happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) +-} + +-- Enter error recovery: generate an error token, +-- save the old token and carry on. +happyFail i tk (action) sts stk = +-- trace "entering error recovery" $ + happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk) + +-- Internal happy errors: + +notHappyAtAll = error "Internal Happy error\n" + +----------------------------------------------------------------------------- +-- Hack to get the typechecker to accept our action functions + + +happyTcHack :: Happy_GHC_Exts.Int# -> a -> a +happyTcHack x y = y +{-# INLINE happyTcHack #-} + + +----------------------------------------------------------------------------- +-- 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. + + +{-# NOINLINE happyDoAction #-} +{-# NOINLINE happyTable #-} +{-# NOINLINE happyCheck #-} +{-# NOINLINE happyActOffsets #-} +{-# NOINLINE happyGotoOffsets #-} +{-# NOINLINE happyDefActions #-} + +{-# 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.
+ dist/build/Parser.hs view
@@ -0,0 +1,982 @@+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} +{-# OPTIONS -fglasgow-exts -cpp #-} +{-# OPTIONS_GHC -w #-} +module Parser (ourParser,AbsSyn) where +import ParseMonad +import AbsSyn +import Lexer +import qualified Data.Array as Happy_Data_Array +import qualified GHC.Exts as Happy_GHC_Exts + +-- parser produced by Happy Version 1.18.5 + +newtype HappyAbsSyn = HappyAbsSyn HappyAny +#if __GLASGOW_HASKELL__ >= 607 +type HappyAny = Happy_GHC_Exts.Any +#else +type HappyAny = forall a . a +#endif +happyIn4 :: (AbsSyn) -> (HappyAbsSyn ) +happyIn4 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn4 #-} +happyOut4 :: (HappyAbsSyn ) -> (AbsSyn) +happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut4 #-} +happyIn5 :: ([Rule]) -> (HappyAbsSyn ) +happyIn5 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn5 #-} +happyOut5 :: (HappyAbsSyn ) -> ([Rule]) +happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut5 #-} +happyIn6 :: (Rule) -> (HappyAbsSyn ) +happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn6 #-} +happyOut6 :: (HappyAbsSyn ) -> (Rule) +happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut6 #-} +happyIn7 :: ([String]) -> (HappyAbsSyn ) +happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn7 #-} +happyOut7 :: (HappyAbsSyn ) -> ([String]) +happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut7 #-} +happyIn8 :: ([String]) -> (HappyAbsSyn ) +happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn8 #-} +happyOut8 :: (HappyAbsSyn ) -> ([String]) +happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut8 #-} +happyIn9 :: ([Prod]) -> (HappyAbsSyn ) +happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn9 #-} +happyOut9 :: (HappyAbsSyn ) -> ([Prod]) +happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut9 #-} +happyIn10 :: (Prod) -> (HappyAbsSyn ) +happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn10 #-} +happyOut10 :: (HappyAbsSyn ) -> (Prod) +happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut10 #-} +happyIn11 :: (Term) -> (HappyAbsSyn ) +happyIn11 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn11 #-} +happyOut11 :: (HappyAbsSyn ) -> (Term) +happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut11 #-} +happyIn12 :: ([Term]) -> (HappyAbsSyn ) +happyIn12 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn12 #-} +happyOut12 :: (HappyAbsSyn ) -> ([Term]) +happyOut12 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut12 #-} +happyIn13 :: ([Term]) -> (HappyAbsSyn ) +happyIn13 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn13 #-} +happyOut13 :: (HappyAbsSyn ) -> ([Term]) +happyOut13 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut13 #-} +happyIn14 :: ([Term]) -> (HappyAbsSyn ) +happyIn14 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn14 #-} +happyOut14 :: (HappyAbsSyn ) -> ([Term]) +happyOut14 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut14 #-} +happyIn15 :: (Maybe String) -> (HappyAbsSyn ) +happyIn15 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn15 #-} +happyOut15 :: (HappyAbsSyn ) -> (Maybe String) +happyOut15 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut15 #-} +happyIn16 :: ([Directive String]) -> (HappyAbsSyn ) +happyIn16 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn16 #-} +happyOut16 :: (HappyAbsSyn ) -> ([Directive String]) +happyOut16 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut16 #-} +happyIn17 :: (Directive String) -> (HappyAbsSyn ) +happyIn17 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn17 #-} +happyOut17 :: (HappyAbsSyn ) -> (Directive String) +happyOut17 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut17 #-} +happyIn18 :: (Maybe String) -> (HappyAbsSyn ) +happyIn18 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn18 #-} +happyOut18 :: (HappyAbsSyn ) -> (Maybe String) +happyOut18 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut18 #-} +happyIn19 :: ([(String,String)]) -> (HappyAbsSyn ) +happyIn19 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn19 #-} +happyOut19 :: (HappyAbsSyn ) -> ([(String,String)]) +happyOut19 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut19 #-} +happyIn20 :: ((String,String)) -> (HappyAbsSyn ) +happyIn20 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn20 #-} +happyOut20 :: (HappyAbsSyn ) -> ((String,String)) +happyOut20 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut20 #-} +happyIn21 :: ([String]) -> (HappyAbsSyn ) +happyIn21 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn21 #-} +happyOut21 :: (HappyAbsSyn ) -> ([String]) +happyOut21 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut21 #-} +happyIn22 :: (Maybe String) -> (HappyAbsSyn ) +happyIn22 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn22 #-} +happyOut22 :: (HappyAbsSyn ) -> (Maybe String) +happyOut22 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut22 #-} +happyInTok :: (Token) -> (HappyAbsSyn ) +happyInTok x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyInTok #-} +happyOutTok :: (HappyAbsSyn ) -> (Token) +happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOutTok #-} + + +happyActOffsets :: HappyAddr +happyActOffsets = HappyA# "\x70\x00\x70\x00\x22\x00\x00\x00\x67\x00\xff\xff\x00\x00\x6d\x00\x78\x00\x76\x00\x75\x00\x6c\x00\x00\x00\x6b\x00\x73\x00\x73\x00\x73\x00\x66\x00\x64\x00\x6f\x00\x62\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x00\x00\x60\x00\x5d\x00\x6a\x00\x6a\x00\x00\x00\x69\x00\x5c\x00\x00\x00\x00\x00\x68\x00\x10\x00\x00\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x56\x00\x01\x00\x65\x00\x00\x00\x00\x00\x34\x00\x00\x00\x63\x00\x51\x00\x00\x00\x0f\x00\x00\x00\x4e\x00\x00\x00\x55\x00\x5f\x00\x4b\x00\x00\x00\x5e\x00\x00\x00\x5a\x00\x00\x00\x4d\x00\x59\x00\x58\x00\x4a\x00\x57\x00\x00\x00\x57\x00\x00\x00\x00\x00\x48\x00\x00\x00\x31\x00\x00\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyGotoOffsets :: HappyAddr +happyGotoOffsets = HappyA# "\x0b\x00\x40\x00\x3c\x00\x00\x00\x00\x00\x47\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x00\x45\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x42\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x41\x00\x11\x00\x00\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x33\x00\x00\x00\x2e\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyDefActions :: HappyAddr +happyDefActions = HappyA# "\xcb\xff\x00\x00\x00\x00\xcc\xff\x00\x00\x00\x00\xe5\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xff\x00\x00\xcd\xff\xcd\xff\xcd\xff\x00\x00\x00\x00\x00\x00\x00\x00\xd5\xff\x00\x00\xd6\xff\xd7\xff\xd9\xff\xcd\xff\xd8\xff\xda\xff\xde\xff\x00\x00\xd2\xff\xd2\xff\xe3\xff\xd0\xff\x00\x00\xe4\xff\xe6\xff\x00\x00\xcb\xff\xfc\xff\xf7\xff\xcf\xff\xd1\xff\xe2\xff\xd3\xff\xe1\xff\xdf\xff\xdd\xff\xce\xff\xd4\xff\xdc\xff\x00\x00\x00\x00\xfd\xff\xfe\xff\x00\x00\xf6\xff\xed\xff\x00\x00\xdb\xff\x00\x00\xf9\xff\xf3\xff\xec\xff\xe7\xff\xee\xff\xf0\xff\xf8\xff\x00\x00\xf5\xff\x00\x00\xeb\xff\x00\x00\x00\x00\xed\xff\x00\x00\xed\xff\xfb\xff\xed\xff\xf4\xff\xe8\xff\xf1\xff\xea\xff\x00\x00\xef\xff\x00\x00\xf2\xff\xfa\xff\xe9\xff"# + +happyCheck :: HappyAddr +happyCheck = HappyA# "\xff\xff\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x00\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x01\x00\x01\x00\x0b\x00\x02\x00\x13\x00\x16\x00\x15\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x07\x00\x12\x00\x07\x00\x0a\x00\x07\x00\x11\x00\x13\x00\x12\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x04\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x01\x00\x02\x00\x0f\x00\x10\x00\x0f\x00\x10\x00\x0c\x00\x0d\x00\x19\x00\x1a\x00\x03\x00\x19\x00\x1a\x00\x11\x00\x0e\x00\x0e\x00\x12\x00\x01\x00\x0d\x00\x11\x00\x11\x00\x11\x00\x01\x00\x01\x00\x01\x00\x01\x00\x14\x00\x13\x00\x11\x00\x01\x00\x01\x00\x0c\x00\x11\x00\x18\x00\x01\x00\x17\x00\x01\x00\x11\x00\x18\x00\x01\x00\x01\x00\x01\x00\x11\x00\x11\x00\x11\x00\x01\x00\x01\x00\x11\x00\x11\x00\x11\x00\x01\x00\x11\x00\x01\x00\x01\x00\x12\x00\x01\x00\xff\xff\xff\xff\x11\x00\x11\x00\x11\x00\xff\xff\xff\xff\x11\x00\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +happyTable :: HappyAddr +happyTable = HappyA# "\x00\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x04\x00\x12\x00\x13\x00\x14\x00\x15\x00\x4d\x00\x2a\x00\x49\x00\x36\x00\x3b\x00\x27\x00\x3c\x00\x58\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x53\x00\x02\x00\x59\x00\x54\x00\x48\x00\x04\x00\x4e\x00\x37\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x38\x00\x12\x00\x13\x00\x14\x00\x15\x00\x4e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x50\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x27\x00\x28\x00\x2b\x00\x22\x00\x21\x00\x22\x00\x05\x00\x06\x00\x56\x00\x57\x00\x34\x00\x45\x00\x46\x00\x31\x00\x2c\x00\x2e\x00\x02\x00\x44\x00\x25\x00\x19\x00\x1b\x00\x1c\x00\x44\x00\x44\x00\x52\x00\x44\x00\x58\x00\x50\x00\x53\x00\x47\x00\x44\x00\x4b\x00\x3e\x00\x48\x00\x44\x00\x4c\x00\x3a\x00\x3d\x00\x36\x00\x2a\x00\x24\x00\x2e\x00\x34\x00\x2b\x00\x30\x00\x1b\x00\x17\x00\x31\x00\x33\x00\x16\x00\x1b\x00\x18\x00\x20\x00\x21\x00\x19\x00\x24\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x25\x00\x00\x00\x00\x00\x04\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyReduceArr = Happy_Data_Array.array (1, 52) [ + (1 , happyReduce_1), + (2 , happyReduce_2), + (3 , happyReduce_3), + (4 , happyReduce_4), + (5 , happyReduce_5), + (6 , happyReduce_6), + (7 , happyReduce_7), + (8 , happyReduce_8), + (9 , happyReduce_9), + (10 , happyReduce_10), + (11 , happyReduce_11), + (12 , happyReduce_12), + (13 , happyReduce_13), + (14 , happyReduce_14), + (15 , happyReduce_15), + (16 , happyReduce_16), + (17 , happyReduce_17), + (18 , happyReduce_18), + (19 , happyReduce_19), + (20 , happyReduce_20), + (21 , happyReduce_21), + (22 , happyReduce_22), + (23 , happyReduce_23), + (24 , happyReduce_24), + (25 , happyReduce_25), + (26 , happyReduce_26), + (27 , happyReduce_27), + (28 , happyReduce_28), + (29 , happyReduce_29), + (30 , happyReduce_30), + (31 , happyReduce_31), + (32 , happyReduce_32), + (33 , happyReduce_33), + (34 , happyReduce_34), + (35 , happyReduce_35), + (36 , happyReduce_36), + (37 , happyReduce_37), + (38 , happyReduce_38), + (39 , happyReduce_39), + (40 , happyReduce_40), + (41 , happyReduce_41), + (42 , happyReduce_42), + (43 , happyReduce_43), + (44 , happyReduce_44), + (45 , happyReduce_45), + (46 , happyReduce_46), + (47 , happyReduce_47), + (48 , happyReduce_48), + (49 , happyReduce_49), + (50 , happyReduce_50), + (51 , happyReduce_51), + (52 , happyReduce_52) + ] + +happy_n_terms = 28 :: Int +happy_n_nonterms = 19 :: Int + +happyReduce_1 = happyReduce 5# 0# happyReduction_1 +happyReduction_1 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut22 happy_x_1 of { happy_var_1 -> + case happyOut16 happy_x_2 of { happy_var_2 -> + case happyOut5 happy_x_4 of { happy_var_4 -> + case happyOut22 happy_x_5 of { happy_var_5 -> + happyIn4 + (AbsSyn happy_var_1 (reverse happy_var_2) (reverse happy_var_4) happy_var_5 + ) `HappyStk` happyRest}}}} + +happyReduce_2 = happySpecReduce_2 1# happyReduction_2 +happyReduction_2 happy_x_2 + happy_x_1 + = case happyOut5 happy_x_1 of { happy_var_1 -> + case happyOut6 happy_x_2 of { happy_var_2 -> + happyIn5 + (happy_var_2 : happy_var_1 + )}} + +happyReduce_3 = happySpecReduce_1 1# happyReduction_3 +happyReduction_3 happy_x_1 + = case happyOut6 happy_x_1 of { happy_var_1 -> + happyIn5 + ([happy_var_1] + )} + +happyReduce_4 = happyReduce 6# 2# happyReduction_4 +happyReduction_4 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokenInfo happy_var_1 TokId) -> + case happyOut7 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_4 of { (TokenInfo happy_var_4 TokCodeQuote) -> + case happyOut9 happy_x_6 of { happy_var_6 -> + happyIn6 + ((happy_var_1,happy_var_2,happy_var_6,Just happy_var_4) + ) `HappyStk` happyRest}}}} + +happyReduce_5 = happyReduce 7# 2# happyReduction_5 +happyReduction_5 (happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokenInfo happy_var_1 TokId) -> + case happyOut7 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_4 of { (TokenInfo happy_var_4 TokCodeQuote) -> + case happyOut9 happy_x_7 of { happy_var_7 -> + happyIn6 + ((happy_var_1,happy_var_2,happy_var_7,Just happy_var_4) + ) `HappyStk` happyRest}}}} + +happyReduce_6 = happyReduce 4# 2# happyReduction_6 +happyReduction_6 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokenInfo happy_var_1 TokId) -> + case happyOut7 happy_x_2 of { happy_var_2 -> + case happyOut9 happy_x_4 of { happy_var_4 -> + happyIn6 + ((happy_var_1,happy_var_2,happy_var_4,Nothing) + ) `HappyStk` happyRest}}} + +happyReduce_7 = happySpecReduce_3 3# happyReduction_7 +happyReduction_7 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut8 happy_x_2 of { happy_var_2 -> + happyIn7 + (reverse happy_var_2 + )} + +happyReduce_8 = happySpecReduce_0 3# happyReduction_8 +happyReduction_8 = happyIn7 + ([] + ) + +happyReduce_9 = happySpecReduce_1 4# happyReduction_9 +happyReduction_9 happy_x_1 + = case happyOutTok happy_x_1 of { (TokenInfo happy_var_1 TokId) -> + happyIn8 + ([happy_var_1] + )} + +happyReduce_10 = happySpecReduce_3 4# happyReduction_10 +happyReduction_10 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_3 of { (TokenInfo happy_var_3 TokId) -> + happyIn8 + (happy_var_3 : happy_var_1 + )}} + +happyReduce_11 = happySpecReduce_3 5# happyReduction_11 +happyReduction_11 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + case happyOut9 happy_x_3 of { happy_var_3 -> + happyIn9 + (happy_var_1 : happy_var_3 + )}} + +happyReduce_12 = happySpecReduce_1 5# happyReduction_12 +happyReduction_12 happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + happyIn9 + ([happy_var_1] + )} + +happyReduce_13 = happyMonadReduce 4# 6# happyReduction_13 +happyReduction_13 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut12 happy_x_1 of { happy_var_1 -> + case happyOut15 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { (TokenInfo happy_var_3 TokCodeQuote) -> + ( lineP >>= \l -> return (happy_var_1,happy_var_3,l,happy_var_2))}}} + ) (\r -> happyReturn (happyIn10 r)) + +happyReduce_14 = happyMonadReduce 3# 6# happyReduction_14 +happyReduction_14 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut12 happy_x_1 of { happy_var_1 -> + case happyOut15 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { (TokenInfo happy_var_3 TokCodeQuote) -> + ( lineP >>= \l -> return (happy_var_1,happy_var_3,l,happy_var_2))}}} + ) (\r -> happyReturn (happyIn10 r)) + +happyReduce_15 = happySpecReduce_1 7# happyReduction_15 +happyReduction_15 happy_x_1 + = case happyOutTok happy_x_1 of { (TokenInfo happy_var_1 TokId) -> + happyIn11 + (App happy_var_1 [] + )} + +happyReduce_16 = happyReduce 4# 7# happyReduction_16 +happyReduction_16 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokenInfo happy_var_1 TokId) -> + case happyOut14 happy_x_3 of { happy_var_3 -> + happyIn11 + (App happy_var_1 (reverse happy_var_3) + ) `HappyStk` happyRest}} + +happyReduce_17 = happySpecReduce_1 8# happyReduction_17 +happyReduction_17 happy_x_1 + = case happyOut13 happy_x_1 of { happy_var_1 -> + happyIn12 + (reverse happy_var_1 + )} + +happyReduce_18 = happySpecReduce_0 8# happyReduction_18 +happyReduction_18 = happyIn12 + ([] + ) + +happyReduce_19 = happySpecReduce_1 9# happyReduction_19 +happyReduction_19 happy_x_1 + = case happyOut11 happy_x_1 of { happy_var_1 -> + happyIn13 + ([happy_var_1] + )} + +happyReduce_20 = happySpecReduce_2 9# happyReduction_20 +happyReduction_20 happy_x_2 + happy_x_1 + = case happyOut13 happy_x_1 of { happy_var_1 -> + case happyOut11 happy_x_2 of { happy_var_2 -> + happyIn13 + (happy_var_2 : happy_var_1 + )}} + +happyReduce_21 = happySpecReduce_1 10# happyReduction_21 +happyReduction_21 happy_x_1 + = case happyOut11 happy_x_1 of { happy_var_1 -> + happyIn14 + ([happy_var_1] + )} + +happyReduce_22 = happySpecReduce_3 10# happyReduction_22 +happyReduction_22 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut14 happy_x_1 of { happy_var_1 -> + case happyOut11 happy_x_3 of { happy_var_3 -> + happyIn14 + (happy_var_3 : happy_var_1 + )}} + +happyReduce_23 = happySpecReduce_2 11# happyReduction_23 +happyReduction_23 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_2 of { (TokenInfo happy_var_2 TokId) -> + happyIn15 + (Just happy_var_2 + )} + +happyReduce_24 = happySpecReduce_0 11# happyReduction_24 +happyReduction_24 = happyIn15 + (Nothing + ) + +happyReduce_25 = happySpecReduce_2 12# happyReduction_25 +happyReduction_25 happy_x_2 + happy_x_1 + = case happyOut16 happy_x_1 of { happy_var_1 -> + case happyOut17 happy_x_2 of { happy_var_2 -> + happyIn16 + (happy_var_2 : happy_var_1 + )}} + +happyReduce_26 = happySpecReduce_1 12# happyReduction_26 +happyReduction_26 happy_x_1 + = case happyOut17 happy_x_1 of { happy_var_1 -> + happyIn16 + ([happy_var_1] + )} + +happyReduce_27 = happySpecReduce_2 13# happyReduction_27 +happyReduction_27 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_2 of { (TokenInfo happy_var_2 TokCodeQuote) -> + happyIn17 + (TokenType happy_var_2 + )} + +happyReduce_28 = happySpecReduce_2 13# happyReduction_28 +happyReduction_28 happy_x_2 + happy_x_1 + = case happyOut19 happy_x_2 of { happy_var_2 -> + happyIn17 + (TokenSpec happy_var_2 + )} + +happyReduce_29 = happySpecReduce_3 13# happyReduction_29 +happyReduction_29 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_2 of { (TokenInfo happy_var_2 TokId) -> + case happyOut18 happy_x_3 of { happy_var_3 -> + happyIn17 + (TokenName happy_var_2 happy_var_3 False + )}} + +happyReduce_30 = happySpecReduce_3 13# happyReduction_30 +happyReduction_30 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_2 of { (TokenInfo happy_var_2 TokId) -> + case happyOut18 happy_x_3 of { happy_var_3 -> + happyIn17 + (TokenName happy_var_2 happy_var_3 True + )}} + +happyReduce_31 = happySpecReduce_1 13# happyReduction_31 +happyReduction_31 happy_x_1 + = happyIn17 + (TokenImportedIdentity + ) + +happyReduce_32 = happySpecReduce_3 13# happyReduction_32 +happyReduction_32 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_2 of { (TokenInfo happy_var_2 TokCodeQuote) -> + case happyOutTok happy_x_3 of { (TokenInfo happy_var_3 TokCodeQuote) -> + happyIn17 + (TokenLexer happy_var_2 happy_var_3 + )}} + +happyReduce_33 = happySpecReduce_2 13# happyReduction_33 +happyReduction_33 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_2 of { (TokenInfo happy_var_2 TokCodeQuote) -> + happyIn17 + (TokenMonad "()" happy_var_2 ">>=" "return" + )} + +happyReduce_34 = happySpecReduce_3 13# happyReduction_34 +happyReduction_34 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_2 of { (TokenInfo happy_var_2 TokCodeQuote) -> + case happyOutTok happy_x_3 of { (TokenInfo happy_var_3 TokCodeQuote) -> + happyIn17 + (TokenMonad happy_var_2 happy_var_3 ">>=" "return" + )}} + +happyReduce_35 = happyReduce 4# 13# happyReduction_35 +happyReduction_35 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_2 of { (TokenInfo happy_var_2 TokCodeQuote) -> + case happyOutTok happy_x_3 of { (TokenInfo happy_var_3 TokCodeQuote) -> + case happyOutTok happy_x_4 of { (TokenInfo happy_var_4 TokCodeQuote) -> + happyIn17 + (TokenMonad "()" happy_var_2 happy_var_3 happy_var_4 + ) `HappyStk` happyRest}}} + +happyReduce_36 = happyReduce 5# 13# happyReduction_36 +happyReduction_36 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_2 of { (TokenInfo happy_var_2 TokCodeQuote) -> + case happyOutTok happy_x_3 of { (TokenInfo happy_var_3 TokCodeQuote) -> + case happyOutTok happy_x_4 of { (TokenInfo happy_var_4 TokCodeQuote) -> + case happyOutTok happy_x_5 of { (TokenInfo happy_var_5 TokCodeQuote) -> + happyIn17 + (TokenMonad happy_var_2 happy_var_3 happy_var_4 happy_var_5 + ) `HappyStk` happyRest}}}} + +happyReduce_37 = happySpecReduce_2 13# happyReduction_37 +happyReduction_37 happy_x_2 + happy_x_1 + = case happyOut21 happy_x_2 of { happy_var_2 -> + happyIn17 + (TokenNonassoc happy_var_2 + )} + +happyReduce_38 = happySpecReduce_2 13# happyReduction_38 +happyReduction_38 happy_x_2 + happy_x_1 + = case happyOut21 happy_x_2 of { happy_var_2 -> + happyIn17 + (TokenRight happy_var_2 + )} + +happyReduce_39 = happySpecReduce_2 13# happyReduction_39 +happyReduction_39 happy_x_2 + happy_x_1 + = case happyOut21 happy_x_2 of { happy_var_2 -> + happyIn17 + (TokenLeft happy_var_2 + )} + +happyReduce_40 = happySpecReduce_2 13# happyReduction_40 +happyReduction_40 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_2 of { (TokenNum happy_var_2 TokNum) -> + happyIn17 + (TokenExpect happy_var_2 + )} + +happyReduce_41 = happySpecReduce_2 13# happyReduction_41 +happyReduction_41 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_2 of { (TokenInfo happy_var_2 TokCodeQuote) -> + happyIn17 + (TokenError happy_var_2 + )} + +happyReduce_42 = happySpecReduce_2 13# happyReduction_42 +happyReduction_42 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_2 of { (TokenInfo happy_var_2 TokCodeQuote) -> + happyIn17 + (TokenAttributetype happy_var_2 + )} + +happyReduce_43 = happySpecReduce_3 13# happyReduction_43 +happyReduction_43 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_2 of { (TokenInfo happy_var_2 TokId) -> + case happyOutTok happy_x_3 of { (TokenInfo happy_var_3 TokCodeQuote) -> + happyIn17 + (TokenAttribute happy_var_2 happy_var_3 + )}} + +happyReduce_44 = happySpecReduce_1 14# happyReduction_44 +happyReduction_44 happy_x_1 + = case happyOutTok happy_x_1 of { (TokenInfo happy_var_1 TokId) -> + happyIn18 + (Just happy_var_1 + )} + +happyReduce_45 = happySpecReduce_0 14# happyReduction_45 +happyReduction_45 = happyIn18 + (Nothing + ) + +happyReduce_46 = happySpecReduce_2 15# happyReduction_46 +happyReduction_46 happy_x_2 + happy_x_1 + = case happyOut20 happy_x_1 of { happy_var_1 -> + case happyOut19 happy_x_2 of { happy_var_2 -> + happyIn19 + (happy_var_1:happy_var_2 + )}} + +happyReduce_47 = happySpecReduce_1 15# happyReduction_47 +happyReduction_47 happy_x_1 + = case happyOut20 happy_x_1 of { happy_var_1 -> + happyIn19 + ([happy_var_1] + )} + +happyReduce_48 = happySpecReduce_2 16# happyReduction_48 +happyReduction_48 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TokenInfo happy_var_1 TokId) -> + case happyOutTok happy_x_2 of { (TokenInfo happy_var_2 TokCodeQuote) -> + happyIn20 + ((happy_var_1,happy_var_2) + )}} + +happyReduce_49 = happySpecReduce_2 17# happyReduction_49 +happyReduction_49 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TokenInfo happy_var_1 TokId) -> + case happyOut21 happy_x_2 of { happy_var_2 -> + happyIn21 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_50 = happySpecReduce_0 17# happyReduction_50 +happyReduction_50 = happyIn21 + ([] + ) + +happyReduce_51 = happySpecReduce_1 18# happyReduction_51 +happyReduction_51 happy_x_1 + = case happyOutTok happy_x_1 of { (TokenInfo happy_var_1 TokCodeQuote) -> + happyIn22 + (Just happy_var_1 + )} + +happyReduce_52 = happySpecReduce_0 18# happyReduction_52 +happyReduction_52 = happyIn22 + (Nothing + ) + +happyNewToken action sts stk + = lexer(\tk -> + let cont i = happyDoAction i tk action sts stk in + case tk of { + TokenEOF -> happyDoAction 27# tk action sts stk; + TokenInfo happy_dollar_dollar TokId -> cont 1#; + TokenKW TokSpecId_TokenType -> cont 2#; + TokenKW TokSpecId_Token -> cont 3#; + TokenKW TokSpecId_Name -> cont 4#; + TokenKW TokSpecId_Partial -> cont 5#; + TokenKW TokSpecId_Lexer -> cont 6#; + TokenKW TokSpecId_ImportedIdentity -> cont 7#; + TokenKW TokSpecId_Monad -> cont 8#; + TokenKW TokSpecId_Nonassoc -> cont 9#; + TokenKW TokSpecId_Left -> cont 10#; + TokenKW TokSpecId_Right -> cont 11#; + TokenKW TokSpecId_Prec -> cont 12#; + TokenKW TokSpecId_Expect -> cont 13#; + TokenKW TokSpecId_Error -> cont 14#; + TokenKW TokSpecId_Attribute -> cont 15#; + TokenKW TokSpecId_Attributetype -> cont 16#; + TokenInfo happy_dollar_dollar TokCodeQuote -> cont 17#; + TokenNum happy_dollar_dollar TokNum -> cont 18#; + TokenKW TokColon -> cont 19#; + TokenKW TokSemiColon -> cont 20#; + TokenKW TokDoubleColon -> cont 21#; + TokenKW TokDoublePercent -> cont 22#; + TokenKW TokBar -> cont 23#; + TokenKW TokParenL -> cont 24#; + TokenKW TokParenR -> cont 25#; + TokenKW TokComma -> cont 26#; + _ -> happyError' tk + }) + +happyError_ tk = happyError' tk + +happyThen :: () => P a -> (a -> P b) -> P b +happyThen = (>>=) +happyReturn :: () => a -> P a +happyReturn = (return) +happyThen1 = happyThen +happyReturn1 :: () => a -> P a +happyReturn1 = happyReturn +happyError' :: () => (Token) -> P a +happyError' tk = (\token -> happyError) tk + +ourParser = happySomeParser where + happySomeParser = happyThen (happyParse 0#) (\x -> happyReturn (happyOut4 x)) + +happySeq = happyDontSeq + + +happyError :: P a +happyError = lineP >>= \l -> fail (show l ++ ": Parse error\n") +{-# LINE 1 "templates\GenericTemplate.hs" #-} +{-# LINE 1 "templates\\GenericTemplate.hs" #-} +{-# LINE 1 "<built-in>" #-} +{-# LINE 1 "<command line>" #-} +{-# LINE 1 "templates\\GenericTemplate.hs" #-} +-- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp + +{-# LINE 30 "templates\\GenericTemplate.hs" #-} + + +data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList + + + + + +{-# LINE 51 "templates\\GenericTemplate.hs" #-} + +{-# LINE 61 "templates\\GenericTemplate.hs" #-} + +{-# LINE 70 "templates\\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 0#, 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 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = + happyReturn1 ans +happyAccept j tk st sts (HappyStk ans _) = + (happyTcHack j (happyTcHack st)) (happyReturn1 ans) + +----------------------------------------------------------------------------- +-- Arrays only: do the next action + + + +happyDoAction i tk st + = {- nothing -} + + + case action of + 0# -> {- nothing -} + happyFail i tk st + -1# -> {- nothing -} + happyAccept i tk st + n | (n Happy_GHC_Exts.<# (0# :: Happy_GHC_Exts.Int#)) -> {- nothing -} + + (happyReduceArr Happy_Data_Array.! rule) i tk st + where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#)))))) + n -> {- nothing -} + + + happyShift new_state i tk st + where !(new_state) = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) + where !(off) = indexShortOffAddr happyActOffsets st + !(off_i) = (off Happy_GHC_Exts.+# i) + check = if (off_i Happy_GHC_Exts.>=# (0# :: Happy_GHC_Exts.Int#)) + then (indexShortOffAddr happyCheck off_i Happy_GHC_Exts.==# i) + else False + !(action) + | check = indexShortOffAddr happyTable off_i + | otherwise = indexShortOffAddr happyDefActions st + +{-# LINE 130 "templates\\GenericTemplate.hs" #-} + + +indexShortOffAddr (HappyA# arr) off = + Happy_GHC_Exts.narrow16Int# i + where + !i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) + !high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) + !low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) + !off' = off Happy_GHC_Exts.*# 2# + + + + + +data HappyAddr = HappyA# Happy_GHC_Exts.Addr# + + + + +----------------------------------------------------------------------------- +-- HappyState data type (not arrays) + +{-# LINE 163 "templates\\GenericTemplate.hs" #-} + +----------------------------------------------------------------------------- +-- Shifting a token + +happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = + let !(i) = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in +-- trace "shifting the error token" $ + happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) + +happyShift new_state i tk st sts stk = + happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) + +-- happyReduce is specialised for the common cases. + +happySpecReduce_0 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_0 nt fn j tk st@((action)) sts stk + = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) + +happySpecReduce_1 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') + = let r = fn v1 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_2 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') + = let r = fn v1 v2 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_3 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') + = let r = fn v1 v2 v3 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happyReduce k i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyReduce k nt fn j tk st sts stk + = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of + sts1@((HappyCons (st1@(action)) (_))) -> + let r = fn stk in -- it doesn't hurt to always seq here... + happyDoSeq r (happyGoto nt j tk st1 sts1 r) + +happyMonadReduce k nt fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyMonadReduce k nt fn j tk st sts stk = + happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) + where !(sts1@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts)) + drop_stk = happyDropStk k stk + +happyMonad2Reduce k nt fn 0# tk st sts stk + = happyFail 0# 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@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts)) + drop_stk = happyDropStk k stk + + !(off) = indexShortOffAddr happyGotoOffsets st1 + !(off_i) = (off Happy_GHC_Exts.+# nt) + !(new_state) = indexShortOffAddr happyTable off_i + + + + +happyDrop 0# l = l +happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t + +happyDropStk 0# l = l +happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs + +----------------------------------------------------------------------------- +-- Moving to a new state after a reduction + + +happyGoto nt j tk st = + {- nothing -} + happyDoAction j tk new_state + where !(off) = indexShortOffAddr happyGotoOffsets st + !(off_i) = (off Happy_GHC_Exts.+# nt) + !(new_state) = indexShortOffAddr happyTable off_i + + + + +----------------------------------------------------------------------------- +-- Error recovery (0# is the error token) + +-- parse error if we are in recovery and we fail again +happyFail 0# 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 0# tk old_st (HappyCons ((action)) (sts)) + (saved_tok `HappyStk` _ `HappyStk` stk) = +-- trace ("discarding state, depth " ++ show (length stk)) $ + happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) +-} + +-- Enter error recovery: generate an error token, +-- save the old token and carry on. +happyFail i tk (action) sts stk = +-- trace "entering error recovery" $ + happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk) + +-- Internal happy errors: + +notHappyAtAll = error "Internal Happy error\n" + +----------------------------------------------------------------------------- +-- Hack to get the typechecker to accept our action functions + + +happyTcHack :: Happy_GHC_Exts.Int# -> a -> a +happyTcHack x y = y +{-# INLINE happyTcHack #-} + + +----------------------------------------------------------------------------- +-- 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. + + +{-# NOINLINE happyDoAction #-} +{-# NOINLINE happyTable #-} +{-# NOINLINE happyCheck #-} +{-# NOINLINE happyActOffsets #-} +{-# NOINLINE happyGotoOffsets #-} +{-# NOINLINE happyDefActions #-} + +{-# 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.
+ happy-meta.cabal view
@@ -0,0 +1,49 @@+Name: happy-meta +Version: 0.1.1 +Synopsis: Quasi-quoter for Happy parsers +-- Description: +License: BSD3 +License-file: LICENSE +Author: Jonas Duregard +Maintainer: jonas.duregard@gmail.com +Category: Development +Build-type: Simple + +Cabal-version: >=1.2.3 + + +Library + hs-source-dirs: src . + extensions: CPP, MagicHash + + Exposed-modules: + Text.Happy.Quote + + Build-depends: + template-haskell >=2.4&&<2.5 + , th-lift >=0.5&&<0.6 + , haskell-src-meta >=0.1.1&&<0.2 + , base >= 4.2 && < 5 + , array, containers + , mtl >= 1.0 + + + Other-modules: + Text.Happy + Text.Happy.HappyTemplate + AbsSyn + First + GenUtils + Grammar + LALR + Lexer + ParseMonad + Parser + ProduceCode + ProduceGLRCode + NameSet + Target + AttrGrammar + AttrGrammarParser + ParamRules +
+ src/AbsSyn.lhs view
@@ -0,0 +1,137 @@+-----------------------------------------------------------------------------+Abstract syntax for grammar files.++(c) 1993-2001 Andy Gill, Simon Marlow+-----------------------------------------------------------------------------++Here is the abstract syntax of the language we parse.++> module AbsSyn (+> AbsSyn(..), Directive(..),+> getTokenType, getTokenSpec, getParserNames, getLexer,+> getImportedIdentity, getMonad, getError,+> getPrios, getPrioNames, getExpect,+> getAttributes, getAttributetype,+> Rule,Prod,Term(..)+> ) where++> data AbsSyn+> = AbsSyn+> (Maybe String) -- header+> [Directive String] -- directives+> [Rule] -- productions+> (Maybe String) -- footer++> type Rule = (String,[String],[Prod],Maybe String)+> type Prod = ([Term],String,Int,Maybe String)+> data Term = App String [Term]++++#ifdef DEBUG++> deriving Show++#endif++%-----------------------------------------------------------------------------+Parser Generator Directives.++ToDo: find a consistent way to analyse all the directives together and+generate some error messages.++> data Directive a+> = TokenType String -- %tokentype+> | TokenSpec [(a,String)] -- %token+> | TokenName String (Maybe String) Bool -- %name/%partial (True <=> %partial)+> | TokenLexer String String -- %lexer+> | TokenImportedIdentity -- %importedidentity+> | TokenMonad String String String String -- %monad+> | TokenNonassoc [String] -- %nonassoc+> | TokenRight [String] -- %right+> | TokenLeft [String] -- %left+> | TokenExpect Int -- %expect+> | TokenError String -- %error+> | TokenAttributetype String -- %attributetype+> | TokenAttribute String String -- %attribute+ ++#ifdef DEBUG++> deriving Show++#endif++> getTokenType :: [Directive t] -> String+> getTokenType ds +> = case [ t | (TokenType t) <- ds ] of +> [t] -> t+> [] -> error "no token type given"+> _ -> error "multiple token types"++> getParserNames :: [Directive t] -> [Directive t]+> getParserNames ds = [ t | t@(TokenName _ _ _) <- ds ]++> getLexer :: [Directive t] -> Maybe (String, String)+> getLexer ds +> = case [ (a,b) | (TokenLexer a b) <- ds ] of+> [t] -> Just t+> [] -> Nothing+> _ -> error "multiple lexer directives"++> getImportedIdentity :: [Directive t] -> Bool+> getImportedIdentity ds +> = case [ (()) | TokenImportedIdentity <- ds ] of+> [_] -> True+> [] -> False+> _ -> error "multiple importedidentity directives"++> getMonad :: [Directive t] -> (Bool, String, String, String, String)+> getMonad ds +> = case [ (True,a,b,c,d) | (TokenMonad a b c d) <- ds ] of+> [t] -> t+> [] -> (False,"()","HappyIdentity",">>=","return")+> _ -> error "multiple monad directives"++> getTokenSpec :: [Directive t] -> [(t, String)]+> getTokenSpec ds = concat [ t | (TokenSpec t) <- ds ]++> getPrios :: [Directive t] -> [Directive t]+> getPrios ds = [ d | d <- ds,+> case d of+> TokenNonassoc _ -> True+> TokenLeft _ -> True+> TokenRight _ -> True+> _ -> False+> ]++> getPrioNames :: Directive t -> [String]+> getPrioNames (TokenNonassoc s) = s+> getPrioNames (TokenLeft s) = s+> getPrioNames (TokenRight s) = s+> getPrioNames _ = error "Not an associativity token"++> getExpect :: [Directive t] -> Maybe Int+> getExpect ds+> = case [ n | (TokenExpect n) <- ds ] of+> [t] -> Just t+> [] -> Nothing+> _ -> error "multiple expect directives"++> getError :: [Directive t] -> Maybe String+> getError ds +> = case [ a | (TokenError a) <- ds ] of+> [t] -> Just t+> [] -> Nothing+> _ -> error "multiple error directives"++> getAttributes :: [Directive t] -> [(String, String)]+> getAttributes ds+> = [ (ident,typ) | (TokenAttribute ident typ) <- ds ]++> getAttributetype :: [Directive t] -> Maybe String+> getAttributetype ds+> = case [ t | (TokenAttributetype t) <- ds ] of+> [t] -> Just t+> [] -> Nothing+> _ -> error "multiple attributetype directives"
+ src/AttrGrammar.lhs view
@@ -0,0 +1,107 @@+> module AttrGrammar +> ( AgToken (..)+> , AgRule (..)+> , agLexAll+> , agLexer+> , subRefVal+> , selfRefVal+> , rightRefVal+> ) where++> import Data.Char+> import ParseMonad++> data AgToken +> = AgTok_LBrace+> | AgTok_RBrace+> | AgTok_Where+> | AgTok_Semicolon+> | AgTok_Eq+> | AgTok_SelfRef String+> | AgTok_SubRef (Int, String)+> | AgTok_RightmostRef String+> | AgTok_Unknown String+> | AgTok_EOF+> deriving (Show,Eq,Ord)++> subRefVal :: AgToken -> (Int, String)+> subRefVal (AgTok_SubRef x) = x+> subRefVal _ = error "subRefVal: Bad value"+> selfRefVal :: AgToken -> String+> selfRefVal (AgTok_SelfRef x) = x+> selfRefVal _ = error "selfRefVal: Bad value"+> rightRefVal :: AgToken -> String+> rightRefVal (AgTok_RightmostRef x) = x+> rightRefVal _ = error "rightRefVal: Bad value"++> data AgRule+> = SelfAssign String [AgToken]+> | SubAssign (Int,String) [AgToken]+> | RightmostAssign String [AgToken]+> | Conditional [AgToken]+> deriving (Show,Eq,Ord)++-----------------------------------------------------------------+-- For the most part, the body of the attribute grammar rules+-- is uninterpreted haskell expressions. We only need to know about+-- a) braces and semicolons to break the rules apart+-- b) the equals sign to break the rules into LValues and the RHS+-- c) attribute references, which are $$, $x (postivie integer x)+-- or $> (for the rightmost symbol) followed by an optional+-- attribute specifier, which is a dot followed by a+-- Haskell variable identifier+-- Examples:+-- $$+-- $1+-- $>+-- $$.pos+-- $3.value+-- $2.someAttribute0'+--+-- Everything else can be treated as uninterpreted strings. Our munging+-- will wreck column alignment so attribute grammar specifications must+-- not rely on layout.++> type Pfunc a = String -> Int -> ParseResult a++> agLexAll :: P [AgToken]+> agLexAll = P $ aux []+> where aux toks [] _ = OkP (reverse toks)+> aux toks s l = agLexer' (\t -> aux (t:toks)) s l++> agLexer :: (AgToken -> P a) -> P a+> agLexer m = P $ agLexer' (\x -> runP (m x))++> agLexer' :: (AgToken -> Pfunc a) -> Pfunc a+> agLexer' cont [] = cont AgTok_EOF []+> agLexer' cont ('{':rest) = cont AgTok_LBrace rest+> agLexer' cont ('}':rest) = cont AgTok_RBrace rest+> agLexer' cont (';':rest) = cont AgTok_Semicolon rest+> agLexer' cont ('=':rest) = cont AgTok_Eq rest+> agLexer' cont ('w':'h':'e':'r':'e':rest) = cont AgTok_Where rest+> agLexer' cont ('$':'$':rest) = agLexAttribute cont (\a -> AgTok_SelfRef a) rest+> agLexer' cont ('$':'>':rest) = agLexAttribute cont (\a -> AgTok_RightmostRef a) rest+> agLexer' cont s@('$':rest) =+> let (n,rest') = span isDigit rest+> in if null n +> then agLexUnknown cont s+> else agLexAttribute cont (\a -> AgTok_SubRef (read n,a)) rest'+> agLexer' cont s@(c:rest)+> | isSpace c = agLexer' cont (dropWhile isSpace rest)+> | otherwise = agLexUnknown cont s++> agLexUnknown :: (AgToken -> Pfunc a) -> Pfunc a+> agLexUnknown cont s = let (u,rest) = aux [] s in cont (AgTok_Unknown u) rest+> where aux t [] = (reverse t,[])+> aux t ('$':c:cs)+> | c /= '$' && not (isDigit c) = aux ('$':t) (c:cs)+> | otherwise = (reverse t,'$':c:cs)+> aux t (c:cs)+> | isSpace c || c `elem` "{};=" = (reverse t,c:cs)+> | otherwise = aux (c:t) cs++> agLexAttribute :: (AgToken -> Pfunc a) -> (String -> AgToken) -> Pfunc a+> agLexAttribute cont k ('.':x:xs) +> | isLower x = let (ident,rest) = span (\c -> isAlphaNum c || c == '\'') xs in cont (k (x:ident)) rest+> | otherwise = \_ -> FailP "bad attribute identifier"+> agLexAttribute cont k rest = cont (k "") rest
+ src/AttrGrammarParser.ly view
@@ -0,0 +1,68 @@+This parser parses the contents of the attribute grammar+into a list of rules. A rule can either be an assignment+to an attribute of the LHS (synthesized attribute), and +assignment to an attribute of the RHS (an inherited attribute),+or a conditional statement.++> {+> {-# OPTIONS_GHC -w #-}+> module AttrGrammarParser (agParser) where+> import ParseMonad+> import AttrGrammar+> }++> %name agParser+> %tokentype { AgToken }+> %token+> "{" { AgTok_LBrace }+> "}" { AgTok_RBrace }+> ";" { AgTok_Semicolon }+> "=" { AgTok_Eq }+> where { AgTok_Where }+> selfRef { AgTok_SelfRef _ }+> subRef { AgTok_SubRef _ }+> rightRef { AgTok_RightmostRef _ }+> unknown { AgTok_Unknown _ }+>+> %monad { P }+> %lexer { agLexer } { AgTok_EOF }++> %%++> agParser :: { [AgRule] }+> : rules { $1 }++> rules :: { [AgRule] }+> : rule ";" rules { $1 : $3 }+> | rule { $1 : [] }+> | { [] }++> rule :: { AgRule }+> : selfRef "=" code { SelfAssign (selfRefVal $1) $3 }+> | subRef "=" code { SubAssign (subRefVal $1) $3 }+> | rightRef "=" code { RightmostAssign (rightRefVal $1) $3 }+> | where code { Conditional $2 }++> code :: { [AgToken] }+> : "{" code0 "}" code { [$1] ++ $2 ++ [$3] ++ $4 }+> | "=" code { $1 : $2 }+> | selfRef code { $1 : $2 }+> | subRef code { $1 : $2 }+> | rightRef code { $1 : $2 }+> | unknown code { $1 : $2 }+> | { [] }++> code0 :: { [AgToken] }+> : "{" code0 "}" code0 { [$1] ++ $2 ++ [$3] ++ $4 }+> | "=" code0 { $1 : $2 }+> | ";" code0 { $1 : $2 }+> | selfRef code0 { $1 : $2 }+> | subRef code0 { $1 : $2 }+> | rightRef code { $1 : $2 }+> | unknown code0 { $1 : $2 }+> | { [] }++> {+> happyError :: P a+> happyError = fail ("Parse error\n")+> }
+ src/First.lhs view
@@ -0,0 +1,67 @@+-----------------------------------------------------------------------------+Implementation of FIRST++(c) 1993-2001 Andy Gill, Simon Marlow+-----------------------------------------------------------------------------++> module First ( mkFirst ) where++> import GenUtils+> import NameSet ( NameSet )+> import qualified NameSet as Set+> import Grammar+> import Data.IntSet (IntSet)++\subsection{Utilities}++> joinSymSets :: (a -> NameSet) -> [a] -> NameSet+> joinSymSets f = foldr +> (\ h b -> let+> h' = f h+> in+> if incEmpty h'+> then Set.filter (not. isEmpty) h' `Set.union` b+> else h')+> (Set.singleton epsilonTok)++Does the Set include the $\epsilon$ symbol ?++> incEmpty :: NameSet -> Bool+> incEmpty set = any isEmpty (Set.toAscList set)++\subsection{Implementation of FIRST}++> mkFirst :: Grammar -> [Name] -> NameSet+> mkFirst (Grammar { first_term = fst_term+> , lookupProdNo = prodNo+> , lookupProdsOfName = prodsOfName+> , non_terminals = nts+> })+> = joinSymSets (\ h -> case lookup h env of+> Nothing -> Set.singleton h+> Just ix -> ix)+> where+> env = mkClosure (==) (getNext fst_term prodNo prodsOfName)+> [ (name,Set.empty) | name <- nts ]++> getNext :: Name -> (a -> (b, [Name], c, d)) -> (Name -> [a])+> -> [(Name, IntSet)] -> [(Name, NameSet)]+> getNext fst_term prodNo prodsOfName env = +> [ (nm, next nm) | (nm,_) <- env ]+> where +> fn t | t == errorTok || t >= fst_term = Set.singleton t+> fn x = case lookup x env of+> Just t -> t+> Nothing -> error "attempted FIRST(e) :-("++> next :: Name -> NameSet+> next t | t >= fst_term = Set.singleton t+> next n = +> foldb Set.union +> [ joinSymSets fn (snd4 (prodNo rl)) | +> rl <- prodsOfName n ]++My little hack++> snd4 :: (a, b, c, d) -> b+> snd4 (_,b,_,_) = b
+ src/GenUtils.lhs view
@@ -0,0 +1,224 @@+-----------------------------------------------------------------------------+Some General Utilities, including sorts, etc.+This is realy just an extended prelude.+All the code below is understood to be in the public domain.+-----------------------------------------------------------------------------++> module GenUtils (++> partition', tack, +> assocMaybeErr,+> arrElem,+> memoise,+> returnMaybe,handleMaybe, findJust,+> MaybeErr(..),+> mapMaybe,+> maybeMap,+> joinMaybe,+> mkClosure,+> foldb,+> listArray',+> cjustify,+> ljustify,+> rjustify,+> space,+> copy,+> combinePairs,+> --trace, -- re-export it +> fst3,+> snd3,+> thd3,+> mapDollarDollar,+> str, char, nl, brack, brack',+> interleave, interleave',+> strspace, maybestr+> ) where++> import Data.Char (isAlphaNum)+> import Data.List+> import Data.Ix ( Ix(..) )+> import Data.Array ( Array, listArray, array, (!) )++%------------------------------------------------------------------------------++Here are two defs that everyone seems to define ... +HBC has it in one of its builtin modules++> mapMaybe :: (a -> Maybe b) -> [a] -> [b]+> mapMaybe _ [] = []+> mapMaybe f (a:r) = case f a of+> Nothing -> mapMaybe f r+> Just b -> b : mapMaybe f r++> maybeMap :: (a -> b) -> Maybe a -> Maybe b+> maybeMap f (Just a) = Just (f a)+> maybeMap _ Nothing = Nothing++> joinMaybe :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a +> joinMaybe _ Nothing Nothing = Nothing+> joinMaybe _ (Just g) Nothing = Just g+> joinMaybe _ Nothing (Just g) = Just g+> joinMaybe f (Just g) (Just h) = Just (f g h)++> data MaybeErr a err = Succeeded a | Failed err deriving (Eq,Show)++@mkClosure@ makes a closure, when given a comparison and iteration loop. +Be careful, because if the functional always makes the object different, +This will never terminate.++> mkClosure :: (a -> a -> Bool) -> (a -> a) -> a -> a+> mkClosure eq f = match . iterate f+> where+> match (a:b:_) | a `eq` b = a+> match (_:c) = match c+> match [] = error "Can't happen: match []"++> foldb :: (a -> a -> a) -> [a] -> a+> foldb _ [] = error "can't reduce an empty list using foldb"+> foldb _ [x] = x+> foldb f l = foldb f (foldb' l)+> where +> foldb' (x:y:x':y':xs) = f (f x y) (f x' y') : foldb' xs+> foldb' (x:y:xs) = f x y : foldb' xs+> foldb' xs = xs++> returnMaybe :: a -> Maybe a+> returnMaybe = Just++> handleMaybe :: Maybe a -> Maybe a -> Maybe a+> handleMaybe m k = case m of+> Nothing -> k+> _ -> m+ +> findJust :: (a -> Maybe b) -> [a] -> Maybe b+> findJust f = foldr handleMaybe Nothing . map f+++Gofer-like stuff:++> fst3 :: (a, b, c) -> a+> fst3 (a,_,_) = a+> snd3 :: (a, b, c) -> b+> snd3 (_,a,_) = a+> thd3 :: (a, b, c) -> c+> thd3 (_,_,a) = a++> cjustify, ljustify, rjustify :: Int -> String -> String+> cjustify n s = space halfm ++ s ++ space (m - halfm)+> where m = n - length s+> halfm = m `div` 2+> ljustify n s = s ++ space (max 0 (n - length s))+> rjustify n s = space (n - length s) ++ s++> space :: Int -> String+> space n = copy n ' '++> copy :: Int -> a -> [a] -- make list of n copies of x+> copy n x = take n xs where xs = x:xs++> partition' :: (Eq b) => (a -> b) -> [a] -> [[a]]+> partition' _ [] = []+> partition' _ [x] = [[x]]+> partition' f (x:x':xs) | f x == f x' +> = tack x (partition' f (x':xs))+> | otherwise +> = [x] : partition' f (x':xs)++> tack :: a -> [[a]] -> [[a]]+> tack x xss = (x : head xss) : tail xss++> combinePairs :: (Ord a) => [(a,b)] -> [(a,[b])]+> combinePairs xs = +> combine [ (a,[b]) | (a,b) <- sortBy (\ (a,_) (b,_) -> compare a b) xs]+> where+> combine [] = []+> combine ((a,b):(c,d):r) | a == c = combine ((a,b++d) : r)+> combine (a:r) = a : combine r+> ++> assocMaybeErr :: (Eq a) => [(a,b)] -> a -> MaybeErr b String+> assocMaybeErr env k = case [ val | (key,val) <- env, k == key] of+> [] -> Failed "assoc: "+> (val:_) -> Succeeded val+> ++Now some utilties involving arrays. Here is a version of @elem@ that+uses partial application to optimise lookup.++> arrElem :: (Ix a, Ord a) => [a] -> a -> Bool+> arrElem obj = \x -> inRange size x && arr ! x +> where+> obj' = sort obj+> size = (head obj',last obj')+> arr = listArray size [ i `elem` obj | i <- range size ]+++You can use this function to simulate memoisation. For example:++ > fib = memoise (0,100) fib'+ > where+ > fib' 0 = 0+ > fib' 1 = 0+ > fib' n = fib (n-1) + fib (n-2)++will give a very efficent variation of the fib function.+++> memoise :: (Ix a) => (a,a) -> (a -> b) -> a -> b+> memoise bds f = (!) arr+> where arr = array bds [ (t, f t) | t <- range bds ]++> listArray' :: (Int,Int) -> [a] -> Array Int a+> listArray' (low,up) elems = +> if length elems /= up-low+1 then error "wibble" else+> listArray (low,up) elems++++Replace $$ with an arbitrary string, being careful to avoid ".." and '.'.++> mapDollarDollar :: String -> Maybe (String -> String)+> mapDollarDollar code0 = go code0 ""+> where go code acc =+> case code of+> [] -> Nothing+> +> '"' :r -> case reads code :: [(String,String)] of+> [] -> go r ('"':acc)+> (s,r'):_ -> go r' (reverse (show s) ++ acc)+> a:'\'' :r | isAlphaNum a -> go r ('\'':a:acc)+> '\'' :r -> case reads code :: [(Char,String)] of+> [] -> go r ('\'':acc)+> (c,r'):_ -> go r' (reverse (show c) ++ acc)+> '\\':'$':r -> go r ('$':acc)+> '$':'$':r -> Just (\repl -> reverse acc ++ repl ++ r)+> c:r -> go r (c:acc)+++%-------------------------------------------------------------------------------+Fast string-building functions. ++> str :: String -> String -> String+> str = showString+> char :: Char -> String -> String+> char c = (c :)+> interleave :: String -> [String -> String] -> String -> String+> interleave s = foldr (\a b -> a . str s . b) id+> interleave' :: String -> [String -> String] -> String -> String+> interleave' s = foldr1 (\a b -> a . str s . b) ++> strspace :: String -> String+> strspace = char ' '+> nl :: String -> String+> nl = char '\n'++> maybestr :: Maybe String -> String -> String+> maybestr (Just s) = str s+> maybestr _ = id++> brack :: String -> String -> String+> brack s = str ('(' : s) . char ')'+> brack' :: (String -> String) -> String -> String+> brack' s = char '(' . s . char ')'++
+ src/Grammar.lhs view
@@ -0,0 +1,594 @@+-----------------------------------------------------------------------------+The Grammar data type.++(c) 1993-2001 Andy Gill, Simon Marlow+-----------------------------------------------------------------------------++Here is our mid-section datatype++> module Grammar (+> Name, isEmpty, +> +> Production, Grammar(..), mangler,+> +> LRAction(..), ActionTable, Goto(..), GotoTable, Priority(..),+> Assoc(..),+> +> errorName, errorTok, startName, firstStartTok, dummyTok,+> eofName, epsilonTok+> ) where++> import GenUtils+> import AbsSyn+> import ParseMonad+> import AttrGrammar+> import AttrGrammarParser+> import ParamRules++> import Data.Array+> import Data.Char+> import Data.List+> import Data.Maybe (fromMaybe)++> import Control.Monad.Writer++#ifdef DEBUG++> import System.IOExts++#endif++> type Name = Int++> type Production = (Name,[Name],(String,[Int]),Priority)++> data Grammar +> = Grammar {+> productions :: [Production],+> lookupProdNo :: Int -> Production,+> lookupProdsOfName :: Name -> [Int],+> token_specs :: [(Name,String)],+> terminals :: [Name],+> non_terminals :: [Name],+> starts :: [(String,Name,Name,Bool)],+> types :: Array Int (Maybe String),+> token_names :: Array Int String,+> first_nonterm :: Name,+> first_term :: Name,+> eof_term :: Name,+> priorities :: [(Name,Priority)],+> token_type :: String,+> imported_identity :: Bool,+> monad :: (Bool,String,String,String,String),+> expect :: Maybe Int,+> attributes :: [(String,String)],+> attributetype :: String,+> lexer :: Maybe (String,String),+> error_handler :: Maybe String+> }++#ifdef DEBUG++> instance Show Grammar where+> showsPrec _ (Grammar +> { productions = p+> , token_specs = t+> , terminals = ts+> , non_terminals = nts+> , starts = starts+> , types = tys+> , token_names = e+> , first_nonterm = fnt+> , first_term = ft+> , eof_term = eof+> })+> = showString "productions = " . shows p+> . showString "\ntoken_specs = " . shows t+> . showString "\nterminals = " . shows ts+> . showString "\nnonterminals = " . shows nts+> . showString "\nstarts = " . shows starts+> . showString "\ntypes = " . shows tys+> . showString "\ntoken_names = " . shows e+> . showString "\nfirst_nonterm = " . shows fnt+> . showString "\nfirst_term = " . shows ft+> . showString "\neof = " . shows eof+> . showString "\n"++#endif++> data Assoc = LeftAssoc | RightAssoc | None++#ifdef DEBUG++> deriving Show++#endif++> data Priority = No | Prio Assoc Int++#ifdef DEBUG++> deriving Show++#endif++> instance Eq Priority where+> No == No = True+> Prio _ i == Prio _ j = i == j+> _ == _ = False++> mkPrio :: Int -> Directive a -> Priority+> mkPrio i (TokenNonassoc _) = Prio None i+> mkPrio i (TokenRight _) = Prio RightAssoc i+> mkPrio i (TokenLeft _) = Prio LeftAssoc i+> mkPrio _ _ = error "Panic: impossible case in mkPrio"++-----------------------------------------------------------------------------+-- Magic name values++All the tokens in the grammar are mapped onto integers, for speed.+The namespace is broken up as follows:++epsilon = 0+error = 1+dummy = 2+%start = 3..s+non-terminals = s..n+terminals = n..m+%eof = m++These numbers are deeply magical, change at your own risk. Several+other places rely on these being arranged as they are, including+ProduceCode.lhs and the various HappyTemplates.++Unfortunately this means you can't tell whether a given token is a+terminal or non-terminal without knowing the boundaries of the+namespace, which are kept in the Grammar structure.++In hindsight, this was probably a bad idea.++> startName, eofName, errorName, dummyName :: String+> startName = "%start" -- with a suffix, like %start_1, %start_2 etc.+> eofName = "%eof" +> errorName = "error"+> dummyName = "%dummy" -- shouldn't occur in the grammar anywhere++> firstStartTok, dummyTok, errorTok, epsilonTok :: Name+> firstStartTok = 3+> dummyTok = 2+> errorTok = 1+> epsilonTok = 0++> isEmpty :: Name -> Bool+> isEmpty n | n == epsilonTok = True+> | otherwise = False++-----------------------------------------------------------------------------+-- The Mangler++This bit is a real mess, mainly because of the error message support.++> type ErrMsg = String+> type M a = Writer [ErrMsg] a++> addErr :: ErrMsg -> M ()+> addErr e = tell [e]++> mangler :: FilePath -> AbsSyn -> MaybeErr Grammar [ErrMsg]+> mangler file abssyn+> | null errs = Succeeded g+> | otherwise = Failed errs+> where (g, errs) = runWriter (manglerM file abssyn)++> manglerM :: FilePath -> AbsSyn -> M Grammar+> manglerM file (AbsSyn _hd dirs rules' _tl) =+> -- add filename to all error messages+> mapWriter (\(a,e) -> (a, map (\s -> file ++ ": " ++ s) e)) $ do++> rules <- case expand_rules rules' of+> Left err -> addErr err >> return []+> Right as -> return as+> nonterm_strs <- checkRules ([n | (n,_,_) <- rules]) "" []++> let++> terminal_strs = concat (map getTerm dirs) ++ [eofName]++> n_starts = length starts'+> n_nts = length nonterm_strs+> n_ts = length terminal_strs+> first_nt = firstStartTok + n_starts+> first_t = first_nt + n_nts+> last_start = first_nt - 1+> last_nt = first_t - 1+> last_t = first_t + n_ts - 1++> start_names = [ firstStartTok .. last_start ]+> nonterm_names = [ first_nt .. last_nt ]+> terminal_names = [ first_t .. last_t ]++> starts' = case getParserNames dirs of+> [] -> [TokenName "happyParse" Nothing False]+> ns -> ns+>+> start_strs = [ startName++'_':p | (TokenName p _ _) <- starts' ]++Build up a mapping from name values to strings.++> name_env = (errorTok, errorName) :+> (dummyTok, dummyName) :+> zip start_names start_strs +++> zip nonterm_names nonterm_strs +++> zip terminal_names terminal_strs++> lookupName :: String -> [Name]+> lookupName n = [ t | (t,r) <- name_env, r == n ]++> mapToName str' =+> case lookupName str' of+> [a] -> return a+> [] -> do addErr ("unknown identifier '" ++ str' ++ "'")+> return errorTok+> (a:_) -> do addErr ("multiple use of '" ++ str' ++ "'")+> return a++Start symbols...++> -- default start token is the first non-terminal in the grammar+> lookupStart (TokenName _ Nothing _) = return first_nt+> lookupStart (TokenName _ (Just n) _) = mapToName n+> lookupStart _ = error "lookupStart: Not a TokenName"+> -- in++> start_toks <- mapM lookupStart starts'++> let+> parser_names = [ s | TokenName s _ _ <- starts' ]+> start_partials = [ b | TokenName _ _ b <- starts' ]+> start_prods = zipWith (\nm tok -> (nm, [tok], ("no code",[]), No))+> start_names start_toks++Deal with priorities...++> priodir = zip [1..] (getPrios dirs)+>+> prios = [ (name,mkPrio i dir)+> | (i,dir) <- priodir+> , nm <- AbsSyn.getPrioNames dir+> , name <- lookupName nm+> ]++> prioByString = [ (name, mkPrio i dir)+> | (i,dir) <- priodir+> , name <- AbsSyn.getPrioNames dir+> ]++Translate the rules from string to name-based.++> convNT (nt, prods, ty) +> = do nt' <- mapToName nt+> return (nt', prods, ty)+>+> attrs = getAttributes dirs+> attrType = fromMaybe "HappyAttrs" (getAttributetype dirs)+>+> transRule (nt, prods, _ty)+> = mapM (finishRule nt) prods+>+> finishRule nt (lhs,code,line,prec)+> = mapWriter (\(a,e) -> (a, map (addLine line) e)) $ do+> lhs' <- mapM mapToName lhs+> code' <- checkCode (length lhs) lhs' nonterm_names code attrs+> case mkPrec lhs' prec of+> Left s -> do addErr ("Undeclared precedence token: " ++ s)+> return (nt, lhs', code', No)+> Right p -> return (nt, lhs', code', p)+>+> mkPrec :: [Name] -> Maybe String -> Either String Priority+> mkPrec lhs prio =+> case prio of+> Nothing -> case filter (flip elem terminal_names) lhs of+> [] -> Right No+> xs -> case lookup (last xs) prios of+> Nothing -> Right No+> Just p -> Right p+> Just s -> case lookup s prioByString of+> Nothing -> Left s+> Just p -> Right p+> -- in++> rules1 <- mapM convNT rules+> rules2 <- mapM transRule rules1++> let+> tys = accumArray (\_ x -> x) Nothing (first_nt, last_nt) +> [ (nm, Just ty) | (nm, _, Just ty) <- rules1 ]++> env_array :: Array Int String+> env_array = array (errorTok, last_t) name_env+> -- in++Get the token specs in terms of Names.++> let +> fixTokenSpec (a,b) = do n <- mapToName a; return (n,b)+> -- in+> tokspec <- mapM fixTokenSpec (getTokenSpec dirs)++> let+> ass = combinePairs [ (a,no)+> | ((a,_,_,_),no) <- zip productions' [0..] ]+> arr = array (firstStartTok, length ass - 1 + firstStartTok) ass++> lookup_prods :: Name -> [Int]+> lookup_prods x | x >= firstStartTok && x < first_t = arr ! x+> lookup_prods _ = error "lookup_prods"+>+> productions' = start_prods ++ concat rules2+> prod_array = listArray' (0,length productions' - 1) productions'+> -- in++> return (Grammar {+> productions = productions',+> lookupProdNo = (prod_array !),+> lookupProdsOfName = lookup_prods,+> token_specs = tokspec,+> terminals = errorTok : terminal_names,+> non_terminals = start_names ++ nonterm_names,+> -- INCLUDES the %start tokens+> starts = zip4 parser_names start_names start_toks+> start_partials,+> types = tys,+> token_names = env_array,+> first_nonterm = first_nt,+> first_term = first_t,+> eof_term = last terminal_names,+> priorities = prios,+> imported_identity = getImportedIdentity dirs,+> monad = getMonad dirs,+> lexer = getLexer dirs,+> error_handler = getError dirs,+> token_type = getTokenType dirs,+> expect = getExpect dirs,+> attributes = attrs,+> attributetype = attrType+> })++For combining actions with possible error messages.++> addLine :: Int -> String -> String+> addLine l s = show l ++ ": " ++ s++> getTerm :: Directive a -> [a]+> getTerm (TokenSpec stuff) = map fst stuff+> getTerm _ = []++So is this.++> checkRules :: [String] -> String -> [String] -> Writer [ErrMsg] [String]+> checkRules (name:rest) above nonterms+> | name == above = checkRules rest name nonterms+> | name `elem` nonterms +> = do addErr ("Multiple rules for '" ++ name ++ "'")+> checkRules rest name nonterms+> | otherwise = checkRules rest name (name : nonterms)++> checkRules [] _ nonterms = return (reverse nonterms)+++-----------------------------------------------------------------------------+-- If any attribute directives were used, we are in an attribute grammar, so+-- go do special processing. If not, pass on to the regular processing routine++> checkCode :: Int -> [Name] -> [Name] -> String -> [(String,String)] -> M (String,[Int])+> checkCode arity _ _ code [] = doCheckCode arity code+> checkCode arity lhs nonterm_names code attrs = rewriteAttributeGrammar arity lhs nonterm_names code attrs++------------------------------------------------------------------------------+-- Special processing for attribute grammars. We re-parse the body of the code+-- block and output the nasty-looking record manipulation and let binding goop+--++> rewriteAttributeGrammar :: Int -> [Name] -> [Name] -> String -> [(String,String)] -> M (String,[Int])+> rewriteAttributeGrammar arity lhs nonterm_names code attrs =++ first we need to parse the body of the code block++> case runP agParser code 0 of+> FailP msg -> do addErr ("error in attribute grammar rules: "++msg)+> return ("",[])+> OkP rules ->++ now we break the rules into three lists, one for synthesized attributes,+ one for inherited attributes, and one for conditionals++> let (selfRules,subRules,conditions) = partitionRules [] [] [] rules+> attrNames = map fst attrs+> defaultAttr = head attrNames++ now check that $i references are in range++> in do let prods = mentionedProductions rules+> mapM checkArity prods++ and output the rules++> rulesStr <- formatRules arity attrNames defaultAttr +> allSubProductions selfRules +> subRules conditions++ return the munged code body and all sub-productions mentioned++> return (rulesStr,nub (allSubProductions++prods))+++> where partitionRules a b c [] = (a,b,c)+> partitionRules a b c (RightmostAssign attr toks : xs) = partitionRules a (SubAssign (arity,attr) toks : b) c xs+> partitionRules a b c (x@(SelfAssign _ _ ) : xs) = partitionRules (x:a) b c xs+> partitionRules a b c (x@(SubAssign _ _) : xs) = partitionRules a (x:b) c xs+> partitionRules a b c (x@(Conditional _) : xs) = partitionRules a b (x:c) xs++> allSubProductions = map (+1) (findIndices (`elem` nonterm_names) lhs)++> mentionedProductions rules = [ i | (AgTok_SubRef (i,_)) <- concat (map getTokens rules) ]++> getTokens (SelfAssign _ toks) = toks+> getTokens (SubAssign _ toks) = toks+> getTokens (Conditional toks) = toks+> getTokens (RightmostAssign _ toks) = toks+> +> checkArity x = when (x > arity) $ addErr (show x++" out of range")++++------------------------------------------------------------------------------------+-- Actually emit the code for the record bindings and conditionals+--++> formatRules :: Int -> [String] -> String -> [Name] +> -> [AgRule] -> [AgRule] -> [AgRule] +> -> M String++> formatRules arity _attrNames defaultAttr prods selfRules subRules conditions = return $+> concat [ "\\happyInhAttrs -> let { "+> , "happySelfAttrs = happyInhAttrs",formattedSelfRules+> , subProductionRules+> , "; happyConditions = ", formattedConditions+> , " } in (happyConditions,happySelfAttrs)"+> ]+>+> where formattedSelfRules = case selfRules of [] -> []; _ -> "{ "++formattedSelfRules'++" }"+> formattedSelfRules' = concat $ intersperse ", " $ map formatSelfRule selfRules+> formatSelfRule (SelfAssign [] toks) = defaultAttr++" = "++(formatTokens toks)+> formatSelfRule (SelfAssign attr toks) = attr++" = "++(formatTokens toks)+> formatSelfRule _ = error "formatSelfRule: Not a self rule"++> subRulesMap :: [(Int,[(String,[AgToken])])]+> subRulesMap = map (\l -> foldr (\ (_,x) (i,xs) -> (i,x:xs))+> (fst $ head l,[snd $ head l])+> (tail l) ) .+> groupBy (\x y -> (fst x) == (fst y)) .+> sortBy (\x y -> compare (fst x) (fst y)) .+> map (\(SubAssign (i,ident) toks) -> (i,(ident,toks))) $ subRules++> subProductionRules = concat $ map formatSubRules prods++> formatSubRules i = +> let attrs = fromMaybe [] . lookup i $ subRulesMap+> attrUpdates' = concat $ intersperse ", " $ map (formatSubRule i) attrs+> attrUpdates = case attrUpdates' of [] -> []; x -> "{ "++x++" }"+> in concat ["; (happyConditions_",show i,",happySubAttrs_",show i,") = ",mkHappyVar i+> ," happyEmptyAttrs"+> , attrUpdates+> ]+> +> formattedConditions = concat $ intersperse "++" $ localConditions : (map (\i -> "happyConditions_"++(show i)) prods)+> localConditions = "["++(concat $ intersperse ", " $ map formatCondition conditions)++"]"+> formatCondition (Conditional toks) = formatTokens toks+> formatCondition _ = error "formatCondition: Not a condition"++> formatSubRule _ ([],toks) = defaultAttr++" = "++(formatTokens toks)+> formatSubRule _ (attr,toks) = attr++" = "++(formatTokens toks)++> formatTokens tokens = concat (map formatToken tokens)++> formatToken AgTok_LBrace = "{ "+> formatToken AgTok_RBrace = "} "+> formatToken AgTok_Where = "where "+> formatToken AgTok_Semicolon = "; "+> formatToken AgTok_Eq = "="+> formatToken (AgTok_SelfRef []) = "("++defaultAttr++" happySelfAttrs) "+> formatToken (AgTok_SelfRef x) = "("++x++" happySelfAttrs) "+> formatToken (AgTok_RightmostRef x) = formatToken (AgTok_SubRef (arity,x))+> formatToken (AgTok_SubRef (i,[])) +> | i `elem` prods = "("++defaultAttr++" happySubAttrs_"++(show i)++") "+> | otherwise = mkHappyVar i ++ " "+> formatToken (AgTok_SubRef (i,x)) +> | i `elem` prods = "("++x++" happySubAttrs_"++(show i)++") "+> | otherwise = error ("lhs "++(show i)++" is not a non-terminal")+> formatToken (AgTok_Unknown x) = x++" "+> formatToken AgTok_EOF = error "formatToken AgTok_EOF"+++-----------------------------------------------------------------------------+-- Check for every $i that i is <= the arity of the rule.++-- At the same time, we collect a list of the variables actually used in this+-- code, which is used by the backend.++> doCheckCode :: Int -> String -> M (String, [Int])+> doCheckCode arity code0 = go code0 "" []+> where go code acc used =+> case code of+> [] -> return (reverse acc, used)+> +> '"' :r -> case reads code :: [(String,String)] of+> [] -> go r ('"':acc) used+> (s,r'):_ -> go r' (reverse (show s) ++ acc) used+> a:'\'' :r | isAlphaNum a -> go r ('\'':a:acc) used+> '\'' :r -> case reads code :: [(Char,String)] of+> [] -> go r ('\'':acc) used+> (c,r'):_ -> go r' (reverse (show c) ++ acc) used+> '\\':'$':r -> go r ('$':acc) used+>+> '$':'>':r -- the "rightmost token"+> | arity == 0 -> do addErr "$> in empty rule"+> go r acc used+> | otherwise -> go r (reverse (mkHappyVar arity) ++ acc)+> (arity : used)+>+> '$':r@(i:_) | isDigit i -> +> case reads r :: [(Int,String)] of+> (j,r'):_ -> +> if j > arity +> then do addErr ('$': show j ++ " out of range")+> go r' acc used+> else go r' (reverse (mkHappyVar j) ++ acc) +> (j : used)+> [] -> error "doCheckCode []"+> c:r -> go r (c:acc) used++> mkHappyVar :: Int -> String+> mkHappyVar n = "happy_var_" ++ show n++-----------------------------------------------------------------------------+-- Internal Reduction Datatypes++> data LRAction = LR'Shift Int Priority -- state number and priority+> | LR'Reduce Int Priority-- rule no and priority+> | LR'Accept -- :-)+> | LR'Fail -- :-(+> | LR'MustFail -- :-(+> | LR'Multiple [LRAction] LRAction -- conflict+> deriving(Eq++#ifdef DEBUG++> ,Show++#endif++> ) ++> type ActionTable = Array Int{-state-} (Array Int{-terminal#-} LRAction)++ instance Text LRAction where + showsPrec _ (LR'Shift i _) = showString ("s" ++ show i)+ showsPrec _ (LR'Reduce i _) + = showString ("r" ++ show i)+ showsPrec _ (LR'Accept) = showString ("acc")+ showsPrec _ (LR'Fail) = showString (" ")+ instance Eq LRAction where { (==) = primGenericEq } ++> data Goto = Goto Int | NoGoto +> deriving(Eq++#ifdef DEBUG++> ,Show++#endif++> ) ++> type GotoTable = Array Int{-state-} (Array Int{-nonterminal #-} Goto)
+ src/LALR.lhs view
@@ -0,0 +1,662 @@+-----------------------------------------------------------------------------+Generation of LALR parsing tables.++(c) 1993-1996 Andy Gill, Simon Marlow+(c) 1997-2001 Simon Marlow+-----------------------------------------------------------------------------++> module LALR+> (genActionTable, genGotoTable, genLR0items, precalcClosure0,+> propLookaheads, calcLookaheads, mergeLookaheadInfo, countConflicts,+> Lr0Item(..), Lr1Item)+> where++> import GenUtils+> import Data.Set ( Set )+> import qualified Data.Set as Set hiding ( Set )+> import qualified NameSet+> import NameSet ( NameSet )+> import Grammar++> import Control.Monad.ST+> import Data.Array.ST+> import Data.Array as Array+> import Data.List (nub)++> unionMap :: (Ord b) => (a -> Set b) -> Set a -> Set b+> unionMap f = Set.fold (Set.union . f) Set.empty++> unionNameMap :: (Name -> NameSet) -> NameSet -> NameSet+> unionNameMap f = NameSet.fold (NameSet.union . f) NameSet.empty++This means rule $a$, with dot at $b$ (all starting at 0)++> data Lr0Item = Lr0 {-#UNPACK#-}!Int {-#UNPACK#-}!Int -- (rule, dot)+> deriving (Eq,Ord)++> data Lr1Item = Lr1 {-#UNPACK#-}!Int {-#UNPACK#-}!Int NameSet -- (rule, dot, lookahead)+> type RuleList = [Lr0Item]++-----------------------------------------------------------------------------+Generating the closure of a set of LR(0) items++Precalculate the rule closure for each non-terminal in the grammar,+using a memo table so that no work is repeated.++> precalcClosure0 :: Grammar -> Name -> RuleList+> precalcClosure0 g = +> \n -> case lookup n info' of+> Nothing -> []+> Just c -> c+> where+>+> info' :: [(Name, RuleList)]+> info' = map (\(n,rules) -> (n,map (\rule -> Lr0 rule 0) (NameSet.toAscList rules))) info++> info :: [(Name, NameSet)]+> info = mkClosure (==) (\f -> map (follow f) f)+> (map (\nt -> (nt,NameSet.fromList (lookupProdsOfName g nt))) nts)++> follow :: [(Name, NameSet)] -> (Name, NameSet) -> (Name, NameSet)+> follow f (nt,rules) = (nt, unionNameMap (followNT f) rules `NameSet.union` rules)++> followNT :: [(Name, NameSet)] -> Int -> NameSet+> followNT f rule = +> case findRule g rule 0 of+> Just nt | nt >= firstStartTok && nt < fst_term ->+> case lookup nt f of+> Just rs -> rs+> Nothing -> error "followNT"+> _ -> NameSet.empty++> nts = non_terminals g+> fst_term = first_term g++> closure0 :: Grammar -> (Name -> RuleList) -> Set Lr0Item -> Set Lr0Item+> closure0 g closureOfNT set = Set.fold addRules Set.empty set+> where+> fst_term = first_term g+> addRules rule set' = Set.union (Set.fromList (rule : closureOfRule rule)) set'+> +> closureOfRule (Lr0 rule dot) = +> case findRule g rule dot of +> (Just nt) | nt >= firstStartTok && nt < fst_term +> -> closureOfNT nt+> _ -> []++-----------------------------------------------------------------------------+Generating the closure of a set of LR(1) items++> closure1 :: Grammar -> ([Name] -> NameSet) -> [Lr1Item] -> [Lr1Item]+> closure1 g first set+> = fst (mkClosure (\(_,new) _ -> null new) addItems ([],set))+> where+> fst_term = first_term g++> addItems :: ([Lr1Item],[Lr1Item]) -> ([Lr1Item],[Lr1Item])+> addItems (old_items, new_items) = (new_old_items, new_new_items)+> where+> new_old_items = new_items `union_items` old_items+> new_new_items = subtract_items +> (foldr union_items [] (map fn new_items))+> new_old_items++> fn :: Lr1Item -> [Lr1Item]+> fn (Lr1 rule dot as) =+> case lookupProdNo g rule of { (_name,lhs,_,_) ->+> case drop dot lhs of+> (b:beta) | b >= firstStartTok && b < fst_term ->+> let terms = unionNameMap +> (\a -> first (beta ++ [a])) as+> in+> [ (Lr1 rule' 0 terms) | rule' <- lookupProdsOfName g b ]+> _ -> []+> }++Subtract the first set of items from the second.++> subtract_items :: [Lr1Item] -> [Lr1Item] -> [Lr1Item]+> subtract_items items1 items2 = foldr (subtract_item items2) [] items1++These utilities over item sets are crucial to performance.++Stamp on overloading with judicious use of type signatures...++> subtract_item :: [Lr1Item] -> Lr1Item -> [Lr1Item] -> [Lr1Item]+> subtract_item [] i result = i : result+> subtract_item ((Lr1 rule dot as):items) i@(Lr1 rule' dot' as') result =+> case compare rule' rule of+> LT -> i : result+> GT -> carry_on+> EQ -> case compare dot' dot of+> LT -> i : result+> GT -> carry_on+> EQ -> case NameSet.difference as' as of+> bs | NameSet.null bs -> result+> | otherwise -> (Lr1 rule dot bs) : result+> where+> carry_on = subtract_item items i result++Union two sets of items.++> union_items :: [Lr1Item] -> [Lr1Item] -> [Lr1Item]+> union_items is [] = is+> union_items [] is = is+> union_items (i@(Lr1 rule dot as):is) (i'@(Lr1 rule' dot' as'):is') =+> case compare rule rule' of+> LT -> drop_i+> GT -> drop_i'+> EQ -> case compare dot dot' of+> LT -> drop_i+> GT -> drop_i'+> EQ -> (Lr1 rule dot (as `NameSet.union` as')) : union_items is is'+> where+> drop_i = i : union_items is (i':is')+> drop_i' = i' : union_items (i:is) is'++-----------------------------------------------------------------------------+goto(I,X) function++The input should be the closure of a set of kernel items I together with+a token X (terminal or non-terminal. Output will be the set of kernel+items for the set of items goto(I,X)++> gotoClosure :: Grammar -> Set Lr0Item -> Name -> Set Lr0Item+> gotoClosure gram i x = unionMap fn i+> where+> fn (Lr0 rule_no dot) =+> case findRule gram rule_no dot of+> Just t | x == t -> Set.singleton (Lr0 rule_no (dot+1))+> _ -> Set.empty ++-----------------------------------------------------------------------------+Generating LR0 Item sets++The item sets are generated in much the same way as we find the+closure of a set of items: we use two sets, those which have already+generated more sets, and those which have just been generated. We+keep iterating until the second set is empty.++The addItems function is complicated by the fact that we need to keep+information about which sets were generated by which others.++> type ItemSetWithGotos = (Set Lr0Item, [(Name,Int)])++> genLR0items :: Grammar -> (Name -> RuleList) -> [ItemSetWithGotos]+> genLR0items g precalcClosures+> = fst (mkClosure (\(_old,new) _ -> null new)+> addItems+> (([],startRules)))+> where++> n_starts = length (starts g)+> startRules :: [Set Lr0Item]+> startRules = [ Set.singleton (Lr0 rule 0) | rule <- [0..n_starts] ]++> tokens = non_terminals g ++ terminals g++> addItems :: ([ItemSetWithGotos], [Set Lr0Item])+> -> ([ItemSetWithGotos], [Set Lr0Item])+> +> addItems (oldSets,newSets) = (newOldSets, reverse newNewSets)+> where+> +> newOldSets = oldSets ++ (zip newSets intgotos)++> itemSets = map fst oldSets ++ newSets++First thing to do is for each set in I in newSets, generate goto(I,X)+for each token (terminals and nonterminals) X.++> gotos :: [[(Name,Set Lr0Item)]]+> gotos = map (filter (not . Set.null . snd))+> (map (\i -> let i' = closure0 g precalcClosures i in+> [ (x,gotoClosure g i' x) | x <- tokens ]) newSets)++Next, we assign each new set a number, which is the index of this set+in the list of sets comprising all the sets generated so far plus+those generated in this iteration. We also filter out those sets that+are new, i.e. don't exist in the current list of sets, so that they+can be added.++We also have to make sure that there are no duplicate sets in the+*current* batch of goto(I,X) sets, as this could be disastrous. I+think I've squished this one with the '++ reverse newSets' in+numberSets.++numberSets is built this way so we can use it quite neatly with a foldr.+Unfortunately, the code's a little opaque.++> numberSets +> :: [(Name,Set Lr0Item)] +> -> (Int,+> [[(Name,Int)]],+> [Set Lr0Item])+> -> (Int, [[(Name,Int)]], [Set Lr0Item])+>+> numberSets [] (i,gotos',newSets') = (i,([]:gotos'),newSets')+> numberSets ((x,gotoix):rest) (i,g':gotos',newSets')+> = numberSets rest+> (case indexInto 0 gotoix (itemSets ++ reverse newSets') of+> Just j -> (i, ((x,j):g'):gotos', newSets')+> Nothing -> (i+1,((x,i):g'):gotos', gotoix:newSets'))+> numberSets _ _ = error "genLR0items/numberSets: Unhandled case"++Finally, do some fiddling around to get this all in the form we want.++> intgotos :: [[(Name,Int)]]+> newNewSets :: [Set Lr0Item]+> (_, ([]:intgotos), newNewSets) =+> foldr numberSets (length newOldSets, [[]], []) gotos++> indexInto :: Eq a => Int -> a -> [a] -> Maybe Int+> indexInto _ _ [] = Nothing+> indexInto i x (y:ys) | x == y = Just i+> | otherwise = indexInto (i+1) x ys++-----------------------------------------------------------------------------+Computing propagation of lookaheads++ToDo: generate this info into an array to be used in the subsequent+calcLookaheads pass.++> propLookaheads +> :: Grammar+> -> [(Set Lr0Item,[(Name,Int)])] -- LR(0) kernel sets+> -> ([Name] -> NameSet) -- First function+> -> (+> [(Int, Lr0Item, NameSet)], -- spontaneous lookaheads+> Array Int [(Lr0Item, Int, Lr0Item)] -- propagated lookaheads+> )++> propLookaheads gram sets first = (concat s, array (0,length sets - 1) +> [ (a,b) | (a,b) <- p ])+> where++> (s,p) = unzip (zipWith propLASet sets [0..])++> propLASet :: (Set Lr0Item, [(Name, Int)]) -> Int -> ([(Int, Lr0Item, NameSet)],(Int,[(Lr0Item, Int, Lr0Item)]))+> propLASet (set,goto) i = (start_spont ++ concat s', (i, concat p'))+> where++> (s',p') = unzip (map propLAItem (Set.toAscList set))++> -- spontaneous EOF lookaheads for each start state & rule...+> start_info :: [(String, Name, Name, Bool)]+> start_info = starts gram ++> start_spont :: [(Int, Lr0Item ,NameSet)]+> start_spont = [ (start, (Lr0 start 0), +> NameSet.singleton (startLookahead gram partial))+> | (start, (_,_,_,partial)) <- +> zip [ 0 .. length start_info - 1] start_info]++> propLAItem :: Lr0Item -> ([(Int, Lr0Item, NameSet)], [(Lr0Item, Int, Lr0Item)])+> propLAItem item@(Lr0 rule dot) = (spontaneous, propagated)+> where++> j = closure1 gram first [Lr1 rule dot (NameSet.singleton dummyTok)]++> spontaneous :: [(Int, Lr0Item, NameSet)]+> spontaneous = concat [ +> (case findRule gram rule' dot' of+> Nothing -> []+> Just x -> case lookup x goto of+> Nothing -> error "spontaneous"+> Just k ->+> case NameSet.filter (/= dummyTok) ts of+> ts' | NameSet.null ts' -> []+> | otherwise -> [(k, Lr0 rule' (dot' + 1), ts')])+> | (Lr1 rule' dot' ts) <- j ]++> propagated :: [(Lr0Item, Int, Lr0Item)]+> propagated = concat [+> (case findRule gram rule' dot' of+> Nothing -> []+> Just x -> case lookup x goto of+> Nothing -> error "propagated"+> Just k -> [(item, k, Lr0 rule' (dot' + 1))])+> | (Lr1 rule' dot' ts) <- j, dummyTok `elem` (NameSet.toAscList ts) ]++The lookahead for a start rule depends on whether it was declared+with %name or %partial: a %name parser is assumed to parse the whole+input, ending with EOF, whereas a %partial parser may parse only a+part of the input: it accepts when the error token is found.++> startLookahead :: Grammar -> Bool -> Name+> startLookahead gram partial = if partial then errorTok else eof_term gram++-----------------------------------------------------------------------------+Calculate lookaheads++Special version using a mutable array:++> calcLookaheads+> :: Int -- number of states+> -> [(Int, Lr0Item, NameSet)] -- spontaneous lookaheads+> -> Array Int [(Lr0Item, Int, Lr0Item)] -- propagated lookaheads+> -> Array Int [(Lr0Item, NameSet)]++> calcLookaheads n_states spont prop+> = runST (do+> arr <- newArray (0,n_states) []+> propagate arr (foldr fold_lookahead [] spont)+> freeze arr+> )++> where+> propagate :: STArray s Int [(Lr0Item, NameSet)]+> -> [(Int, Lr0Item, NameSet)] -> ST s ()+> propagate _ [] = return ()+> propagate arr new = do +> let+> items = [ (i,item'',s) | (j,item,s) <- new, +> (item',i,item'') <- prop ! j,+> item == item' ]+> new_new <- get_new arr items []+> add_lookaheads arr new+> propagate arr new_new++This function is needed to merge all the (set_no,item,name) triples+into (set_no, item, set name) triples. It can be removed when we get+the spontaneous lookaheads in the right form to begin with (ToDo).++> add_lookaheads :: STArray s Int [(Lr0Item, NameSet)]+> -> [(Int, Lr0Item, NameSet)]+> -> ST s ()+> add_lookaheads _ [] = return ()+> add_lookaheads arr ((i,item,s) : lookaheads) = do+> las <- readArray arr i+> writeArray arr i (add_lookahead item s las)+> add_lookaheads arr lookaheads++> get_new :: STArray s Int [(Lr0Item, NameSet)]+> -> [(Int, Lr0Item, NameSet)]+> -> [(Int, Lr0Item, NameSet)]+> -> ST s [(Int, Lr0Item, NameSet)]+> get_new _ [] new = return new+> get_new arr (l@(i,_item,_s):las) new = do+> state_las <- readArray arr i+> get_new arr las (get_new' l state_las new)++> add_lookahead :: Lr0Item -> NameSet -> [(Lr0Item,NameSet)] ->+> [(Lr0Item,NameSet)]+> add_lookahead item s [] = [(item,s)]+> add_lookahead item s (m@(item',s') : las)+> | item == item' = (item, s `NameSet.union` s') : las+> | otherwise = m : add_lookahead item s las++> get_new' :: (Int,Lr0Item,NameSet) -> [(Lr0Item,NameSet)] ->+> [(Int,Lr0Item,NameSet)] -> [(Int,Lr0Item,NameSet)]+> get_new' l [] new = l : new+> get_new' l@(i,item,s) ((item',s') : las) new+> | item == item' =+> let s'' = NameSet.filter (\x -> not (NameSet.member x s')) s in+> if NameSet.null s'' then new else+> ((i,item,s''):new)+> | otherwise = +> get_new' l las new++> fold_lookahead :: (Int,Lr0Item,NameSet) -> [(Int,Lr0Item,NameSet)]+> -> [(Int,Lr0Item,NameSet)]+> fold_lookahead l [] = [l]+> fold_lookahead l@(i,item,s) (m@(i',item',s'):las)+> | i == i' && item == item' = (i,item, s `NameSet.union` s'):las+> | i < i' = (i,item,s):m:las+> | otherwise = m : fold_lookahead l las++Normal version:++calcLookaheads+ :: Int -- number of states+ -> [(Int, Lr0Item, Set Name)] -- spontaneous lookaheads+ -> Array Int [(Lr0Item, Int, Lr0Item)] -- propagated lookaheads+ -> Array Int [(Lr0Item, Set Name)]++calcLookaheads n_states spont prop+ = rebuildArray $ fst (mkClosure (\(_,new) _ -> null new) propagate+ ([], foldr addLookahead [] spont))+ where++ rebuildArray :: [(Int, Lr0Item, Set Name)] -> Array Int [(Lr0Item, Set Name)]+ rebuildArray xs = accumArray (++) [] (0,n_states-1)+ [ (a, [(b,c)]) | (a,b,c) <- xs ]++ propagate (las,new) = + let+ items = [ (i,item'',s) | (j,item,s) <- new, + (item',i,item'') <- prop ! j,+ item == item' ]+ new_new = foldr (\i new -> getNew i las new) [] items+ new_las = foldr addLookahead las new+ in+ (new_las, new_new)++addLookahead :: (Int,Lr0Item,Set Name) -> [(Int,Lr0Item,Set Name)]+ -> [(Int,Lr0Item,Set Name)]+addLookahead l [] = [l]+addLookahead l@(i,item,s) (m@(i',item',s'):las)+ | i == i' && item == item' = (i,item, s `Set.union` s'):las+ | i < i' = (i,item,s):m:las+ | otherwise = m : addLookahead l las++getNew :: (Int,Lr0Item,Set Name) -> [(Int,Lr0Item,Set Name)]+ -> [(Int,Lr0Item,Set Name)] -> [(Int,Lr0Item,Set Name)]+getNew l [] new = l:new+getNew l@(i,item,s) (m@(i',item',s'):las) new+ | i == i' && item == item' = + let s'' = filter (`notElem` s') s in+ if null s'' then new else+ ((i,item,s''):new)+ | i < i' = (i,item,s):new+ | otherwise = getNew l las new++-----------------------------------------------------------------------------+Merge lookaheads++Stick the lookahead info back into the state table.++> mergeLookaheadInfo+> :: Array Int [(Lr0Item, NameSet)] -- lookahead info+> -> [(Set Lr0Item, [(Name,Int)])] -- state table+> -> [ ([Lr1Item], [(Name,Int)]) ]++> mergeLookaheadInfo lookaheads sets+> = zipWith mergeIntoSet sets [0..]+> where++> mergeIntoSet :: (Set Lr0Item, [(Name, Int)]) -> Int -> ([Lr1Item], [(Name, Int)])+> mergeIntoSet (items, goto) i+> = (concat (map mergeIntoItem (Set.toAscList items)), goto)+> where++> mergeIntoItem :: Lr0Item -> [Lr1Item]+> mergeIntoItem item@(Lr0 rule dot)+> = [Lr1 rule dot la]+> where la = case [ s | (item',s) <- lookaheads ! i,+> item == item' ] of+> [] -> NameSet.empty+> [x] -> x+> _ -> error "mergIntoItem"++-----------------------------------------------------------------------------+Generate the goto table++This is pretty straightforward, given all the information we stored+while generating the LR0 sets of items.++Generating the goto table doesn't need lookahead info.++> genGotoTable :: Grammar -> [(Set Lr0Item,[(Name,Int)])] -> GotoTable+> genGotoTable g sets = gotoTable+> where+> Grammar{ first_nonterm = fst_nonterm,+> first_term = fst_term,+> non_terminals = non_terms } = g+>+> -- goto array doesn't include %start symbols+> gotoTable = listArray (0,length sets-1)+> [+> (array (fst_nonterm, fst_term-1) [ +> (n, case lookup n goto of+> Nothing -> NoGoto+> Just s -> Goto s)+> | n <- non_terms,+> n >= fst_nonterm, n < fst_term ])+> | (_set,goto) <- sets ]++-----------------------------------------------------------------------------+Generate the action table++> genActionTable :: Grammar -> ([Name] -> NameSet) ->+> [([Lr1Item],[(Name,Int)])] -> ActionTable+> genActionTable g first sets = actionTable+> where+> Grammar { first_term = fst_term,+> terminals = terms,+> starts = starts',+> priorities = prios } = g++> n_starts = length starts'+> isStartRule rule = rule < n_starts -- a bit hacky, but it'll do for now++> term_lim = (head terms,last terms)+> actionTable = array (0,length sets-1)+> [ (set_no, accumArray res+> LR'Fail term_lim +> (possActions goto set))+> | ((set,goto),set_no) <- zip sets [0..] ]++> possAction goto _set (Lr1 rule pos la) = +> case findRule g rule pos of+> Just t | t >= fst_term || t == errorTok -> +> case lookup t goto of+> Nothing -> []+> Just j ->+> case lookup t prios of+> Nothing -> [ (t,LR'Shift j{-'-} No) ]+> Just p -> [ (t,LR'Shift j{-'-} p) ]+> Nothing+> | isStartRule rule+> -> let (_,_,_,partial) = starts' !! rule in+> [ (startLookahead g partial, LR'Accept{-'-}) ]+> | otherwise +> -> case lookupProdNo g rule of+> (_,_,_,p) -> zip (NameSet.toAscList la) (repeat (LR'Reduce rule p))+> _ -> []++> possActions goto coll = +> (concat [ possAction goto coll item |+> item <- closure1 g first coll ])++These comments are now out of date! /JS++Here's how we resolve conflicts, leaving a complete record of the+conflicting actions in an LR'Multiple structure for later output in+the info file.++Shift/reduce conflicts are always resolved as shift actions, and+reduce/reduce conflicts are resolved as a reduce action using the rule+with the lowest number (i.e. the rule that comes first in the grammar+file.)++NOTES on LR'MustFail: this was introduced as part of the precedence+parsing changes. The problem with LR'Fail is that it is a soft+failure: we sometimes substitute an LR'Fail for an LR'Reduce (eg. when+computing default actions), on the grounds that an LR'Fail in this+state will also be an LR'Fail in the goto state, so we'll fail+eventually. This may not be true with precedence parsing, though. If+there are two non-associative operators together, we must fail at this+point rather than reducing. Hence the use of LR'MustFail.+++NOTE: on (LR'Multiple as a) handling+ PCC [sep04] has changed this to have the following invariants:+ * the winning action appears only once, in the "a" slot+ * only reductions appear in the "as" list+ * there are no duplications+ This removes complications elsewhere, where LR'Multiples were + building up tree structures... ++> res LR'Fail x = x+> res x LR'Fail = x+> res LR'MustFail _ = LR'MustFail+> res _ LR'MustFail = LR'MustFail+> res x x' | x == x' = x+> res (LR'Accept) _ = LR'Accept+> res _ (LR'Accept) = LR'Accept++> res (LR'Multiple as x) (LR'Multiple bs x')+> | x == x' = LR'Multiple (nub $ as ++ bs) x+> -- merge dropped reductions for identical action++> res (LR'Multiple as x) (LR'Multiple bs x')+> = case res x x' of +> LR'Multiple cs a+> | a == x -> LR'Multiple (nub $ x' : as ++ bs ++ cs) x+> | a == x' -> LR'Multiple (nub $ x : as ++ bs ++ cs) x'+> | otherwise -> error "failed invariant in resolve"+> -- last means an unexpected change+> other -> other+> -- merge dropped reductions for clashing actions, but only +> -- if they were S/R or R/R++> res a@(LR'Multiple _ _) b = res a (LR'Multiple [] b)+> res a b@(LR'Multiple _ _) = res (LR'Multiple [] a) b +> -- leave cases above to do the appropriate merging++> res a@(LR'Shift {}) b@(LR'Reduce {}) = res b a+> res a@(LR'Reduce _ p) b@(LR'Shift _ p')+> = case (p,p') of+> (No,_) -> LR'Multiple [a] b -- shift wins+> (_,No) -> LR'Multiple [a] b -- shift wins+> (Prio c i, Prio _ j)+> | i < j -> b+> | i > j -> a+> | otherwise ->+> case c of+> LeftAssoc -> a+> RightAssoc -> b+> None -> LR'MustFail+> res a@(LR'Reduce r p) b@(LR'Reduce r' p')+> = case (p,p') of+> (No,_) -> LR'Multiple [a] b -- give to earlier rule?+> (_,No) -> LR'Multiple [a] b+> (Prio _ i, Prio _ j)+> | i < j -> b+> | j > i -> a+> | r < r' -> LR'Multiple [b] a+> | otherwise -> LR'Multiple [a] b+> res _ _ = error "confict in resolve"++-----------------------------------------------------------------------------+Count the conflicts++> countConflicts :: ActionTable -> (Array Int (Int,Int), (Int,Int))+> countConflicts action+> = (conflictArray, foldr (\(a,b) (c,d) -> (a+c, b+d)) (0,0) conflictList)+> +> where+> +> conflictArray = listArray (Array.bounds action) conflictList+> conflictList = map countConflictsState (assocs action)+>+> countConflictsState (_state, actions)+> = foldr countMultiples (0,0) (elems actions)+> where+> countMultiples (LR'Multiple (_:_) (LR'Shift{})) (sr,rr) +> = (sr + 1, rr)+> countMultiples (LR'Multiple (_:_) (LR'Reduce{})) (sr,rr) +> = (sr, rr + 1)+> countMultiples (LR'Multiple _ _) _+> = error "bad conflict representation"+> countMultiples _ c = c++-----------------------------------------------------------------------------++> findRule :: Grammar -> Int -> Int -> Maybe Name+> findRule g rule dot = +> case lookupProdNo g rule of+> (_,lhs,_,_) -> case drop dot lhs of+> (a:_) -> Just a+> _ -> Nothing
+ src/Lexer.lhs view
@@ -0,0 +1,251 @@+-----------------------------------------------------------------------------+The lexer.++(c) 1993-2001 Andy Gill, Simon Marlow+-----------------------------------------------------------------------------++> module Lexer (+> Token(..),+> TokenId(..),+> lexer ) where++> import ParseMonad ++> import Data.Char ( isSpace, isAlphaNum, isDigit, digitToInt )++> data Token +> = TokenInfo String TokenId+> | TokenNum Int TokenId+> | TokenKW TokenId+> | TokenEOF++> tokenToId :: Token -> TokenId+> tokenToId (TokenInfo _ i) = i+> tokenToId (TokenNum _ i) = i+> tokenToId (TokenKW i) = i+> tokenToId TokenEOF = error "tokenToId TokenEOF"++> instance Eq Token where+> i == i' = tokenToId i == tokenToId i'++> instance Ord Token where+> i <= i' = tokenToId i <= tokenToId i'++> data TokenId +> = TokId -- words and symbols+> | TokSpecId_TokenType -- %tokentype+> | TokSpecId_Token -- %token+> | TokSpecId_Name -- %name+> | TokSpecId_Partial -- %partial+> | TokSpecId_Lexer -- %lexer+> | TokSpecId_ImportedIdentity -- %importedidentity+> | TokSpecId_Monad -- %monad+> | TokSpecId_Nonassoc -- %nonassoc+> | TokSpecId_Left -- %left+> | TokSpecId_Right -- %right+> | TokSpecId_Prec -- %prec+> | TokSpecId_Expect -- %expect+> | TokSpecId_Error -- %error+> | TokSpecId_Attributetype -- %attributetype+> | TokSpecId_Attribute -- %attribute+> | TokCodeQuote -- stuff inside { .. }+> | TokColon -- :+> | TokSemiColon -- ;+> | TokDoubleColon -- ::+> | TokDoublePercent -- %%+> | TokBar -- |+> | TokNum -- Integer+> | TokParenL -- (+> | TokParenR -- )+> | TokComma -- ,+> deriving (Eq,Ord++#ifdef DEBUG++> ,Show++#endif++> )++ToDo: proper text instance here, for use in parser error messages.++> lexer :: (Token -> P a) -> P a+> lexer cont = P lexer'+> where lexer' "" = returnToken cont TokenEOF ""+> lexer' ('-':'-':r) = lexer' (dropWhile (/= '\n') r)+> lexer' ('{':'-':r) = \line -> lexNestedComment line lexer' r line+> lexer' (c:rest) = nextLex cont c rest++> returnToken :: (t -> P a) -> t -> String -> Int -> ParseResult a+> returnToken cont tok = runP (cont tok)++> nextLex :: (Token -> P a) -> Char -> String -> Int -> ParseResult a+> nextLex cont c = case c of+> '\n' -> \rest line -> returnToken lexer cont rest (line+1)+> '%' -> lexPercent cont+> ':' -> lexColon cont+> ';' -> returnToken cont (TokenKW TokSemiColon)++> '|' -> returnToken cont (TokenKW TokBar)+> '\'' -> lexChar cont+> '"'{-"-}-> lexString cont+> '{' -> lexCode cont++> '(' -> returnToken cont (TokenKW TokParenL)+> ')' -> returnToken cont (TokenKW TokParenR)+> ',' -> returnToken cont (TokenKW TokComma)++> _ +> | isSpace c -> runP (lexer cont)+> | c >= 'a' && c <= 'z' +> || c >= 'A' && c <= 'Z' -> lexId cont c+> | isDigit c -> lexNum cont c+> _ -> lexError ("lexical error before `" ++ c : "'")++Percents come in two forms, in pairs, or +followed by a special identifier.++> lexPercent :: (Token -> P a) -> [Char] -> Int -> ParseResult a+> lexPercent cont s = case s of+> '%':rest -> returnToken cont (TokenKW TokDoublePercent) rest+> 't':'o':'k':'e':'n':'t':'y':'p':'e':rest -> +> returnToken cont (TokenKW TokSpecId_TokenType) rest+> 't':'o':'k':'e':'n':rest ->+> returnToken cont (TokenKW TokSpecId_Token) rest+> 'n':'a':'m':'e':rest ->+> returnToken cont (TokenKW TokSpecId_Name) rest+> 'p':'a':'r':'t':'i':'a':'l':rest ->+> returnToken cont (TokenKW TokSpecId_Partial) rest+> 'i':'m':'p':'o':'r':'t':'e':'d':'i':'d':'e':'n':'t':'i':'t':'y':rest ->+> returnToken cont (TokenKW TokSpecId_ImportedIdentity) rest+> 'm':'o':'n':'a':'d':rest ->+> returnToken cont (TokenKW TokSpecId_Monad) rest+> 'l':'e':'x':'e':'r':rest ->+> returnToken cont (TokenKW TokSpecId_Lexer) rest+> 'n':'o':'n':'a':'s':'s':'o':'c':rest ->+> returnToken cont (TokenKW TokSpecId_Nonassoc) rest+> 'l':'e':'f':'t':rest ->+> returnToken cont (TokenKW TokSpecId_Left) rest+> 'r':'i':'g':'h':'t':rest ->+> returnToken cont (TokenKW TokSpecId_Right) rest+> 'p':'r':'e':'c':rest ->+> returnToken cont (TokenKW TokSpecId_Prec) rest+> 'e':'x':'p':'e':'c':'t':rest ->+> returnToken cont (TokenKW TokSpecId_Expect) rest+> 'e':'r':'r':'o':'r':rest ->+> returnToken cont (TokenKW TokSpecId_Error) rest+> 'a':'t':'t':'r':'i':'b':'u':'t':'e':'t':'y':'p':'e':rest ->+> returnToken cont (TokenKW TokSpecId_Attributetype) rest+> 'a':'t':'t':'r':'i':'b':'u':'t':'e':rest ->+> returnToken cont (TokenKW TokSpecId_Attribute) rest+> _ -> lexError ("unrecognised directive: %" ++ +> takeWhile (not.isSpace) s) s++> lexColon :: (Token -> P a) -> [Char] -> Int -> ParseResult a+> lexColon cont (':':rest) = returnToken cont (TokenKW TokDoubleColon) rest+> lexColon cont rest = returnToken cont (TokenKW TokColon) rest++> lexId :: (Token -> P a) -> Char -> String -> Int -> ParseResult a+> lexId cont c rest = +> readId rest (\ ident rest' -> returnToken cont (TokenInfo (c:ident) TokId) rest')++> lexChar :: (Token -> P a) -> String -> Int -> ParseResult a+> lexChar cont rest = lexReadChar rest +> (\ ident -> returnToken cont (TokenInfo ("'" ++ ident ++ "'") TokId))++> lexString :: (Token -> P a) -> String -> Int -> ParseResult a+> lexString cont rest = lexReadString rest +> (\ ident -> returnToken cont (TokenInfo ("\"" ++ ident ++ "\"") TokId))++> lexCode :: (Token -> P a) -> String -> Int -> ParseResult a+> lexCode cont rest = lexReadCode rest (0 :: Integer) "" cont++> lexNum :: (Token -> P a) -> Char -> String -> Int -> ParseResult a+> lexNum cont c rest = +> readNum rest (\ num rest' -> +> returnToken cont (TokenNum (stringToInt (c:num)) TokNum) rest')+> where stringToInt = foldl (\n c' -> digitToInt c' + 10*n) 0++> cleanupCode :: String -> String+> cleanupCode s = +> dropWhile isSpace (reverse (dropWhile isSpace (reverse s)))++This has to match for @}@ that are {\em not} in strings. The code+here is a bit tricky, but should work in most cases.++> lexReadCode :: Num a+> => String -> a -> String -> (Token -> P b) -> Int+> -> ParseResult b+> lexReadCode s n c = case s of+> '\n':r -> \cont l -> lexReadCode r n ('\n':c) cont (l+1)+>+> '{' :r -> lexReadCode r (n+1) ('{':c)+>+> '}' :r+> | n == 0 -> \cont -> returnToken cont (TokenInfo (+> cleanupCode (reverse c)) TokCodeQuote) r+> | otherwise -> lexReadCode r (n-1) ('}':c)+>+> '"'{-"-}:r -> lexReadString r (\ str r' -> +> lexReadCode r' n ('"' : (reverse str) ++ '"' : c))+>+> a: '\'':r | isAlphaNum a -> lexReadCode r n ('\'':a:c)+>+> '\'' :r -> lexReadSingleChar r (\ str r' -> +> lexReadCode r' n ((reverse str) ++ '\'' : c))+>+> ch:r -> lexReadCode r n (ch:c)+>+> [] -> \_cont -> lexError "No closing '}' in code segment" []++----------------------------------------------------------------------------+Utilities that read the rest of a token.++> readId :: String -> (String -> String -> a) -> a+> readId (c:r) fn | isIdPart c = readId r (fn . (:) c)+> readId r fn = fn [] r++> readNum :: String -> (String -> String -> a) -> a+> readNum (c:r) fn | isDigit c = readNum r (fn . (:) c)+> readNum r fn = fn [] r++> isIdPart :: Char -> Bool+> isIdPart c =+> c >= 'a' && c <= 'z' +> || c >= 'A' && c <= 'Z' +> || c >= '0' && c <= '9' +> || c == '_'++> lexReadSingleChar :: String -> (String -> String -> a) -> a+> lexReadSingleChar (c:'\'':r) fn = fn (c:"'") r+> lexReadSingleChar ('\\':c:'\'':r) fn = fn ('\\':c:"'") r+> lexReadSingleChar r fn = fn "" r++> lexReadChar :: String -> (String -> String -> a) -> a+> lexReadChar ('\'':r) fn = fn "" r+> lexReadChar ('\\':'\'':r) fn = lexReadChar r (fn . (:) '\\' . (:) '\'')+> lexReadChar ('\\':c:r) fn = lexReadChar r (fn . (:) '\\' . (:) c)+> lexReadChar (c:r) fn = lexReadChar r (fn . (:) c)+> lexReadChar [] fn = fn "" []++> lexReadString :: String -> (String -> String -> a) -> a+> lexReadString ('"'{-"-}:r) fn = fn "" r+> lexReadString ('\\':'"':r) fn = lexReadString r (fn . (:) '\\' . (:) '"')+> lexReadString ('\\':c:r) fn = lexReadString r (fn . (:) '\\' . (:) c)+> lexReadString (c:r) fn = lexReadString r (fn . (:) c)+> lexReadString [] fn = fn "" []++> lexError :: String -> String -> Int -> ParseResult a+> lexError err = runP (lineP >>= \l -> fail (show l ++ ": " ++ err ++ "\n"))++> lexNestedComment :: Int -> ([Char] -> Int -> ParseResult a) -> [Char] -> Int+> -> ParseResult a+> lexNestedComment l cont r = +> case r of+> '-':'}':r' -> cont r'+> '{':'-':r' -> \line -> lexNestedComment line +> (\r'' -> lexNestedComment l cont r'') r' line+> '\n':r' -> \line -> lexNestedComment l cont r' (line+1)+> _:r' -> lexNestedComment l cont r'+> "" -> \_ -> lexError "unterminated comment" r l
+ src/NameSet.hs view
@@ -0,0 +1,10 @@+module NameSet (+ NameSet, null, member, empty, singleton,+ union, difference, filter, fold,+ fromList, toAscList+) where++import Prelude hiding ( null, filter )+import Data.IntSet++type NameSet = IntSet
+ src/ParamRules.hs view
@@ -0,0 +1,92 @@+module ParamRules(expand_rules) where++import AbsSyn+import Control.Monad.Writer+import Control.Monad.Error+import Control.Monad.Instances() -- mtl is broken, so we use Either monad+import Data.List(partition,intersperse)+import qualified Data.Set as S+import qualified Data.Map as M -- XXX: Make it work with old GHC.++expand_rules :: [Rule] -> Either String [Rule1]+expand_rules rs = do let (funs,rs1) = split_rules rs+ (as,is) <- runM2 (mapM (`inst_rule` []) rs1)+ bs <- make_insts funs (S.toList is) S.empty+ return (as++bs)++type RuleName = String+type Inst = (RuleName, [RuleName])+type Funs = M.Map RuleName Rule+type Rule1 = (RuleName,[Prod1],Maybe String)+type Prod1 = ([RuleName],String,Int,Maybe String)++inst_name :: Inst -> RuleName+inst_name (f,[]) = f+inst_name (f,xs) = f ++ "(" ++ concat (intersperse "," xs) ++ ")"+++-- | A renaming substitution used when we instantiate a parameterized rule.+type Subst = [(RuleName,RuleName)]+type M1 = Writer (S.Set Inst)+type M2 = ErrorT String M1++-- | Collects the instances arising from a term.+from_term :: Subst -> Term -> M1 RuleName+from_term s (App f []) = return $ case lookup f s of+ Just g -> g+ Nothing -> f++from_term s (App f ts) = do xs <- from_terms s ts+ let i = (f,xs)+ tell (S.singleton i)+ return $ inst_name i++-- | Collects the instances arising from a list of terms.+from_terms :: Subst -> [Term] -> M1 [RuleName]+from_terms s ts = mapM (from_term s) ts++-- XXX: perhaps change the line to the line of the instance+inst_prod :: Subst -> Prod -> M1 Prod1+inst_prod s (ts,c,l,p) = do xs <- from_terms s ts+ return (xs,c,l,p)++inst_rule :: Rule -> [RuleName] -> M2 Rule1+inst_rule (x,xs,ps,t) ts = do s <- build xs ts []+ ps1 <- lift $ mapM (inst_prod s) ps+ let y = inst_name (x,ts)+ return (y,ps1,t) -- XXX: type?+ where build (x':xs') (t':ts') m = build xs' ts' ((x',t'):m)+ build [] [] m = return m+ build xs' [] _ = err ("Need " ++ show (length xs') ++ " more arguments")+ build _ ts' _ = err (show (length ts') ++ " arguments too many.")++ err m = throwError ("In " ++ inst_name (x,ts) ++ ": " ++ m)++make_rule :: Funs -> Inst -> M2 Rule1+make_rule funs (f,xs) =+ case M.lookup f funs of+ Just r -> inst_rule r xs+ Nothing -> throwError ("Undefined rule: " ++ f)++runM2 :: ErrorT e (Writer w) a -> Either e (a, w)+runM2 m = case runWriter (runErrorT m) of+ (Left e,_) -> Left e+ (Right a,xs) -> Right (a,xs)++make_insts :: Funs -> [Inst] -> S.Set Inst -> Either String [Rule1]+make_insts _ [] _ = return []+make_insts funs is done =+ do (as,ws) <- runM2 (mapM (make_rule funs) is)+ let done1 = S.union (S.fromList is) done+ let is1 = filter (not . (`S.member` done1)) (S.toList ws)+ bs <- make_insts funs is1 done1+ return (as++bs)+++split_rules :: [Rule] -> (Funs,[Rule])+split_rules rs = let (xs,ys) = partition has_args rs+ in (M.fromList [ (x,r) | r@(x,_,_,_) <- xs ],ys)+ where has_args (_,xs,_,_) = not (null xs)+++
+ src/ParseMonad.lhs view
@@ -0,0 +1,22 @@+-----------------------------------------------------------------------------+The parser monad.++(c) 2001 Simon Marlow+-----------------------------------------------------------------------------++> module ParseMonad where++> data ParseResult a = OkP a | FailP String+> newtype P a = P (String -> Int -> ParseResult a)+> runP :: P a -> String -> Int -> ParseResult a+> runP (P f) = f++> lineP :: P Int+> lineP = P $ \_ l -> OkP l++> instance Monad P where+> return m = P $ \ _ _ -> OkP m+> m >>= k = P $ \s l -> case runP m s l of+> OkP a -> runP (k a) s l+> FailP err -> FailP err+> fail s = P $ \ _ _ -> FailP s
+ src/Parser.ly view
@@ -0,0 +1,146 @@+-----------------------------------------------------------------------------+$Id: Parser.ly,v 1.15 2005/01/26 01:10:42 ross Exp $++The parser.++(c) 1993-2000 Andy Gill, Simon Marlow+-----------------------------------------------------------------------------++> {+> {-# OPTIONS_GHC -w #-}+> module Parser (ourParser,AbsSyn) where+> import ParseMonad+> import AbsSyn+> import Lexer+> }++> %name ourParser+> %tokentype { Token }+> %token+> id { TokenInfo $$ TokId }+> spec_tokentype { TokenKW TokSpecId_TokenType }+> spec_token { TokenKW TokSpecId_Token }+> spec_name { TokenKW TokSpecId_Name }+> spec_partial { TokenKW TokSpecId_Partial }+> spec_lexer { TokenKW TokSpecId_Lexer }+> spec_imported_identity { TokenKW TokSpecId_ImportedIdentity }+> spec_monad { TokenKW TokSpecId_Monad }+> spec_nonassoc { TokenKW TokSpecId_Nonassoc }+> spec_left { TokenKW TokSpecId_Left }+> spec_right { TokenKW TokSpecId_Right }+> spec_prec { TokenKW TokSpecId_Prec }+> spec_expect { TokenKW TokSpecId_Expect }+> spec_error { TokenKW TokSpecId_Error }+> spec_attribute { TokenKW TokSpecId_Attribute }+> spec_attributetype { TokenKW TokSpecId_Attributetype }+> code { TokenInfo $$ TokCodeQuote }+> int { TokenNum $$ TokNum }+> ":" { TokenKW TokColon }+> ";" { TokenKW TokSemiColon }+> "::" { TokenKW TokDoubleColon }+> "%%" { TokenKW TokDoublePercent }+> "|" { TokenKW TokBar }+> "(" { TokenKW TokParenL }+> ")" { TokenKW TokParenR }+> "," { TokenKW TokComma }++> %monad { P }+> %lexer { lexer } { TokenEOF }++> %%++> parser :: { AbsSyn }+> : optCode tokInfos "%%" rules optCode+> { AbsSyn $1 (reverse $2) (reverse $4) $5 }++> rules :: { [Rule] }+> : rules rule { $2 : $1 }+> | rule { [$1] }++> rule :: { Rule }+> : id params "::" code ":" prods { ($1,$2,$6,Just $4) }+> | id params "::" code id ":" prods { ($1,$2,$7,Just $4) }+> | id params ":" prods { ($1,$2,$4,Nothing) }++> params :: { [String] }+> : "(" comma_ids ")" { reverse $2 }+> | {- empty -} { [] }++> comma_ids :: { [String] }+> : id { [$1] }+> | comma_ids "," id { $3 : $1 }++> prods :: { [Prod] }+> : prod "|" prods { $1 : $3 }+> | prod { [$1] }++> prod :: { Prod }+> : terms prec code ";" {% lineP >>= \l -> return ($1,$3,l,$2) }+> | terms prec code {% lineP >>= \l -> return ($1,$3,l,$2) }++> term :: { Term }+> : id { App $1 [] }+> | id "(" comma_terms ")" { App $1 (reverse $3) }++> terms :: { [Term] }+> : terms_rev { reverse $1 }+> | { [] }++> terms_rev :: { [Term] }+> : term { [$1] }+> | terms_rev term { $2 : $1 }++> comma_terms :: { [Term] }+> : term { [$1] }+> | comma_terms "," term { $3 : $1 }++> prec :: { Maybe String }+> : spec_prec id { Just $2 }+> | { Nothing }++> tokInfos :: { [Directive String] } +> : tokInfos tokInfo { $2 : $1 }+> | tokInfo { [$1] }++> tokInfo :: { Directive String } +> : spec_tokentype code { TokenType $2 }+> | spec_token tokenSpecs { TokenSpec $2 }+> | spec_name id optStart { TokenName $2 $3 False }+> | spec_partial id optStart { TokenName $2 $3 True }+> | spec_imported_identity { TokenImportedIdentity }+> | spec_lexer code code { TokenLexer $2 $3 }+> | spec_monad code { TokenMonad "()" $2 ">>=" "return" }+> | spec_monad code code { TokenMonad $2 $3 ">>=" "return" }+> | spec_monad code code code { TokenMonad "()" $2 $3 $4 }+> | spec_monad code code code code { TokenMonad $2 $3 $4 $5 }+> | spec_nonassoc ids { TokenNonassoc $2 }+> | spec_right ids { TokenRight $2 }+> | spec_left ids { TokenLeft $2 }+> | spec_expect int { TokenExpect $2 }+> | spec_error code { TokenError $2 }+> | spec_attributetype code { TokenAttributetype $2 }+> | spec_attribute id code { TokenAttribute $2 $3 }++> optStart :: { Maybe String }+> : id { Just $1 }+> | {- nothing -} { Nothing }++> tokenSpecs :: { [(String,String)] }+> : tokenSpec tokenSpecs { $1:$2 }+> | tokenSpec { [$1] }++> tokenSpec :: { (String,String) }+> : id code { ($1,$2) }++> ids :: { [String] }+> : id ids { $1 : $2 }+> | {- nothing -} { [] }++> optCode :: { Maybe String }+> : code { Just $1 }+> | {- nothing -} { Nothing }++> {+> happyError :: P a+> happyError = lineP >>= \l -> fail (show l ++ ": Parse error\n")+> }
+ src/ProduceCode.lhs view
@@ -0,0 +1,1211 @@+-----------------------------------------------------------------------------+The code generator.++(c) 1993-2001 Andy Gill, Simon Marlow+-----------------------------------------------------------------------------++> module ProduceCode (produceParser) where++-- > import Paths_happy ( version )+-- > import Data.Version ( showVersion )++> import Grammar+> import Target ( Target(..) )+> import GenUtils ( mapDollarDollar, str, char, nl, strspace,+> interleave, interleave', maybestr, +> brack, brack' )++> import Data.Maybe ( isJust, isNothing )+> import Data.Char+> import Data.List++> import Control.Monad.ST+> import Data.Array.ST ( STUArray )+> import Data.Array.Unboxed ( UArray )+> import Data.Array.MArray+> import Data.Array.IArray ++%-----------------------------------------------------------------------------+Produce the complete output file.++> produceParser :: Grammar -- grammar info+> -> ActionTable -- action table+> -> GotoTable -- goto table+> -> String -- stuff to go at the top+> -> Maybe String -- module header+> -> Maybe String -- module trailer+> -> Target -- type of code required+> -> Bool -- use coercions+> -> Bool -- use ghc extensions+> -> Bool -- strict parser+> -> String++> produceParser (Grammar +> { productions = prods+> , non_terminals = nonterms+> , terminals = terms+> , types = nt_types+> , first_nonterm = first_nonterm'+> , eof_term = eof+> , first_term = fst_term+> , lexer = lexer'+> , imported_identity = imported_identity'+> , monad = (use_monad,monad_context,monad_tycon,monad_then,monad_return)+> , token_specs = token_rep+> , token_type = token_type'+> , starts = starts'+> , error_handler = error_handler'+> , attributetype = attributetype'+> , attributes = attributes'+> })+> action goto top_options module_header module_trailer +> target coerce ghc strict+> = ( top_opts+> . maybestr module_header . nl+> . str comment+> -- comment goes *after* the module header, so that we+> -- don't screw up any OPTIONS pragmas in the header.+> . produceAbsSynDecl . nl+> . produceTypes+> . produceActionTable target+> . produceReductions+> . produceTokenConverter . nl+> . produceIdentityStuff+> . produceMonadStuff+> . produceEntries+> . produceStrict strict+> . produceAttributes attributes' attributetype' . nl+> . maybestr module_trailer . nl+> ) ""+> where+> n_starts = length starts'+> token = brack token_type'+>+> nowarn_opts = str "{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}" . nl+>+> top_opts = nowarn_opts .+> case top_options of+> "" -> str ""+> _ -> str (unwords [ "{-# OPTIONS"+> , top_options+> , "#-}"+> ]) . nl++%-----------------------------------------------------------------------------+Make the abstract syntax type declaration, of the form:++data HappyAbsSyn a t1 .. tn+ = HappyTerminal a+ | HappyAbsSyn1 t1+ ...+ | HappyAbsSynn tn++> produceAbsSynDecl ++If we're using coercions, we need to generate the injections etc.++ data HappyAbsSyn ti tj tk ... = HappyAbsSyn++(where ti, tj, tk are type variables for the non-terminals which don't+ have type signatures).++ happyIn<n> :: ti -> HappyAbsSyn ti tj tk ...+ happyIn<n> x = unsafeCoerce# x+ {-# INLINE happyIn<n> #-}++ happyOut<n> :: HappyAbsSyn ti tj tk ... -> tn+ happyOut<n> x = unsafeCoerce# x+ {-# INLINE happyOut<n> #-}++> | coerce +> = let+> happy_item = str "HappyAbsSyn " . str_tyvars+> bhappy_item = brack' happy_item+>+> inject n ty+> = mkHappyIn n . str " :: " . type_param n ty+> . str " -> " . bhappy_item . char '\n'+> . mkHappyIn n . str " x = Happy_GHC_Exts.unsafeCoerce# x\n"+> . str "{-# INLINE " . mkHappyIn n . str " #-}"+>+> extract n ty+> = mkHappyOut n . str " :: " . bhappy_item+> . str " -> " . type_param n ty . char '\n'+> . mkHappyOut n . str " x = Happy_GHC_Exts.unsafeCoerce# x\n"+> . str "{-# INLINE " . mkHappyOut n . str " #-}"+> in+> str "newtype " . happy_item . str " = HappyAbsSyn HappyAny\n" -- see NOTE below+> . interleave "\n" (map str+> [ "#if __GLASGOW_HASKELL__ >= 607",+> "type HappyAny = Happy_GHC_Exts.Any",+> "#else",+> "type HappyAny = forall a . a",+> "#endif" ])+> . interleave "\n" +> [ inject n ty . nl . extract n ty | (n,ty) <- assocs nt_types ]+> -- token injector+> . str "happyInTok :: " . token . str " -> " . bhappy_item+> . str "\nhappyInTok x = Happy_GHC_Exts.unsafeCoerce# x\n{-# INLINE happyInTok #-}\n"+> -- token extractor+> . str "happyOutTok :: " . bhappy_item . str " -> " . token+> . str "\nhappyOutTok x = Happy_GHC_Exts.unsafeCoerce# x\n{-# INLINE happyOutTok #-}\n"++> . str "\n"++NOTE: in the coerce case we always coerce all the semantic values to+HappyAbsSyn which is declared to be a synonym for Any. This is the+type that GHC officially knows nothing about - it's the same type used+to implement Dynamic. (in GHC 6.6 and older, Any didn't exist, so we+use the closest approximation namely forall a . a). ++It's vital that GHC doesn't know anything about this type, because it+will use any knowledge it has to optimise, and if the knowledge is+false then the optimisation may also be false. Previously we used (()+-> ()) as the type here, but this led to bogus optimisations (see GHC+ticket #1616).++Also, note that we must use a newtype instead of just a type synonym,+because the otherwise the type arguments to the HappyAbsSyn type+constructor will lose information. See happy/tests/bug001 for an+example where this matters.++... Otherwise, output the declaration in full...++> | otherwise+> = str "data HappyAbsSyn " . str_tyvars+> . str "\n\t= HappyTerminal " . token+> . str "\n\t| HappyErrorToken Int\n"+> . interleave "\n" +> [ str "\t| " . makeAbsSynCon n . strspace . type_param n ty+> | (n, ty) <- assocs nt_types, +> (nt_types_index ! n) == n]++> where all_tyvars = [ 't':show n | (n, Nothing) <- assocs nt_types ]+> str_tyvars = str (unwords all_tyvars)++%-----------------------------------------------------------------------------+Type declarations of the form:++type HappyReduction a b = ....+action_0, action_1 :: Int -> HappyReduction a b +reduction_1, ... :: HappyReduction a b ++These are only generated if types for *all* rules are given (and not for array+based parsers -- types aren't as important there).++> produceTypes +> | target == TargetArrayBased = id++> | all isJust (elems nt_types) =+> happyReductionDefinition . str "\n\n"+> . interleave' ",\n " +> [ mkActionName i | (i,_action') <- zip [ 0 :: Int .. ]+> (assocs action) ]+> . str " :: " . str monad_context . str " => "+> . intMaybeHash . str " -> " . happyReductionValue . str "\n\n"+> . interleave' ",\n " +> [ mkReduceFun i | +> (i,_action) <- zip [ n_starts :: Int .. ]+> (drop n_starts prods) ]+> . str " :: " . str monad_context . str " => "+> . happyReductionValue . str "\n\n"++> | otherwise = id++> where intMaybeHash | ghc = str "Happy_GHC_Exts.Int#"+> | otherwise = str "Int"+> tokens = +> case lexer' of+> Nothing -> char '[' . token . str "] -> "+> Just _ -> id+> happyReductionDefinition =+> str "{- to allow type-synonyms as our monads (likely\n"+> . str " - with explicitly-specified bind and return)\n"+> . str " - in Haskell98, it seems that with\n"+> . str " - /type M a = .../, then /(HappyReduction M)/\n"+> . str " - is not allowed. But Happy is a\n"+> . str " - code-generator that can just substitute it.\n"+> . str "type HappyReduction m = "+> . happyReduction (str "m")+> . str "\n-}"+> happyReductionValue =+> str "({-"+> . str "HappyReduction "+> . brack monad_tycon+> . str " = -}"+> . happyReduction (brack monad_tycon)+> . str ")"+> happyReduction m =+> str "\n\t "+> . intMaybeHash+> . str " \n\t-> " . token+> . str "\n\t-> HappyState "+> . token+> . str " (HappyStk HappyAbsSyn -> " . tokens . result+> . str ")\n\t"+> . str "-> [HappyState "+> . token+> . str " (HappyStk HappyAbsSyn -> " . tokens . result+> . str ")] \n\t-> HappyStk HappyAbsSyn \n\t-> "+> . tokens+> . result+> where result = m . str " HappyAbsSyn"++%-----------------------------------------------------------------------------+Next, the reduction functions. Each one has the following form:++happyReduce_n_m = happyReduce n m reduction where {+ reduction (+ (HappyAbsSynX | HappyTerminal) happy_var_1 :+ ..+ (HappyAbsSynX | HappyTerminal) happy_var_q :+ happyRest)+ = HappyAbsSynY+ ( <<user supplied string>> ) : happyRest+ ; reduction _ _ = notHappyAtAll n m++where n is the non-terminal number, and m is the rule number.++NOTES on monad productions. These look like++ happyReduce_275 = happyMonadReduce 0# 119# happyReduction_275+ happyReduction_275 (happyRest)+ = happyThen (code) (\r -> happyReturn (HappyAbsSyn r))++why can't we pass the HappyAbsSyn constructor to happyMonadReduce and+save duplicating the happyThen/happyReturn in each monad production?+Because this would require happyMonadReduce to be polymorphic in the+result type of the monadic action, and since in array-based parsers+the whole thing is one recursive group, we'd need a type signature on+happyMonadReduce to get polymorphic recursion. Sigh.++> produceReductions =+> interleave "\n\n" +> (zipWith produceReduction (drop n_starts prods) [ n_starts .. ])++> produceReduction (nt, toks, (code,vars_used), _) i++> | is_monad_prod && (use_monad || imported_identity')+> = mkReductionHdr (showInt lt) monad_reduce+> . char '(' . interleave " `HappyStk`\n\t" tokPatterns+> . str "happyRest) tk\n\t = happyThen ("+> . tokLets (char '(' . str code' . char ')')+> . (if monad_pass_token then str " tk" else id)+> . str "\n\t) (\\r -> happyReturn (" . this_absSynCon . str " r))"++> | specReduceFun lt+> = mkReductionHdr id ("happySpecReduce_" ++ show lt)+> . interleave "\n\t" tokPatterns+> . str " = "+> . tokLets (+> this_absSynCon . str "\n\t\t " +> . char '(' . str code' . str "\n\t)"+> )+> . (if coerce || null toks || null vars_used then+> id+> else+> nl . reductionFun . strspace+> . interleave " " (map str (take (length toks) (repeat "_")))+> . str " = notHappyAtAll ")++> | otherwise+> = mkReductionHdr (showInt lt) "happyReduce"+> . char '(' . interleave " `HappyStk`\n\t" tokPatterns+> . str "happyRest)\n\t = "+> . tokLets+> ( this_absSynCon . str "\n\t\t " +> . char '(' . str code'. str "\n\t) `HappyStk` happyRest"+> )++> where +> (code', is_monad_prod, monad_pass_token, monad_reduce) +> = case code of +> '%':'%':code1 -> (code1, True, True, "happyMonad2Reduce")+> '%':'^':code1 -> (code1, True, True, "happyMonadReduce")+> '%':code1 -> (code1, True, False, "happyMonadReduce")+> _ -> (code, False, False, "")++> -- adjust the nonterminal number for the array-based parser+> -- so that nonterminals start at zero.+> adjusted_nt | target == TargetArrayBased = nt - first_nonterm'+> | otherwise = nt+>+> mkReductionHdr lt' s = +> mkReduceFun i . str " = "+> . str s . strspace . lt' . strspace . showInt adjusted_nt+> . strspace . reductionFun . nl +> . reductionFun . strspace+> +> reductionFun = str "happyReduction_" . shows i+>+> tokPatterns +> | coerce = reverse (map mkDummyVar [1 .. length toks])+> | otherwise = reverse (zipWith tokPattern [1..] toks)+> +> tokPattern n _ | n `notElem` vars_used = char '_'+> tokPattern n t | t >= firstStartTok && t < fst_term+> = if coerce +> then mkHappyVar n+> else brack' (+> makeAbsSynCon t . str " " . mkHappyVar n+> )+> tokPattern n t+> = if coerce+> then mkHappyTerminalVar n t+> else str "(HappyTerminal " +> . mkHappyTerminalVar n t+> . char ')'+> +> tokLets code''+> | coerce && not (null cases) +> = interleave "\n\t" cases+> . code'' . str (take (length cases) (repeat '}'))+> | otherwise = code''+>+> cases = [ str "case " . extract t . strspace . mkDummyVar n+> . str " of { " . tokPattern n t . str " -> "+> | (n,t) <- zip [1..] toks,+> n `elem` vars_used ]+>+> extract t | t >= firstStartTok && t < fst_term = mkHappyOut t+> | otherwise = str "happyOutTok"+>+> lt = length toks++> this_absSynCon | coerce = mkHappyIn nt+> | otherwise = makeAbsSynCon nt++%-----------------------------------------------------------------------------+The token conversion function.++> produceTokenConverter+> = case lexer' of { +> +> Nothing ->+> str "happyNewToken action sts stk [] =\n\t"+> . eofAction "notHappyAtAll"+> . str " []\n\n"+> . str "happyNewToken action sts stk (tk:tks) =\n\t"+> . str "let cont i = " . doAction . str " sts stk tks in\n\t"+> . str "case tk of {\n\t"+> . interleave ";\n\t" (map doToken token_rep)+> . str "_ -> happyError' (tk:tks)\n\t"+> . str "}\n\n"+> . str "happyError_ tk tks = happyError' (tk:tks)\n";++> Just (lexer'',eof') ->+> str "happyNewToken action sts stk\n\t= "+> . str lexer''+> . str "(\\tk -> "+> . str "\n\tlet cont i = "+> . doAction+> . str " sts stk in\n\t"+> . str "case tk of {\n\t"+> . str (eof' ++ " -> ")+> . eofAction "tk" . str ";\n\t"+> . interleave ";\n\t" (map doToken token_rep)+> . str "_ -> happyError' tk\n\t"+> . str "})\n\n"+> . str "happyError_ tk = happyError' tk\n";+> }++> where ++> eofAction tk =+> (case target of+> TargetArrayBased ->+> str "happyDoAction " . eofTok . strspace . str tk . str " action"+> _ -> str "action " . eofTok . strspace . eofTok+> . strspace . str tk . str " (HappyState action)")+> . str " sts stk"+> eofTok = showInt (tokIndex eof)+> +> doAction = case target of+> TargetArrayBased -> str "happyDoAction i tk action"+> _ -> str "action i i tk (HappyState action)"+> +> doToken (i,tok) +> = str (removeDollarDollar tok)+> . str " -> cont " +> . showInt (tokIndex i)++Use a variable rather than '_' to replace '$$', so we can use it on+the left hand side of '@'.++> removeDollarDollar xs = case mapDollarDollar xs of+> Nothing -> xs+> Just fn -> fn "happy_dollar_dollar"++> mkHappyTerminalVar :: Int -> Int -> String -> String+> mkHappyTerminalVar i t = +> case tok_str_fn of+> Nothing -> pat +> Just fn -> brack (fn (pat []))+> where+> tok_str_fn = case lookup t token_rep of+> Nothing -> Nothing+> Just str' -> mapDollarDollar str'+> pat = mkHappyVar i++> tokIndex +> = case target of+> TargetHaskell -> id+> TargetArrayBased -> \i -> i - n_nonterminals - n_starts - 2+> -- tokens adjusted to start at zero, see ARRAY_NOTES++%-----------------------------------------------------------------------------+Action Tables.++Here we do a bit of trickery and replace the normal default action+(failure) for each state with at least one reduction action. For each+such state, we pick one reduction action to be the default action.+This should make the code smaller without affecting the speed. It+changes the sematics for errors, however; errors could be detected in+a different state now (but they'll still be detected at the same point+in the token stream).++Further notes on default cases:++Default reductions are important when error recovery is considered: we+don't allow reductions whilst in error recovery, so we'd like the+parser to automatically reduce down to a state where the error token+can be shifted before entering error recovery. This is achieved by+using default reductions wherever possible.++One case to consider is:++State 345++ con -> conid . (rule 186)+ qconid -> conid . (rule 212)++ error reduce using rule 212+ '{' reduce using rule 186+ etc.++we should make reduce_212 the default reduction here. So the rules become:++ * if there is a production + error -> reduce_n+ then make reduce_n the default action.+ * if there is a non-reduce action for the error token, the default action+ for this state must be "fail".+ * otherwise pick the most popular reduction in this state for the default.+ * if there are no reduce actions in this state, then the default+ action remains 'enter error recovery'.++This gives us an invariant: there won't ever be a production of the+type 'error -> reduce_n' explicitly in the grammar, which means that+whenever an unexpected token occurs, either the parser will reduce+straight back to a state where the error token can be shifted, or if+none exists, we'll get a parse error. In theory, we won't need the+machinery to discard states in the parser...++> produceActionTable TargetHaskell +> = foldr (.) id (map (produceStateFunction goto) (assocs action))+> +> produceActionTable TargetArrayBased+> = produceActionArray+> . produceReduceArray+> . str "happy_n_terms = " . shows n_terminals . str " :: Int\n"+> . str "happy_n_nonterms = " . shows n_nonterminals . str " :: Int\n\n"++> produceStateFunction goto' (state, acts)+> = foldr (.) id (map produceActions assocs_acts)+> . foldr (.) id (map produceGotos (assocs gotos))+> . mkActionName state+> . (if ghc+> then str " x = happyTcHack x "+> else str " _ = ")+> . mkAction default_act+> . str "\n\n"+>+> where gotos = goto' ! state+> +> produceActions (_, LR'Fail{-'-}) = id+> produceActions (t, action'@(LR'Reduce{-'-} _ _))+> | action' == default_act = id+> | otherwise = actionFunction t+> . mkAction action' . str "\n"+> produceActions (t, action')+> = actionFunction t+> . mkAction action' . str "\n"+> +> produceGotos (t, Goto i)+> = actionFunction t+> . str "happyGoto " . mkActionName i . str "\n"+> produceGotos (_, NoGoto) = id+> +> actionFunction t+> = mkActionName state . strspace+> . ('(' :) . showInt t+> . str ") = "+> +> default_act = getDefault assocs_acts+>+> assocs_acts = assocs acts++action array indexed by (terminal * last_state) + state++> produceActionArray+> | ghc+> = str "happyActOffsets :: HappyAddr\n"+> . str "happyActOffsets = HappyA# \"" --"+> . str (hexChars act_offs)+> . str "\"#\n\n" --"+> +> . str "happyGotoOffsets :: HappyAddr\n"+> . str "happyGotoOffsets = HappyA# \"" --"+> . str (hexChars goto_offs)+> . str "\"#\n\n" --"+>+> . str "happyDefActions :: HappyAddr\n"+> . str "happyDefActions = HappyA# \"" --"+> . str (hexChars defaults)+> . str "\"#\n\n" --"+> +> . str "happyCheck :: HappyAddr\n"+> . str "happyCheck = HappyA# \"" --"+> . str (hexChars check)+> . str "\"#\n\n" --"+> +> . str "happyTable :: HappyAddr\n"+> . str "happyTable = HappyA# \"" --"+> . str (hexChars table)+> . str "\"#\n\n" --"++> | otherwise+> = str "happyActOffsets :: Happy_Data_Array.Array Int Int\n"+> . str "happyActOffsets = Happy_Data_Array.listArray (0,"+> . shows (n_states) . str ") (["+> . interleave' "," (map shows act_offs)+> . str "\n\t])\n\n"+> +> . str "happyGotoOffsets :: Happy_Data_Array.Array Int Int\n"+> . str "happyGotoOffsets = Happy_Data_Array.listArray (0,"+> . shows (n_states) . str ") (["+> . interleave' "," (map shows goto_offs)+> . str "\n\t])\n\n"+> +> . str "happyDefActions :: Happy_Data_Array.Array Int Int\n"+> . str "happyDefActions = Happy_Data_Array.listArray (0,"+> . shows (n_states) . str ") (["+> . interleave' "," (map shows defaults)+> . str "\n\t])\n\n"+> +> . str "happyCheck :: Happy_Data_Array.Array Int Int\n"+> . str "happyCheck = Happy_Data_Array.listArray (0,"+> . shows table_size . str ") (["+> . interleave' "," (map shows check)+> . str "\n\t])\n\n"+> +> . str "happyTable :: Happy_Data_Array.Array Int Int\n"+> . str "happyTable = Happy_Data_Array.listArray (0,"+> . shows table_size . str ") (["+> . interleave' "," (map shows table)+> . str "\n\t])\n\n"+> +> (_, last_state) = bounds action+> n_states = last_state + 1+> n_terminals = length terms+> n_nonterminals = length nonterms - n_starts -- lose %starts+>+> (act_offs,goto_offs,table,defaults,check) +> = mkTables action goto first_nonterm' fst_term+> n_terminals n_nonterminals n_starts+>+> table_size = length table - 1+>+> produceReduceArray+> = {- str "happyReduceArr :: Array Int a\n" -}+> str "happyReduceArr = Happy_Data_Array.array ("+> . shows (n_starts :: Int) -- omit the %start reductions+> . str ", "+> . shows n_rules+> . str ") [\n"+> . interleave' ",\n" (map reduceArrElem [n_starts..n_rules])+> . str "\n\t]\n\n"++> n_rules = length prods - 1 :: Int++> showInt i | ghc = shows i . showChar '#'+> | otherwise = shows i++This lets examples like:++ data HappyAbsSyn t1+ = HappyTerminal ( HaskToken )+ | HappyAbsSyn1 ( HaskExp )+ | HappyAbsSyn2 ( HaskExp )+ | HappyAbsSyn3 t1++*share* the defintion for ( HaskExp )++ data HappyAbsSyn t1+ = HappyTerminal ( HaskToken )+ | HappyAbsSyn1 ( HaskExp )+ | HappyAbsSyn3 t1++... cuting down on the work that the type checker has to do.++Note, this *could* introduce lack of polymophism,+for types that have alphas in them. Maybe we should+outlaw them inside { }++> nt_types_index :: Array Int Int+> nt_types_index = array (bounds nt_types) +> [ (a, fn a b) | (a, b) <- assocs nt_types ]+> where+> fn n Nothing = n+> fn _ (Just a) = case lookup a assoc_list of+> Just v -> v+> Nothing -> error ("cant find an item in list")+> assoc_list = [ (b,a) | (a, Just b) <- assocs nt_types ]++> makeAbsSynCon = mkAbsSynCon nt_types_index+++> produceIdentityStuff | use_monad = id+> | imported_identity' =+> str "type HappyIdentity = Identity\n"+> . str "happyIdentity = Identity\n"+> . str "happyRunIdentity = runIdentity\n\n"+> | otherwise =+> str "newtype HappyIdentity a = HappyIdentity a\n"+> . str "happyIdentity = HappyIdentity\n"+> . str "happyRunIdentity (HappyIdentity a) = a\n\n"+> . str "instance Monad HappyIdentity where\n"+> . str " return = HappyIdentity\n"+> . str " (HappyIdentity p) >>= q = q p\n\n"++MonadStuff:++ - with no %monad or %lexer:++ happyThen :: () => HappyIdentity a -> (a -> HappyIdentity b) -> HappyIdentity b+ happyReturn :: () => a -> HappyIdentity a+ happyThen1 m k tks = happyThen m (\a -> k a tks)+ happyReturn1 = \a tks -> happyReturn a++ - with %monad:++ happyThen :: CONTEXT => P a -> (a -> P b) -> P b+ happyReturn :: CONTEXT => a -> P a+ happyThen1 m k tks = happyThen m (\a -> k a tks)+ happyReturn1 = \a tks -> happyReturn a++ - with %monad & %lexer:++ happyThen :: CONTEXT => P a -> (a -> P b) -> P b+ happyReturn :: CONTEXT => a -> P a+ happyThen1 = happyThen+ happyReturn1 = happyReturn+++> produceMonadStuff =+> let pcont = str monad_context in+> let pty = str monad_tycon in+> str "happyThen :: " . pcont . str " => " . pty+> . str " a -> (a -> " . pty+> . str " b) -> " . pty . str " b\n"+> . str "happyThen = " . brack monad_then . nl+> . str "happyReturn :: " . pcont . str " => a -> " . pty . str " a\n"+> . str "happyReturn = " . brack monad_return . nl+> . case lexer' of+> Nothing ->+> str "happyThen1 m k tks = (" . str monad_then +> . str ") m (\\a -> k a tks)\n"+> . str "happyReturn1 :: " . pcont . str " => a -> b -> " . pty . str " a\n"+> . str "happyReturn1 = \\a tks -> " . brack monad_return+> . str " a\n"+> . str "happyError' :: " . str monad_context . str " => ["+> . token+> . str "] -> "+> . str monad_tycon+> . str " a\n"+> . str "happyError' = "+> . str (if use_monad then "" else "HappyIdentity . ")+> . errorHandler+> . str "\n\n"+> _ ->+> str "happyThen1 = happyThen\n"+> . str "happyReturn1 :: " . pcont . str " => a -> " . pty . str " a\n"+> . str "happyReturn1 = happyReturn\n"+> . str "happyError' :: " . str monad_context . str " => "+> . token . str " -> " +> . str monad_tycon+> . str " a\n"+> . str "happyError' tk = "+> . str (if use_monad then "" else "HappyIdentity ")+> . errorHandler . str " tk\n"+> . str "\n"++An error handler specified with %error is passed the current token+when used with %lexer, but happyError (the old way but kept for+compatibility) is not passed the current token.++> errorHandler = +> case error_handler' of+> Just h -> str h+> Nothing -> case lexer' of +> Nothing -> str "happyError"+> Just _ -> str "(\\token -> happyError)"++> reduceArrElem n+> = str "\t(" . shows n . str " , "+> . str "happyReduce_" . shows n . char ')'++-----------------------------------------------------------------------------+-- Produce the parser entry and exit points++> produceEntries+> = interleave "\n\n" (map produceEntry (zip starts' [0..]))+> . if null attributes' then id else produceAttrEntries starts'++> produceEntry ((name, _start_nonterm, accept_nonterm, _partial), no)+> = (if null attributes' then str name else str "do_" . str name)+> . maybe_tks+> . str " = "+> . str unmonad+> . str "happySomeParser where\n"+> . str " happySomeParser = happyThen (happyParse "+> . case target of+> TargetHaskell -> str "action_" . shows no+> TargetArrayBased+> | ghc -> shows no . str "#"+> | otherwise -> shows no +> . maybe_tks+> . str ") "+> . brack' (if coerce +> then str "\\x -> happyReturn (happyOut" +> . shows accept_nonterm . str " x)"+> else str "\\x -> case x of {HappyAbsSyn" +> . shows (nt_types_index ! accept_nonterm)+> . str " z -> happyReturn z; _other -> notHappyAtAll }"+> )+> where+> maybe_tks | isNothing lexer' = str " tks"+> | otherwise = id+> unmonad | use_monad = ""+> | otherwise = "happyRunIdentity "++> produceAttrEntries starts''+> = interleave "\n\n" (map f starts'')+> where+> f = case (use_monad,lexer') of+> (True,Just _) -> \(name,_,_,_) -> monadAndLexerAE name+> (True,Nothing) -> \(name,_,_,_) -> monadAE name+> (False,Just _) -> error "attribute grammars not supported for non-monadic parsers with %lexer"+> (False,Nothing)-> \(name,_,_,_) -> regularAE name+>+> defaultAttr = fst (head attributes')+>+> monadAndLexerAE name+> = str name . str " = " +> . str "do { "+> . str "f <- do_" . str name . str "; "+> . str "let { (conds,attrs) = f happyEmptyAttrs } in do { "+> . str "sequence_ conds; "+> . str "return (". str defaultAttr . str " attrs) }}"+> monadAE name+> = str name . str " toks = "+> . str "do { "+> . str "f <- do_" . str name . str " toks; "+> . str "let { (conds,attrs) = f happyEmptyAttrs } in do { "+> . str "sequence_ conds; "+> . str "return (". str defaultAttr . str " attrs) }}"+> regularAE name+> = str name . str " toks = "+> . str "let { "+> . str "f = do_" . str name . str " toks; "+> . str "(conds,attrs) = f happyEmptyAttrs; "+> . str "x = foldr seq attrs conds; "+> . str "} in (". str defaultAttr . str " x)"++----------------------------------------------------------------------------+-- Produce attributes declaration for attribute grammars++> produceAttributes :: [(String, String)] -> String -> String -> String+> produceAttributes [] _ = id+> produceAttributes attrs attributeType +> = str "data " . attrHeader . str " = HappyAttributes {" . attributes' . str "}" . nl+> . str "happyEmptyAttrs = HappyAttributes {" . attrsErrors . str "}" . nl++> where attributes' = foldl1 (\x y -> x . str ", " . y) $ map formatAttribute attrs+> formatAttribute (ident,typ) = str ident . str " :: " . str typ+> attrsErrors = foldl1 (\x y -> x . str ", " . y) $ map attrError attrs+> attrError (ident,_) = str ident . str " = error \"invalid reference to attribute '" . str ident . str "'\""+> attrHeader =+> case attributeType of+> [] -> str "HappyAttributes"+> _ -> str attributeType+++-----------------------------------------------------------------------------+-- Strict or non-strict parser++> produceStrict :: Bool -> String -> String+> produceStrict strict+> | strict = str "happySeq = happyDoSeq\n\n"+> | otherwise = str "happySeq = happyDontSeq\n\n"++-----------------------------------------------------------------------------+Replace all the $n variables with happy_vars, and return a list of all the+vars used in this piece of code.++> actionVal :: LRAction -> Int+> actionVal (LR'Shift state _) = state + 1+> actionVal (LR'Reduce rule _) = -(rule + 1)+> actionVal LR'Accept = -1+> actionVal (LR'Multiple _ a) = actionVal a+> actionVal LR'Fail = 0+> actionVal LR'MustFail = 0++> mkAction :: LRAction -> String -> String+> mkAction (LR'Shift i _) = str "happyShift " . mkActionName i+> mkAction LR'Accept = str "happyAccept"+> mkAction LR'Fail = str "happyFail"+> mkAction LR'MustFail = str "happyFail"+> mkAction (LR'Reduce i _) = str "happyReduce_" . shows i+> mkAction (LR'Multiple _ a) = mkAction a++> mkActionName :: Int -> String -> String+> mkActionName i = str "action_" . shows i++See notes under "Action Tables" above for some subtleties in this function.++> getDefault :: [(Name, LRAction)] -> LRAction+> getDefault actions =+> -- pick out the action for the error token, if any+> case [ act | (e, act) <- actions, e == errorTok ] of+>+> -- use error reduction as the default action, if there is one.+> act@(LR'Reduce _ _) : _ -> act+> act@(LR'Multiple _ (LR'Reduce _ _)) : _ -> act+>+> -- if the error token is shifted or otherwise, don't generate+> -- a default action. This is *important*!+> (act : _) | act /= LR'Fail -> LR'Fail+>+> -- no error actions, pick a reduce to be the default.+> _ -> case reduces of+> [] -> LR'Fail+> (act:_) -> act -- pick the first one we see for now+>+> where reduces +> = [ act | (_,act@(LR'Reduce _ _)) <- actions ]+> ++ [ act | (_,(LR'Multiple _ act@(LR'Reduce _ _))) <- actions ]++-----------------------------------------------------------------------------+-- Generate packed parsing tables.++-- happyActOff ! state+-- Offset within happyTable of actions for state++-- happyGotoOff ! state+-- Offset within happyTable of gotos for state++-- happyTable+-- Combined action/goto table++-- happyDefAction ! state+-- Default action for state++-- happyCheck+-- Indicates whether we should use the default action for state+++-- the table is laid out such that the action for a given state & token+-- can be found by:+--+-- off = happyActOff ! state+-- off_i = off + token+-- check | off_i => 0 = (happyCheck ! off_i) == token+-- | otherwise = False+-- action | check = happyTable ! off_i+-- | otherwise = happyDefAaction ! off_i+++-- figure out the default action for each state. This will leave some+-- states with no *real* actions left.++-- for each state with one or more real actions, sort states by+-- width/spread of tokens with real actions, then by number of+-- elements with actions, so we get the widest/densest states+-- first. (I guess the rationale here is that we can use the+-- thin/sparse states to fill in the holes later, and also we+-- have to do less searching for the more complicated cases).++-- try to pair up states with identical sets of real actions.++-- try to fit the actions into the check table, using the ordering+-- from above.+++> mkTables +> :: ActionTable -> GotoTable -> Name -> Int -> Int -> Int -> Int ->+> ([Int] -- happyActOffsets+> ,[Int] -- happyGotoOffsets+> ,[Int] -- happyTable+> ,[Int] -- happyDefAction+> ,[Int] -- happyCheck+> )+>+> mkTables action goto first_nonterm' fst_term +> n_terminals n_nonterminals n_starts+> = ( elems act_offs, +> elems goto_offs, +> take max_off (elems table),+> def_actions, +> take max_off (elems check)+> )+> where +>+> (table,check,act_offs,goto_offs,max_off) +> = runST (genTables (length actions) max_token sorted_actions)+> +> -- the maximum token number used in the parser+> max_token = max n_terminals (n_starts+n_nonterminals) - 1+>+> def_actions = map (\(_,_,def,_,_,_) -> def) actions+>+> actions :: [TableEntry]+> actions = +> [ (ActionEntry,+> state,+> actionVal default_act,+> if null acts'' then 0 +> else fst (last acts'') - fst (head acts''),+> length acts'',+> acts'')+> | (state, acts) <- assocs action,+> let (err:_dummy:vec) = assocs acts+> vec' = drop (n_starts+n_nonterminals) vec+> acts' = filter (notFail) (err:vec')+> default_act = getDefault acts'+> acts'' = mkActVals acts' default_act+> ]+>+> -- adjust terminals by -(fst_term+1), so they start at 1 (error is 0).+> -- (see ARRAY_NOTES)+> adjust token | token == errorTok = 0+> | otherwise = token - fst_term + 1+>+> mkActVals assocs' default_act =+> [ (adjust token, actionVal act) +> | (token, act) <- assocs'+> , act /= default_act ]+>+> gotos :: [TableEntry]+> gotos = [ (GotoEntry,+> state, 0, +> if null goto_vals then 0 +> else fst (last goto_vals) - fst (head goto_vals),+> length goto_vals,+> goto_vals+> )+> | (state, goto_arr) <- assocs goto,+> let goto_vals = mkGotoVals (assocs goto_arr)+> ]+>+> -- adjust nonterminals by -first_nonterm', so they start at zero+> -- (see ARRAY_NOTES)+> mkGotoVals assocs' =+> [ (token - first_nonterm', i) | (token, Goto i) <- assocs' ]+>+> sorted_actions = reverse (sortBy cmp_state (actions++gotos))+> cmp_state (_,_,_,width1,tally1,_) (_,_,_,width2,tally2,_)+> | width1 < width2 = LT+> | width1 == width2 = compare tally1 tally2+> | otherwise = GT++> data ActionOrGoto = ActionEntry | GotoEntry+> type TableEntry = (ActionOrGoto,+> Int{-stateno-},+> Int{-default-},+> Int{-width-},+> Int{-tally-},+> [(Int,Int)])++> genTables+> :: Int -- number of actions+> -> Int -- maximum token no.+> -> [TableEntry] -- entries for the table+> -> ST s (UArray Int Int, -- table+> UArray Int Int, -- check+> UArray Int Int, -- action offsets+> UArray Int Int, -- goto offsets+> Int -- highest offset in table+> )+>+> genTables n_actions max_token entries = do+>+> table <- newArray (0, mAX_TABLE_SIZE) 0+> check <- newArray (0, mAX_TABLE_SIZE) (-1)+> act_offs <- newArray (0, n_actions) 0+> goto_offs <- newArray (0, n_actions) 0+> off_arr <- newArray (-max_token, mAX_TABLE_SIZE) 0+>+> max_off <- genTables' table check act_offs goto_offs +> off_arr entries max_token+>+> table' <- freeze table+> check' <- freeze check+> act_offs' <- freeze act_offs+> goto_offs' <- freeze goto_offs+> return (table',check',act_offs',goto_offs',max_off+1)++> where+> n_states = n_actions - 1+> mAX_TABLE_SIZE = n_states * (max_token + 1)+++> genTables'+> :: STUArray s Int Int -- table+> -> STUArray s Int Int -- check+> -> STUArray s Int Int -- action offsets+> -> STUArray s Int Int -- goto offsets+> -> STUArray s Int Int -- offset array+> -> [TableEntry] -- entries for the table+> -> Int -- maximum token no.+> -> ST s Int -- highest offset in table+>+> genTables' table check act_offs goto_offs off_arr entries max_token+> = fit_all entries 0 1+> where+>+> fit_all [] max_off _ = return max_off+> fit_all (s:ss) max_off fst_zero = do+> (off, new_max_off, new_fst_zero) <- fit s max_off fst_zero+> ss' <- same_states s ss off+> writeArray off_arr off 1+> fit_all ss' new_max_off new_fst_zero+>+> -- try to merge identical states. We only try the next state(s)+> -- in the list, but the list is kind-of sorted so we shouldn't+> -- miss too many.+> same_states _ [] _ = return []+> same_states s@(_,_,_,_,_,acts) ss@((e,no,_,_,_,acts'):ss') off+> | acts == acts' = do writeArray (which_off e) no off+> same_states s ss' off+> | otherwise = return ss+> +> which_off ActionEntry = act_offs+> which_off GotoEntry = goto_offs+>+> -- fit a vector into the table. Return the offset of the vector,+> -- the maximum offset used in the table, and the offset of the first+> -- entry in the table (used to speed up the lookups a bit).+> fit (_,_,_,_,_,[]) max_off fst_zero = return (0,max_off,fst_zero)+>+> fit (act_or_goto, state_no, _deflt, _, _, state@((t,_):_))+> max_off fst_zero = do+> -- start at offset 1 in the table: all the empty states+> -- (states with just a default reduction) are mapped to+> -- offset zero.+> off <- findFreeOffset (-t+fst_zero) check off_arr state+> let new_max_off | furthest_right > max_off = furthest_right+> | otherwise = max_off+> furthest_right = off + max_token+>+> -- trace ("fit: state " ++ show state_no ++ ", off " ++ show off ++ ", elems " ++ show state) $ do+>+> writeArray (which_off act_or_goto) state_no off+> addState off table check state+> new_fst_zero <- findFstFreeSlot check fst_zero+> return (off, new_max_off, new_fst_zero)++When looking for a free offest in the table, we use the 'check' table+rather than the main table. The check table starts off with (-1) in+every slot, because that's the only thing that doesn't overlap with+any tokens (non-terminals start at 0, terminals start at 1). ++Because we use 0 for LR'MustFail as well as LR'Fail, we can't check+for free offsets in the main table because we can't tell whether a+slot is free or not.++> -- Find a valid offset in the table for this state.+> findFreeOffset :: Int -> STUArray s Int Int -> STUArray s Int Int -> [(Int, Int)] -> ST s Int+> findFreeOffset off table off_arr state = do+> -- offset 0 isn't allowed+> if off == 0 then try_next else do+>+> -- don't use an offset we've used before+> b <- readArray off_arr off+> if b /= 0 then try_next else do+>+> -- check whether the actions for this state fit in the table+> ok <- fits off state table+> if not ok then try_next else return off+> where+> try_next = findFreeOffset (off+1) table off_arr state+++> fits :: Int -> [(Int,Int)] -> STUArray s Int Int -> ST s Bool+> fits _ [] _ = return True+> fits off ((t,_):rest) table = do+> i <- readArray table (off+t)+> if i /= -1 then return False+> else fits off rest table++> addState :: Int -> STUArray s Int Int -> STUArray s Int Int -> [(Int, Int)]+> -> ST s ()+> addState _ _ _ [] = return ()+> addState off table check ((t,val):state) = do+> writeArray table (off+t) val+> writeArray check (off+t) t+> addState off table check state++> notFail :: (Int, LRAction) -> Bool+> notFail (_, LR'Fail) = False+> notFail _ = True++> findFstFreeSlot :: STUArray s Int Int -> Int -> ST s Int+> findFstFreeSlot table n = do+> i <- readArray table n+> if i == -1 then return n+> else findFstFreeSlot table (n+1)++-----------------------------------------------------------------------------+-- Misc.++> comment :: String+> comment = +> "-- parser produced by Happy \n\n"++> mkAbsSynCon :: Array Int Int -> Int -> String -> String+> mkAbsSynCon fx t = str "HappyAbsSyn" . shows (fx ! t)++> mkHappyVar, mkReduceFun, mkDummyVar :: Int -> String -> String+> mkHappyVar n = str "happy_var_" . shows n+> mkReduceFun n = str "happyReduce_" . shows n+> mkDummyVar n = str "happy_x_" . shows n++> mkHappyIn, mkHappyOut :: Int -> String -> String+> mkHappyIn n = str "happyIn" . shows n+> mkHappyOut n = str "happyOut" . shows n++> type_param :: Int -> Maybe String -> ShowS+> type_param n Nothing = char 't' . shows n+> type_param _ (Just ty) = brack ty++> specReduceFun :: Int -> Bool+> specReduceFun = (<= 3)++-----------------------------------------------------------------------------+-- Convert an integer to a 16-bit number encoded in \xNN\xNN format suitable+-- for placing in a string.++> hexChars :: [Int] -> String+> hexChars acts = concat (map hexChar acts)++> hexChar :: Int -> String+> hexChar i | i < 0 = hexChar (i + 2^16)+> hexChar i = toHex (i `mod` 256) ++ toHex (i `div` 256)++> toHex :: Int -> String+> toHex i = ['\\','x', hexDig (i `div` 16), hexDig (i `mod` 16)]++> hexDig :: Int -> Char+> hexDig i | i <= 9 = chr (i + ord '0')+> | otherwise = chr (i - 10 + ord 'a')
+ src/ProduceGLRCode.lhs view
@@ -0,0 +1,703 @@+Module for producing GLR (Tomita) parsing code.+This module is designed as an extension to the Haskell parser generator Happy.++(c) University of Durham, Ben Medlock 2001+ -- initial code, for structure parsing +(c) University of Durham, Paul Callaghan 2004+ -- extension to semantic rules, and various optimisations+%-----------------------------------------------------------------------------++> module ProduceGLRCode ( produceGLRParser+> , DecodeOption(..)+> , FilterOption(..)+> , GhcExts(..)+> , Options+> ) where++-- > import Paths_happy ( version )++> import GenUtils ( thd3, mapDollarDollar )+> import GenUtils ( str, char, nl, brack, brack', interleave, maybestr )+> import Grammar+> import System.IO+> import Data.Array+> import Data.Char ( isSpace )+> import Data.List ( nub, (\\), sort )++-- > import Data.Version ( showVersion )++%-----------------------------------------------------------------------------+File and Function Names++> base_template, lib_template :: String -> String+> base_template td = td ++ "/GLR_Base" -- NB Happy uses / too+> lib_template td = td ++ "/GLR_Lib" -- Windows accepts this?++---+prefix for production names, to avoid name clashes++> prefix :: String+> prefix = "G_"++%-----------------------------------------------------------------------------+This type represents choice of decoding style for the result++> data DecodeOption+> = TreeDecode +> | LabelDecode++---+This type represents whether filtering done or not++> data FilterOption+> = NoFiltering+> | UseFiltering++---+This type represents whether GHC extensions are used or not+ - extra values are imports and ghc options reqd++> data GhcExts+> = NoGhcExts+> | UseGhcExts String String -- imports and options++---+this is where the exts matter++> show_st :: GhcExts -> {-State-}Int -> String+> show_st UseGhcExts{} = (++"#") . show+> show_st NoGhcExts = show++---++> type DebugMode = Bool+> type Options = (DecodeOption, FilterOption, GhcExts)+++%-----------------------------------------------------------------------------+Main exported function++> produceGLRParser+> :: FilePath -- Output file name+> -> String -- Templates directory+> -> ActionTable -- LR tables+> -> GotoTable -- LR tables +> -> Maybe String -- Module header+> -> Maybe String -- User-defined stuff (token DT, lexer etc.)+> -> (DebugMode,Options) -- selecting code-gen style+> -> Grammar -- Happy Grammar+> -> IO ()++> produceGLRParser outfilename template_dir action goto header trailer options g+> = do+> let basename = takeWhile (/='.') outfilename+> let tbls = (action,goto)+> (parseName,_,_,_) <- case starts g of+> [s] -> return s+> s:_ -> do +> putStrLn "GLR-Happy doesn't support multiple start points (yet)"+> putStrLn "Defaulting to first start point."+> return s+> [] -> error "produceGLRParser: []"+> mkFiles basename tbls parseName template_dir header trailer options g+++%-----------------------------------------------------------------------------+"mkFiles" generates the files containing the Tomita parsing code.+It produces two files - one for the data (small template), and one for +the driver and data strs (large template).++> mkFiles :: FilePath -- Root of Output file name +> -> (ActionTable+> ,GotoTable) -- LR tables +> -> String -- Start parse function name+> -> String -- Templates directory+> -> Maybe String -- Module header+> -> Maybe String -- User-defined stuff (token DT, lexer etc.)+> -> (DebugMode,Options) -- selecting code-gen style+> -> Grammar -- Happy Grammar+> -> IO ()+>+> mkFiles basename tables start templdir header trailer (debug,options) g+> = do+> let debug_ext = if debug then "-debug" else ""+> let (ext,imps,opts) = case thd3 options of +> UseGhcExts is os -> ("-ghc", is, os)+> _ -> ("", "", "")+> base <- readFile (base_template templdir)+> --writeFile (basename ++ ".si") (unlines $ map show sem_info)+> writeFile (basename ++ "Data.hs") (content base opts $ "")++> lib <- readFile (lib_template templdir ++ ext ++ debug_ext)+> writeFile (basename ++ ".hs") (lib_content imps opts lib)+> where+> mod_name = reverse $ takeWhile (`notElem` "\\/") $ reverse basename+> data_mod = mod_name ++ "Data"++> (sem_def, sem_info) = mkGSemType options g+> table_text = mkTbls tables sem_info (thd3 options) g++> header_parts = fmap (span (\x -> take 3 (dropWhile isSpace x) == "{-#") +> . lines) +> header+> -- Split off initial options, if they are present+> -- Assume these options ONLY related to code which is in +> -- parser tail or in sem. rules+ +> content base_defs opts +> = str ("{-# OPTIONS " ++ opts ++ " #-}") .nl +> . str (unlines $ maybe [] fst header_parts) .nl+> . nl+> . str (comment "data") .nl .nl+> . str ("module " ++ data_mod ++ " where") .nl ++> . nl+> . maybestr (fmap (unlines.snd) header_parts) .nl +> . nl+> . str base_defs .nl+> . nl++> . let count_nls = length . filter (=='\n')+> pre_trailer = maybe 0 count_nls header -- check fmt below+> + count_nls base_defs+> + 10 -- for the other stuff+> post_trailer = pre_trailer + maybe 0 count_nls trailer + 4+> in +> str ("{-# LINE " ++ show pre_trailer ++ " "+> ++ show (basename ++ "Data.hs") ++ "#-}") +> -- This should show a location in basename.y -- but Happy+> -- doesn't pass this info through. But we still avoid being+> -- told a location in GLR_Base! +> . nl+> . nl+> . maybestr trailer +> .nl+> .nl+> . str ("{-# LINE " ++ show post_trailer ++ " "+> ++ show (basename ++ "Data.hs") ++ "#-}") +> . nl+> . nl++> . mkGSymbols g .nl+> . nl+> . sem_def .nl+> . nl+> . mkSemObjects options (monad_sub g) sem_info .nl+> . nl+> . mkDecodeUtils options (monad_sub g) sem_info .nl+> . nl+> . user_def_token_code (token_type g) .nl+> . nl+> . table_text++> lib_content imps opts lib_text+> = let (pre,_drop_me : post) = break (== "fakeimport DATA") $ lines lib_text+> in +> unlines [ "{-# OPTIONS " ++ opts ++ " #-}\n"+> , comment "driver" ++ "\n"+> , "module " ++ mod_name ++ "("+> , case lexer g of +> Nothing -> ""+> Just (lf,_) -> "\t" ++ lf ++ ","+> , "\t" ++ start+> , ""+> , unlines pre+> , imps+> , "import " ++ data_mod+> , start ++ " = glr_parse " +> , "use_filtering = " ++ show use_filtering+> , "top_symbol = " ++ prefix ++ start_prod+> , unlines post+> ]+> start_prod = token_names g ! (let (_,_,i,_) = head $ starts g in i)+> use_filtering = case options of (_, UseFiltering,_) -> True+> _ -> False++> comment :: String -> String+> comment which+> = "-- parser (" ++ which ++ ") produced by Happy (GLR)"+++> user_def_token_code :: String -> String -> String+> user_def_token_code tokenType+> = str "type UserDefTok = " . str tokenType . nl+> . str "instance TreeDecode " . brack tokenType . str " where" . nl+> . str "\tdecode_b f (Branch (SemTok t) []) = [happy_return t]" . nl+> . str "instance LabelDecode " . brack tokenType . str " where" . nl+> . str "\tunpack (SemTok t) = t" . nl+++%-----------------------------------------------------------------------------+Formats the tables as code.++> mkTbls :: (ActionTable -- Action table from Happy+> ,GotoTable) -- Goto table from Happy+> -> SemInfo -- info about production mapping+> -> GhcExts -- Use unboxed values?+> -> Grammar -- Happy Grammar+> -> ShowS+>+> mkTbls (action,goto) sem_info exts g+> = let gsMap = mkGSymMap g +> semfn_map = mk_semfn_map sem_info+> in +> writeActionTbl action gsMap (semfn_map !) exts g+> . writeGotoTbl goto gsMap exts+++%-----------------------------------------------------------------------------+Create a mapping of Happy grammar symbol integers to the data representation+that will be used for them in the GLR parser.++> mkGSymMap :: Grammar -> [(Name,String)]+> mkGSymMap g+> = [ -- (errorTok, prefix ++ "Error") +> ]+> ++ [ (i, prefix ++ (token_names g) ! i) +> | i <- user_non_terminals g ] -- Non-terminals+> ++ [ (i, "HappyTok (" ++ mkMatch tok ++ ")")+> | (i,tok) <- token_specs g ] -- Tokens (terminals)+> ++ [(eof_term g,"HappyEOF")] -- EOF symbol (internal terminal)+> where+> mkMatch tok = case mapDollarDollar tok of +> Nothing -> tok+> Just fn -> fn "_"++> toGSym :: [(Int, String)] -> Int -> String+> toGSym gsMap i +> = case lookup i gsMap of+> Nothing -> error $ "No representation for symbol " ++ show i+> Just g -> g +++%-----------------------------------------------------------------------------+Take the ActionTable from Happy and turn it into a String representing a+function that can be included as the action table in the GLR parser.+It also shares identical reduction values as CAFs++> writeActionTbl +> :: ActionTable -> [(Int,String)] -> (Name->String) +> -> GhcExts -> Grammar -> ShowS+> writeActionTbl acTbl gsMap semfn_map exts g+> = interleave "\n" +> $ map str +> $ mkLines ++ [errorLine] ++ mkReductions+> where+> name = "action"+> mkLines = concatMap (mkState) (assocs acTbl)+> errorLine = name ++ " _ _ = Error" +> mkState (i,arr) +> = filter (/="") $ map (mkLine i) (assocs arr)+>+> mkLine state (symInt,action)+> | symInt == errorTok -- skip error productions+> = "" -- NB see ProduceCode's handling of these+> | otherwise+> = case action of+> LR'Fail -> ""+> LR'MustFail -> ""+> _ -> unwords [ startLine , mkAct action ]+> where+> startLine +> = unwords [ name , show_st exts state, "(" , getTok , ") =" ]+> getTok = let tok = toGSym gsMap symInt+> in case mapDollarDollar tok of+> Nothing -> tok+> Just f -> f "_"+> mkAct act+> = case act of+> LR'Shift newSt _ -> "Shift " ++ show newSt ++ " []"+> LR'Reduce r _ -> "Reduce " ++ "[" ++ mkRed r ++ "]" +> LR'Accept -> "Accept"+> LR'Multiple rs (LR'Shift st _) +> -> "Shift " ++ show st ++ " " ++ mkReds rs+> LR'Multiple rs r@(LR'Reduce{})+> -> "Reduce " ++ mkReds (r:rs)+> _ -> error "writeActionTbl/mkAct: Unhandled case"+> where+> mkReds rs = "[" ++ tail (concat [ "," ++ mkRed r | LR'Reduce r _ <- rs ]) ++ "]"++> mkRed r = "red_" ++ show r+> mkReductions = [ mkRedDefn p | p@(_,(n,_,_,_)) <- zip [0..] $ productions g +> , n `notElem` start_productions g ]++> mkRedDefn (r, (lhs_id, rhs_ids, (_code,_dollar_vars), _))+> = mkRed r ++ " = ("++ lhs ++ "," ++ show arity ++ " :: Int," ++ sem ++")"+> where+> lhs = toGSym gsMap $ lhs_id+> arity = length rhs_ids+> sem = semfn_map r+++%-----------------------------------------------------------------------------+Do the same with the Happy goto table.++> writeGotoTbl :: GotoTable -> [(Int,String)] -> GhcExts -> ShowS+> writeGotoTbl goTbl gsMap exts+> = interleave "\n" (map str $ filter (not.null) mkLines)+> . str errorLine . nl+> where+> name = "goto"+> errorLine = "goto _ _ = " ++ show_st exts (negate 1) +> mkLines = map mkState (assocs goTbl) +>+> mkState (i,arr) +> = unlines $ filter (/="") $ map (mkLine i) (assocs arr)+>+> mkLine state (ntInt,goto)+> = case goto of+> NoGoto -> ""+> Goto st -> unwords [ startLine , show_st exts st ]+> where+> startLine +> = unwords [ name , show_st exts state, getGSym , "=" ]+> getGSym = toGSym gsMap ntInt+++%-----------------------------------------------------------------------------+Create the 'GSymbol' ADT for the symbols in the grammar++> mkGSymbols :: Grammar -> ShowS+> mkGSymbols g +> = str dec +> . str eof+> . str tok +> . interleave "\n" [ str " | " . str prefix . str sym . str " " +> | sym <- syms ] +> . str der +> -- ++ eq_inst+> -- ++ ord_inst+> where+> dec = "data GSymbol"+> eof = " = HappyEOF" +> tok = " | HappyTok {-!Int-} (" ++ token_type g ++ ")"+> der = " deriving (Show,Eq,Ord)"+> syms = [ token_names g ! i | i <- user_non_terminals g ]++NOTES: +Was considering avoiding use of Eq/Ord over tokens, but this then means+hand-coding the Eq/Ord classes since we're over-riding the usual order+except in one case. ++maybe possible to form a union and do some juggling, but this isn't that+easy, eg input type of "action". ++plus, issues about how token info gets into TreeDecode sem values - which+might be tricky to arrange.+<> eq_inst = "instance Eq GSymbol where" +<> : "\tHappyTok i _ == HappyTok j _ = i == j" +<> : [ "\ti == j = fromEnum i == fromEnum j" ++++%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+Semantic actions on rules.++These are stored in a union type "GSem", and the semantic values are held +on the branches created at the appropriate reduction. ++"GSem" type has one constructor per distinct type of semantic action and+pattern of child usage. +++%-----------------------------------------------------------------------------+Creating a type for storing semantic rules+ - also collects information on code structure and constructor names, for+ use in later stages.++> type SemInfo +> = [(String, String, [Int], [((Int,Int), ([(Int,String)],String), [Int])])]++> mkGSemType :: Options -> Grammar -> (ShowS, SemInfo)+> mkGSemType (TreeDecode,_,_) g +> = (def, map snd syms)+> where+> mtype s = case monad_sub g of+> Nothing -> s+> Just (ty,_,_) -> ty ++ ' ' : brack s ""++> def = str "data GSem" . nl+> . str " = NoSem" . nl+> . str (" | SemTok (" ++ token_type g ++ ")") . nl+> . interleave "\n" [ str " | " . str sym . str " " +> | sym <- map fst syms ] +> . str "instance Show GSem where" . nl+> . interleave "\n" [ str "\tshow " . str c . str "{} = " . str (show c)+> | (_,c,_,_) <- map snd syms ]++> syms = [ (c_name ++ " (" ++ ty ++ ")", (rty, c_name, mask, prod_info))+> | (i,this@(mask,args,rty)) <- zip [0..] (nub $ map fst info)+> -- find unique types (plus mask)+> , let c_name = "Sem_" ++ show i+> , let mrty = mtype rty+> , let ty = foldr (\l r -> l ++ " -> " ++ r) mrty args ++> , let code_info = [ j_code | (that, j_code) <- info, this == that ]+> , let prod_info = [ ((i,k), code, js) +> | (k,code) <- zip [0..] (nub $ map snd code_info)+> , let js = [ j | (j,code2) <- code_info+> , code == code2 ]+> ]+> -- collect specific info about productions with this type+> ]++> info = [ ((var_mask, args, i_ty), (j,(ts_pats,code)))+> | i <- user_non_terminals g +> , let i_ty = typeOf i+> , j <- lookupProdsOfName g i -- all prod numbers+> , let (_,ts,(raw_code,dollar_vars),_) = lookupProdNo g j+> , let var_mask = map (\x -> x - 1) vars_used+> where vars_used = sort $ nub dollar_vars+> , let args = [ typeOf $ ts !! v | v <- var_mask ]+> , let code | all isSpace raw_code = "()"+> | otherwise = raw_code+> , let ts_pats = [ (k+1,c) | k <- var_mask+> , (t,c) <- token_specs g+> , ts !! k == t ]+> ]++> typeOf n | n `elem` terminals g = token_type g+> | otherwise = case types g ! n of+> Nothing -> "()" -- default+> Just t -> t++> -- NB expects that such labels are Showable+> mkGSemType (LabelDecode,_,_) g +> = (def, map snd syms)+> where+> def = str "data GSem" . nl+> . str " = NoSem" . nl+> . str (" | SemTok (" ++ token_type g ++ ")")+> . interleave "\n" [ str " | " . str sym . str " " +> | sym <- map fst syms ] +> . str " deriving (Show)" . nl++> syms = [ (c_name ++ " (" ++ ty ++ ")", (ty, c_name, mask, prod_info))+> | (i,this@(mask,ty)) <- zip [0..] (nub $ map fst info)+> -- find unique types+> , let c_name = "Sem_" ++ show i+> , let code_info = [ j_code | (that, j_code) <- info, this == that ]+> , let prod_info = [ ((i,k), code, js) +> | (k,code) <- zip [0..] (nub $ map snd code_info)+> , let js = [ j | (j,code2) <- code_info+> , code == code2 ]++> ]+> -- collect specific info about productions with this type+> ]++> info = [ ((var_mask,i_ty), (j,(ts_pats,code)))+> | i <- user_non_terminals g+> , let i_ty = typeOf i+> , j <- lookupProdsOfName g i -- all prod numbers+> , let (_,ts,(code,dollar_vars),_) = lookupProdNo g j+> , let var_mask = map (\x -> x - 1) vars_used+> where vars_used = sort $ nub dollar_vars+> , let ts_pats = [ (k+1,c) | k <- var_mask+> , (t,c) <- token_specs g+> , ts !! k == t ]+> ]++> typeOf n = case types g ! n of+> Nothing -> "()" -- default+> Just t -> t+++%---------------------------------------+Creates the appropriate semantic values.+ - for label-decode, these are the code, but abstracted over the child indices+ - for tree-decode, these are the code abstracted over the children's values++> mkSemObjects :: Options -> MonadInfo -> SemInfo -> ShowS +> mkSemObjects (LabelDecode,filter_opt,_) _ sem_info+> = interleave "\n" +> $ [ str (mkSemFn_Name ij)+> . str (" ns@(" ++ pat ++ "happy_rest) = ")+> . str (" Branch (" ++ c_name ++ " (" ++ code ++ ")) ")+> . str (nodes filter_opt)+> | (_ty, c_name, mask, prod_info) <- sem_info+> , (ij, (pats,code), _ps) <- prod_info +> , let pat | null mask = ""+> | otherwise = concatMap (\v -> mk_tok_binder pats (v+1) ++ ":")+> [0..maximum mask]++> , let nodes NoFiltering = "ns"+> nodes UseFiltering = "(" ++ foldr (\l -> mkHappyVar (l+1) . showChar ':') "[])" mask+> ]+> where+> mk_tok_binder pats v +> = mk_binder (\s -> "(_,_,HappyTok (" ++ s ++ "))") pats v ""+++> mkSemObjects (TreeDecode,filter_opt,_) monad_info sem_info+> = interleave "\n" +> $ [ str (mkSemFn_Name ij)+> . str (" ns@(" ++ pat ++ "happy_rest) = ")+> . str (" Branch (" ++ c_name ++ " (" ++ sem ++ ")) ")+> . str (nodes filter_opt)+> | (_ty, c_name, mask, prod_info) <- sem_info+> , (ij, (pats,code), _) <- prod_info +> , let indent c = init $ unlines $ map (replicate 2 '\t'++) $ lines c+> , let mcode = case monad_info of+> Nothing -> code+> Just (_,_,rtn) -> case code of +> '%':code' -> "\n" ++ indent code'+> _ -> rtn ++ " (" ++ code ++ ")"+> , let sem = foldr (\v t -> mk_lambda pats (v + 1) "" ++ t) mcode mask+> , let pat | null mask = ""+> | otherwise = concatMap (\v -> mkHappyVar (v+1) ":")+> [0..maximum mask]+> , let nodes NoFiltering = "ns"+> nodes UseFiltering = "(" ++ foldr (\l -> mkHappyVar (l+1) . showChar ':') "[])" mask+> ] ++> mk_lambda :: [(Int, String)] -> Int -> String -> String+> mk_lambda pats v+> = (\s -> "\\" ++ s ++ " -> ") . mk_binder id pats v++> mk_binder :: (String -> String) -> [(Int, String)] -> Int -> String -> String+> mk_binder wrap pats v+> = case lookup v pats of+> Nothing -> mkHappyVar v +> Just p -> case mapDollarDollar p of +> Nothing -> wrap . mkHappyVar v . showChar '@' . brack p+> Just fn -> wrap . brack' (fn . mkHappyVar v)+++---+standardise the naming scheme++> mkSemFn_Name :: (Int, Int) -> String+> mkSemFn_Name (i,j) = "semfn_" ++ show i ++ "_" ++ show j++---+maps production name to the underlying (possibly shared) semantic function++> mk_semfn_map :: SemInfo -> Array Name String+> mk_semfn_map sem_info+> = array (0,maximum $ map fst prod_map) prod_map+> where +> prod_map = [ (p, mkSemFn_Name ij) +> | (_,_,_,pi') <- sem_info, (ij,_,ps) <- pi', p <- ps ]+++%-----------------------------------------------------------------------------+Create default decoding functions++Idea is that sem rules are stored as functions in the AbsSyn names, and +only unpacked when needed. Using classes here to manage the unpacking. ++> mkDecodeUtils :: Options -> MonadInfo -> SemInfo -> ShowS+> mkDecodeUtils (TreeDecode,filter_opt,_) monad_info seminfo+> = interleave "\n" +> $ map str (monad_defs monad_info)+> ++ map mk_inst ty_cs+> where+> ty_cs = [ (ty, [ (c_name, mask)+> | (ty2, c_name, mask, _j_vs) <- seminfo+> , ty2 == ty+> ])+> | ty <- nub [ ty | (ty,_,_,_) <- seminfo ]+> ] -- group by same type++> mk_inst (ty, cs_vs)+> = str ("instance TreeDecode (" ++ ty ++ ") where ") . nl+> . interleave "\n"+> [ char '\t' +> . str ("decode_b f (Branch (" ++ c_name ++ " s)")+> . str (" (" ++ var_pat ++ ")) = ")+> . cross_prod monad_info "s" (nodes filter_opt)+> | (c_name, vs) <- cs_vs +> , let vars = [ "b_" ++ show n | n <- var_range filter_opt vs ]+> , let var_pat = foldr (\l r -> l ++ ":" ++ r) "_" vars+> , let nodes NoFiltering = [ vars !! n | n <- vs ]+> nodes UseFiltering = vars +> ]++> var_range _ [] = []+> var_range NoFiltering vs = [0 .. maximum vs ]+> var_range UseFiltering vs = [0 .. length vs - 1]++> cross_prod Nothing s_var nodes+> = cross_prod_ (char '[' . str s_var . char ']') +> (map str nodes)+> cross_prod (Just (_,_,rtn)) s_var nodes+> = str "map happy_join $ "+> . cross_prod_ (char '[' . str rtn . char ' ' . str s_var . char ']')+> (map str nodes)++> cross_prod_ = foldl (\s a -> brack' +> $ str "cross_fn" +> . char ' ' . s +> . str " $ decode f " +> . a)++++> mkDecodeUtils (LabelDecode,_,_) monad_info seminfo+> = interleave "\n" +> $ map str +> $ monad_defs monad_info ++ concatMap (mk_inst) ty_cs+> where+> ty_cs = [ (ty, [ (c_name, mask)+> | (ty2, c_name, mask, _) <- seminfo+> , ty2 == ty+> ])+> | ty <- nub [ ty | (ty,_,_,_) <- seminfo ]+> ] -- group by same type++> mk_inst (ty, cns)+> = ("instance LabelDecode (" ++ ty ++ ") where ")+> : [ "\tunpack (" ++ c_name ++ " s) = s"+> | (c_name, _mask) <- cns ]+++---+This selects the info used for monadic parser generation++> type MonadInfo = Maybe (String,String,String)+> monad_sub :: Grammar -> MonadInfo+> monad_sub g +> = case monad g of+> (True, _, ty,bd,ret) -> Just (ty,bd,ret)+> _ -> Nothing +> -- TMP: only use monad info if it was user-declared, and ignore ctxt+> -- TMP: otherwise default to non-monadic code+> -- TMP: (NB not sure of consequences of monads-everywhere yet)+++--- +form the various monad-related defs. ++> monad_defs :: MonadInfo -> [String]+> monad_defs Nothing +> = [ "type Decode_Result a = a"+> , "happy_ap = ($)"+> , "happy_return = id"]+> monad_defs (Just (ty,tn,rtn)) +> = [ "happy_join x = (" ++ tn ++ ") x id"+> , "happy_ap f a = (" ++ tn ++ ") f (\\f -> (" ++ tn ++ ") a (\\a -> " ++ rtn ++ "(f a)))"+> , "type Decode_Result a = " ++ brack ty " a"+> , "happy_return = " ++ rtn ++ " :: a -> Decode_Result a"+> ]++%-----------------------------------------------------------------------------+Util Functions++---+remove Happy-generated start symbols.++> user_non_terminals :: Grammar -> [Name]+> user_non_terminals g+> = non_terminals g \\ start_productions g++> start_productions :: Grammar -> [Name]+> start_productions g = [ s | (_,s,_,_) <- starts g ]+++---++> mkHappyVar :: Int -> String -> String+> mkHappyVar n = showString "happy_var_" . shows n++
+ src/Target.lhs view
@@ -0,0 +1,13 @@+-----------------------------------------------------------------------------+The target data type.++(c) 1993-2001 Andy Gill, Simon Marlow+-----------------------------------------------------------------------------++> module Target (Target(..)) where++> data Target+> = TargetHaskell -- functions and things+> | TargetArrayBased -- arrays++> deriving Eq
+ src/Text/Happy.hs view
@@ -0,0 +1,170 @@+module Text.Happy (runHappy, CLIFlags(..)) where++import ProduceCode+import Parser+import ParseMonad+import AbsSyn+import LALR+import First+import Grammar+import GenUtils+import Target+-- import Text.Happy.HappyTemplate+import Data.Array( assocs, elems, (!) )+import Data.List( nub )++ +runHappy :: [CLIFlags]+ -> String+ -> (String, ([Int], [String]))+runHappy cli s = + case runP ourParser s 1 of+ FailP err -> die (err)+ OkP abssyn@(AbsSyn _ _ _ tl) -> + case {-# SCC "Mangler" #-} (mangler "" abssyn) of+ Failed e -> die (unlines e ++ "\n")+ Succeeded g -> let + first = {-# SCC "First" #-} (mkFirst g)+ closures = {-# SCC "Closures" #-} (precalcClosure0 g)+ sets = {-# SCC "LR0_Sets" #-} (genLR0items g closures)+ _lainfo@(spont,prop) = {-# SCC "Prop" #-} (propLookaheads g sets first)+ la = {-# SCC "Calc" #-} (calcLookaheads (length sets) spont prop)+ items2 = {-# SCC "Merge" #-} (mergeLookaheadInfo la sets)+ goto = {-# SCC "Goto" #-} (genGotoTable g sets)+ action = {-# SCC "Action" #-} (genActionTable g first items2)+-- (conflictArray,(sr,rr)) = {-# SCC "Conflict" #-} (countConflicts action)++ reduction_filter | OptGLR `elem` cli = any_reduction+ | otherwise = first_reduction+ (unused_rules, unused_terminals) + = find_redundancies reduction_filter g action++ target = getTarget cli++ opt_coerce = getCoerce target cli+ opt_strict = getStrict cli+ opt_ghc = getGhc cli+++ -- templ = getTemplate + outfile = produceParser + g+ action+ goto+ (optsToInject target cli)+ Nothing+ tl+ TargetHaskell+ opt_coerce+ opt_ghc+ opt_strict+ in+ (outfile,((unused_rules, unused_terminals)))++++die :: String -> a+die s = error s++find_redundancies + :: (LRAction -> [Int]) -> Grammar -> ActionTable -> ([Int], [String])+find_redundancies extract_reductions g action_table = + (unused_rules, map (env !) unused_terminals)+ where+ Grammar { terminals = terms,+ token_names = env,+ eof_term = eof,+ starts = starts',+ productions = productions'+ } = g++ actions = concat (map assocs (elems action_table))+ start_rules = [ 0 .. (length starts' - 1) ]+ used_rules = start_rules +++ nub [ r | (_,a) <- actions, r <- extract_reductions a ]+ used_tokens = errorTok : eof : + nub [ t | (t,a) <- actions, is_shift a ]+ n_prods = length productions'+ unused_terminals = filter (`notElem` used_tokens) terms+ unused_rules = filter (`notElem` used_rules ) [0..n_prods-1]++is_shift :: LRAction -> Bool+is_shift (LR'Shift _ _) = True+is_shift (LR'Multiple _ LR'Shift{}) = True+is_shift _ = False++-- selects what counts as a reduction when calculating used/unused++any_reduction :: LRAction -> [Int]+any_reduction (LR'Reduce r _) = [r] +any_reduction (LR'Multiple as a) = concatMap any_reduction (a : as)+any_reduction _ = []++first_reduction :: LRAction -> [Int]+first_reduction (LR'Reduce r _) = [r] +first_reduction (LR'Multiple _ a) = first_reduction a -- eg R/R conflict+first_reduction _ = []++optsToInject :: Target -> [CLIFlags] -> String+optsToInject tgt cli + | OptGhcTarget `elem` cli = "-fglasgow-exts -cpp"+ | tgt == TargetArrayBased = "-cpp"+ | OptDebugParser `elem` cli = "-cpp"+ | otherwise = ""++optToTarget :: CLIFlags -> Maybe Target+optToTarget OptArrayTarget = Just TargetArrayBased+optToTarget _ = Nothing++data CLIFlags =+ DumpVersion+ | DumpHelp+ | OptInfoFile (Maybe String)+ | OptTemplate String+ | OptMagicName String++ | OptGhcTarget+ | OptArrayTarget+ | OptUseCoercions+ | OptDebugParser+ | OptStrict+ | OptOutputFile String+ | OptGLR+ | OptGLR_Decode+ | OptGLR_Filter+ deriving Eq+++getTarget :: [CLIFlags] -> Target+getTarget cli = case [ t | (Just t) <- map optToTarget cli ] of+ (t:ts) | all (==t) ts -> t+ [] -> TargetHaskell+ _ -> error "getTarget: multiple target options"++-- > getTemplate :: IO String -> [CLIFlags] -> IO String+-- > getTemplate def cli+-- > = case [ s | (OptTemplate s) <- cli ] of+-- > [] -> def+-- > f:fs -> return (last (f:fs))+{-+> getMagicName :: [CLIFlags] -> IO (Maybe String)+> getMagicName cli+> = case [ s | (OptMagicName s) <- cli ] of+> [] -> return Nothing+> f:fs -> return (Just (map toLower (last (f:fs))))+-}+getCoerce :: Target -> [CLIFlags] -> Bool+getCoerce _target cli+ = if OptUseCoercions `elem` cli + then if OptGhcTarget `elem` cli+ then True+ else error ("-c/--coerce may only be used " +++ "in conjunction with -g/--ghc\n")+ else False++getGhc :: [CLIFlags] -> Bool+getGhc cli = OptGhcTarget `elem` cli++getStrict :: [CLIFlags] -> Bool+getStrict cli = OptStrict `elem` cli+
+ src/Text/Happy/HappyTemplate.hs view
@@ -0,0 +1,206 @@+module Text.Happy.HappyTemplate where+happyTemplate =+ "{-# LINE 1 \"templates\\GenericTemplate.hs\" #-}\n" ++ + "{-# LINE 1 \"templates\\\\GenericTemplate.hs\" #-}\n" ++ + "{-# LINE 1 \"<built-in>\" #-}\n" ++ + "{-# LINE 1 \"<command line>\" #-}\n" ++ + "{-# LINE 1 \"templates\\\\GenericTemplate.hs\" #-}\n" ++ + "-- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp \n" ++ + "\n" ++ + "{-# LINE 28 \"templates\\\\GenericTemplate.hs\" #-}\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + "{-# LINE 49 \"templates\\\\GenericTemplate.hs\" #-}\n" ++ + "\n" ++ + "{-# LINE 59 \"templates\\\\GenericTemplate.hs\" #-}\n" ++ + "\n" ++ + "{-# LINE 68 \"templates\\\\GenericTemplate.hs\" #-}\n" ++ + "\n" ++ + "infixr 9 `HappyStk`\n" ++ + "data HappyStk a = HappyStk a (HappyStk a)\n" ++ + "\n" ++ + "-----------------------------------------------------------------------------\n" ++ + "-- starting the parse\n" ++ + "\n" ++ + "happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll\n" ++ + "\n" ++ + "-----------------------------------------------------------------------------\n" ++ + "-- Accepting the parse\n" ++ + "\n" ++ + "-- If the current token is (1), it means we've just accepted a partial\n" ++ + "-- parse (a %partial parser). We must ignore the saved token on the top of\n" ++ + "-- the stack in this case.\n" ++ + "happyAccept (1) tk st sts (_ `HappyStk` ans `HappyStk` _) =\n" ++ + "\thappyReturn1 ans\n" ++ + "happyAccept j tk st sts (HappyStk ans _) = \n" ++ + "\t (happyReturn1 ans)\n" ++ + "\n" ++ + "-----------------------------------------------------------------------------\n" ++ + "-- Arrays only: do the next action\n" ++ + "\n" ++ + "{-# LINE 155 \"templates\\\\GenericTemplate.hs\" #-}\n" ++ + "\n" ++ + "-----------------------------------------------------------------------------\n" ++ + "-- HappyState data type (not arrays)\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + "newtype HappyState b c = HappyState\n" ++ + " (Int -> -- token number\n" ++ + " Int -> -- token number (yes, again)\n" ++ + " b -> -- token semantic value\n" ++ + " HappyState b c -> -- current state\n" ++ + " [HappyState b c] -> -- state stack\n" ++ + " c)\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + "-----------------------------------------------------------------------------\n" ++ + "-- Shifting a token\n" ++ + "\n" ++ + "happyShift new_state (1) tk st sts stk@(x `HappyStk` _) =\n" ++ + " let i = (case x of { HappyErrorToken (i) -> i }) in\n" ++ + "-- trace \"shifting the error token\" $\n" ++ + " new_state i i tk (HappyState (new_state)) ((st):(sts)) (stk)\n" ++ + "\n" ++ + "happyShift new_state i tk st sts stk =\n" ++ + " happyNewToken new_state ((st):(sts)) ((HappyTerminal (tk))`HappyStk`stk)\n" ++ + "\n" ++ + "-- happyReduce is specialised for the common cases.\n" ++ + "\n" ++ + "happySpecReduce_0 i fn (1) tk st sts stk\n" ++ + " = happyFail (1) tk st sts stk\n" ++ + "happySpecReduce_0 nt fn j tk st@((HappyState (action))) sts stk\n" ++ + " = action nt j tk st ((st):(sts)) (fn `HappyStk` stk)\n" ++ + "\n" ++ + "happySpecReduce_1 i fn (1) tk st sts stk\n" ++ + " = happyFail (1) tk st sts stk\n" ++ + "happySpecReduce_1 nt fn j tk _ sts@(((st@(HappyState (action))):(_))) (v1`HappyStk`stk')\n" ++ + " = let r = fn v1 in\n" ++ + " happySeq r (action nt j tk st sts (r `HappyStk` stk'))\n" ++ + "\n" ++ + "happySpecReduce_2 i fn (1) tk st sts stk\n" ++ + " = happyFail (1) tk st sts stk\n" ++ + "happySpecReduce_2 nt fn j tk _ ((_):(sts@(((st@(HappyState (action))):(_))))) (v1`HappyStk`v2`HappyStk`stk')\n" ++ + " = let r = fn v1 v2 in\n" ++ + " happySeq r (action nt j tk st sts (r `HappyStk` stk'))\n" ++ + "\n" ++ + "happySpecReduce_3 i fn (1) tk st sts stk\n" ++ + " = happyFail (1) tk st sts stk\n" ++ + "happySpecReduce_3 nt fn j tk _ ((_):(((_):(sts@(((st@(HappyState (action))):(_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')\n" ++ + " = let r = fn v1 v2 v3 in\n" ++ + " happySeq r (action nt j tk st sts (r `HappyStk` stk'))\n" ++ + "\n" ++ + "happyReduce k i fn (1) tk st sts stk\n" ++ + " = happyFail (1) tk st sts stk\n" ++ + "happyReduce k nt fn j tk st sts stk\n" ++ + " = case happyDrop (k - ((1) :: Int)) sts of\n" ++ + "\t sts1@(((st1@(HappyState (action))):(_))) ->\n" ++ + " \tlet r = fn stk in -- it doesn't hurt to always seq here...\n" ++ + " \t\thappyDoSeq r (action nt j tk st1 sts1 r)\n" ++ + "\n" ++ + "happyMonadReduce k nt fn (1) tk st sts stk\n" ++ + " = happyFail (1) tk st sts stk\n" ++ + "happyMonadReduce k nt fn j tk st sts stk =\n" ++ + " happyThen1 (fn stk tk) (\\r -> action nt j tk st1 sts1 (r `HappyStk` drop_stk))\n" ++ + " where sts1@(((st1@(HappyState (action))):(_))) = happyDrop k ((st):(sts))\n" ++ + " drop_stk = happyDropStk k stk\n" ++ + "\n" ++ + "happyMonad2Reduce k nt fn (1) tk st sts stk\n" ++ + " = happyFail (1) tk st sts stk\n" ++ + "happyMonad2Reduce k nt fn j tk st sts stk =\n" ++ + " happyThen1 (fn stk tk) (\\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))\n" ++ + " where sts1@(((st1@(HappyState (action))):(_))) = happyDrop k ((st):(sts))\n" ++ + " drop_stk = happyDropStk k stk\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + " new_state = action\n" ++ + "\n" ++ + "\n" ++ + "happyDrop (0) l = l\n" ++ + "happyDrop n ((_):(t)) = happyDrop (n - ((1) :: Int)) t\n" ++ + "\n" ++ + "happyDropStk (0) l = l\n" ++ + "happyDropStk n (x `HappyStk` xs) = happyDropStk (n - ((1)::Int)) xs\n" ++ + "\n" ++ + "-----------------------------------------------------------------------------\n" ++ + "-- Moving to a new state after a reduction\n" ++ + "\n" ++ + "{-# LINE 253 \"templates\\\\GenericTemplate.hs\" #-}\n" ++ + "happyGoto action j tk st = action j j tk (HappyState action)\n" ++ + "\n" ++ + "\n" ++ + "-----------------------------------------------------------------------------\n" ++ + "-- Error recovery ((1) is the error token)\n" ++ + "\n" ++ + "-- parse error if we are in recovery and we fail again\n" ++ + "happyFail (1) tk old_st _ stk =\n" ++ + "--\ttrace \"failing\" $ \n" ++ + " \thappyError_ tk\n" ++ + "\n" ++ + "{- We don't need state discarding for our restricted implementation of\n" ++ + " \"error\". In fact, it can cause some bogus parses, so I've disabled it\n" ++ + " for now --SDM\n" ++ + "\n" ++ + "-- discard a state\n" ++ + "happyFail (1) tk old_st (((HappyState (action))):(sts)) \n" ++ + "\t\t\t\t\t\t(saved_tok `HappyStk` _ `HappyStk` stk) =\n" ++ + "--\ttrace (\"discarding state, depth \" ++ show (length stk)) $\n" ++ + "\taction (1) (1) tk (HappyState (action)) sts ((saved_tok`HappyStk`stk))\n" ++ + "-}\n" ++ + "\n" ++ + "-- Enter error recovery: generate an error token,\n" ++ + "-- save the old token and carry on.\n" ++ + "happyFail i tk (HappyState (action)) sts stk =\n" ++ + "-- trace \"entering error recovery\" $\n" ++ + "\taction (1) (1) tk (HappyState (action)) sts ( (HappyErrorToken (i)) `HappyStk` stk)\n" ++ + "\n" ++ + "-- Internal happy errors:\\n" ++ + "\n" ++ + "notHappyAtAll = error \"Internal Happy error\\n\"" ++ + "\n" ++ + "-----------------------------------------------------------------------------\n" ++ + "-- Hack to get the typechecker to accept our action functions\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + "-----------------------------------------------------------------------------\n" ++ + "-- Seq-ing. If the --strict flag is given, then Happy emits \n" ++ + "--\thappySeq = happyDoSeq\n" ++ + "-- otherwise it emits\n" ++ + "-- \thappySeq = happyDontSeq\n" ++ + "\n" ++ + "happyDoSeq, happyDontSeq :: a -> b -> b\n" ++ + "happyDoSeq a b = a `seq` b\n" ++ + "happyDontSeq a b = b\n" ++ + "\n" ++ + "-----------------------------------------------------------------------------\n" ++ + "-- Don't inline any functions from the template. GHC has a nasty habit\n" ++ + "-- of deciding to inline happyGoto everywhere, which increases the size of\n" ++ + "-- the generated parser quite a bit.\n" ++ + "\n" ++ + "{-# LINE 317 \"templates\\\\GenericTemplate.hs\" #-}\n" ++ + "{-# NOINLINE happyShift #-}\n" ++ + "{-# NOINLINE happySpecReduce_0 #-}\n" ++ + "{-# NOINLINE happySpecReduce_1 #-}\n" ++ + "{-# NOINLINE happySpecReduce_2 #-}\n" ++ + "{-# NOINLINE happySpecReduce_3 #-}\n" ++ + "{-# NOINLINE happyReduce #-}\n" ++ + "{-# NOINLINE happyMonadReduce #-}\n" ++ + "{-# NOINLINE happyGoto #-}\n" ++ + "{-# NOINLINE happyFail #-}\n" ++ + "\n" ++ + "-- end of Happy Template."