diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Text/Happy/Quote.hs b/Text/Happy/Quote.hs new file mode 100644 --- /dev/null +++ b/Text/Happy/Quote.hs @@ -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 diff --git a/dist/build/AttrGrammarParser.hs b/dist/build/AttrGrammarParser.hs new file mode 100644 --- /dev/null +++ b/dist/build/AttrGrammarParser.hs @@ -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 "" #-} +{-# LINE 1 "" #-} +{-# 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. diff --git a/dist/build/Parser.hs b/dist/build/Parser.hs new file mode 100644 --- /dev/null +++ b/dist/build/Parser.hs @@ -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 "" #-} +{-# LINE 1 "" #-} +{-# 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. diff --git a/happy-meta.cabal b/happy-meta.cabal new file mode 100644 --- /dev/null +++ b/happy-meta.cabal @@ -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 + diff --git a/src/AbsSyn.lhs b/src/AbsSyn.lhs new file mode 100644 --- /dev/null +++ b/src/AbsSyn.lhs @@ -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" diff --git a/src/AttrGrammar.lhs b/src/AttrGrammar.lhs new file mode 100644 --- /dev/null +++ b/src/AttrGrammar.lhs @@ -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 diff --git a/src/AttrGrammarParser.ly b/src/AttrGrammarParser.ly new file mode 100644 --- /dev/null +++ b/src/AttrGrammarParser.ly @@ -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") +> } diff --git a/src/First.lhs b/src/First.lhs new file mode 100644 --- /dev/null +++ b/src/First.lhs @@ -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 diff --git a/src/GenUtils.lhs b/src/GenUtils.lhs new file mode 100644 --- /dev/null +++ b/src/GenUtils.lhs @@ -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 ')' + + diff --git a/src/Grammar.lhs b/src/Grammar.lhs new file mode 100644 --- /dev/null +++ b/src/Grammar.lhs @@ -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) diff --git a/src/LALR.lhs b/src/LALR.lhs new file mode 100644 --- /dev/null +++ b/src/LALR.lhs @@ -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 diff --git a/src/Lexer.lhs b/src/Lexer.lhs new file mode 100644 --- /dev/null +++ b/src/Lexer.lhs @@ -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 diff --git a/src/NameSet.hs b/src/NameSet.hs new file mode 100644 --- /dev/null +++ b/src/NameSet.hs @@ -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 diff --git a/src/ParamRules.hs b/src/ParamRules.hs new file mode 100644 --- /dev/null +++ b/src/ParamRules.hs @@ -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) + + + diff --git a/src/ParseMonad.lhs b/src/ParseMonad.lhs new file mode 100644 --- /dev/null +++ b/src/ParseMonad.lhs @@ -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 diff --git a/src/Parser.ly b/src/Parser.ly new file mode 100644 --- /dev/null +++ b/src/Parser.ly @@ -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") +> } diff --git a/src/ProduceCode.lhs b/src/ProduceCode.lhs new file mode 100644 --- /dev/null +++ b/src/ProduceCode.lhs @@ -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 :: ti -> HappyAbsSyn ti tj tk ... + happyIn x = unsafeCoerce# x + {-# INLINE happyIn #-} + + happyOut :: HappyAbsSyn ti tj tk ... -> tn + happyOut x = unsafeCoerce# x + {-# INLINE happyOut #-} + +> | 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 + ( <> ) : 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') diff --git a/src/ProduceGLRCode.lhs b/src/ProduceGLRCode.lhs new file mode 100644 --- /dev/null +++ b/src/ProduceGLRCode.lhs @@ -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 + + diff --git a/src/Target.lhs b/src/Target.lhs new file mode 100644 --- /dev/null +++ b/src/Target.lhs @@ -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 diff --git a/src/Text/Happy.hs b/src/Text/Happy.hs new file mode 100644 --- /dev/null +++ b/src/Text/Happy.hs @@ -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 + diff --git a/src/Text/Happy/HappyTemplate.hs b/src/Text/Happy/HappyTemplate.hs new file mode 100644 --- /dev/null +++ b/src/Text/Happy/HappyTemplate.hs @@ -0,0 +1,206 @@ +module Text.Happy.HappyTemplate where +happyTemplate = + "{-# LINE 1 \"templates\\GenericTemplate.hs\" #-}\n" ++ + "{-# LINE 1 \"templates\\\\GenericTemplate.hs\" #-}\n" ++ + "{-# LINE 1 \"\" #-}\n" ++ + "{-# LINE 1 \"\" #-}\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."