diff options
Diffstat (limited to 'testsuite/tests/typecheck/should_compile/tc095.hs')
-rw-r--r-- | testsuite/tests/typecheck/should_compile/tc095.hs | 237 |
1 files changed, 237 insertions, 0 deletions
diff --git a/testsuite/tests/typecheck/should_compile/tc095.hs b/testsuite/tests/typecheck/should_compile/tc095.hs new file mode 100644 index 0000000000..5e0a34d912 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc095.hs @@ -0,0 +1,237 @@ +{- +Bug report from Jon Mountjoy: + +While playing with Happy I managed to generate a Haskell program +which compiles fine under ghc but not under Hugs. I don't know which +one is the culprit.... + +In Hugs(January 1998), one gets + + ERROR "hugs.hs" (line 32): Unresolved top-level overloading + *** Binding : happyReduce_1 + *** Outstanding context : Functor b + +where line 32 is the one marked -- ## + +It compiles in ghc-3.00. Changing very small things, like the +line marked ---**** to + action_0 (6) = happyShift action_0 ---**** + +then makes ghc produce a similar message: + + hugs.hs:37: + Cannot resolve the ambiguous context (Functor a1Ab) + `Functor a1Ab' arising from use of `reduction', at hugs.hs:37 +-} + +module ShouldSucceed where + +data HappyAbsSyn t1 t2 t3 + = HappyTerminal Token + | HappyErrorToken Int + | HappyAbsSyn1 t1 + | HappyAbsSyn2 t2 + | HappyAbsSyn3 t3 + +action_0 (6) = happyShift action_3 --- ***** +action_0 (1) = happyGoto action_1 +action_0 (2) = happyGoto action_2 +action_0 _ = happyFail + +action_1 (7) = happyAccept +action_1 _ = happyFail + +action_2 _ = happyReduce_1 + +action_3 (5) = happyShift action_4 +action_3 _ = happyFail + +action_4 (4) = happyShift action_6 +action_4 (3) = happyGoto action_5 +action_4 _ = happyFail + +action_5 _ = happyReduce_2 + +action_6 _ = happyReduce_3 + +happyReduce_1 = happySpecReduce_1 1 reduction where { -- ## + reduction + (HappyAbsSyn2 happy_var_1) + = HappyAbsSyn1 + (\p -> let q = map (\(x,y) -> (x,y p)) happy_var_1 in (10.1)) +; + reduction _ = notHappyAtAll } + +happyReduce_2 = happySpecReduce_3 2 reduction where { + reduction + (HappyAbsSyn3 happy_var_3) + _ + (HappyTerminal (TokenVar happy_var_1)) + = HappyAbsSyn2 + ([(happy_var_1,happy_var_3)]); + reduction _ _ _ = notHappyAtAll } + +happyReduce_3 = happySpecReduce_1 3 reduction where { + reduction + (HappyTerminal (TokenInt happy_var_1)) + = HappyAbsSyn3 + (\p -> happy_var_1); + reduction _ = notHappyAtAll } + +happyNewToken action sts stk [] = + action 7 7 (error "reading EOF!") (HappyState action) sts stk [] + +happyNewToken action sts stk (tk:tks) = + let cont i = action i i tk (HappyState action) sts stk tks in + case tk of { + TokenInt happy_dollar_dollar -> cont 4; + TokenEq -> cont 5; + TokenVar happy_dollar_dollar -> cont 6; + } + +happyThen = \m k -> k m +happyReturn = \a tks -> a +myparser = happyParse + + + +happyError ::[Token] -> a +happyError _ = error "Parse error\n" + +--Here are our tokens +data Token = + TokenInt Int + | TokenVar String + | TokenEq + deriving Show + +main = print (myparser [] []) +-- $Id: tc095.hs,v 1.4 2005/05/24 11:33:11 simonpj Exp $ + +{- + The stack is in the following order throughout the parse: + + i current token number + j another copy of this to avoid messing with the stack + tk current token semantic value + st current state + sts state stack + stk semantic stack +-} + +----------------------------------------------------------------------------- + +happyParse = happyNewToken action_0 [] [] + +-- All this HappyState stuff is simply because we can't have recursive +-- types in Haskell without an intervening data structure. + +newtype HappyState b c = HappyState + (Int -> -- token number + Int -> -- token number (yes, again) + b -> -- token semantic value + HappyState b c -> -- current state + [HappyState b c] -> -- state stack + c) + +----------------------------------------------------------------------------- +-- Accepting the parse + +happyAccept j tk st sts [ HappyAbsSyn1 ans ] = happyReturn ans +happyAccept j tk st sts _ = notHappyAtAll + +----------------------------------------------------------------------------- +-- Shifting a token + +happyShift new_state (-1) tk st sts stk@(HappyErrorToken i : _) = +-- _trace "shifting the error token" $ + new_state i i tk (HappyState new_state) (st:sts) stk + +happyShift new_state i tk st sts stk = + happyNewToken new_state (st:sts) (HappyTerminal tk:stk) + +----------------------------------------------------------------------------- +-- Reducing + +-- happyReduce is specialised for the common cases. + +-- don't allow reductions when we're in error recovery, because this can +-- lead to an infinite loop. + +happySpecReduce_0 i fn (-1) tk _ sts stk + = case sts of + st@(HappyState action):sts -> action (-1) (-1) tk st sts stk + _ -> happyError +happySpecReduce_0 i fn j tk st@(HappyState action) sts stk + = action i j tk st (st:sts) (fn : stk) + +happySpecReduce_1 i fn (-1) tk _ (st@(HappyState action):sts) stk + = action (-1) (-1) tk st sts stk +happySpecReduce_1 i fn j tk _ sts@(st@(HappyState action):_) (v1:stk') + = action i j tk st sts (fn v1 : stk') +happySpecReduce_1 _ _ _ _ _ _ _ + = notHappyAtAll + +happySpecReduce_2 i fn (-1) tk _ (st@(HappyState action):sts) stk + = action (-1) (-1) tk st sts stk +happySpecReduce_2 i fn j tk _ (_:sts@(st@(HappyState action):_)) (v1:v2:stk') + = action i j tk st sts (fn v1 v2 : stk') +happySpecReduce_2 _ _ _ _ _ _ _ + = notHappyAtAll + +happySpecReduce_3 i fn (-1) tk _ (st@(HappyState action):sts) stk + = action (-1) (-1) tk st sts stk +happySpecReduce_3 i fn j tk _ (_:_:sts@(st@(HappyState action):_)) + (v1:v2:v3:stk') + = action i j tk st sts (fn v1 v2 v3 : stk') +happySpecReduce_3 _ _ _ _ _ _ _ + = notHappyAtAll + +happyReduce k i fn (-1) tk _ (st@(HappyState action):sts) stk + = action (-1) (-1) tk st sts stk +happyReduce k i fn j tk st sts stk = action i j tk st' sts' (fn stk) + where sts'@(st'@(HappyState action):_) = drop (k::Int) (st:sts) + +happyMonadReduce k i c fn (-1) tk _ sts stk + = case sts of + (st@(HappyState action):sts) -> action (-1) (-1) tk st sts stk + [] -> happyError +happyMonadReduce k i c fn j tk st sts stk = + happyThen (fn stk) (\r -> action i j tk st' sts' (c r : stk')) + where sts'@(st'@(HappyState action):_) = drop (k::Int) (st:sts) + stk' = drop (k::Int) stk + +----------------------------------------------------------------------------- +-- Moving to a new state after a reduction + +happyGoto action j tk st = action j j tk (HappyState action) + +----------------------------------------------------------------------------- +-- Error recovery (-1 is the error token) + +-- fail if we are in recovery and no more states to discard +{-# NOINLINE happyFail #-} +-- NOINLINE else GHC diverges with the contravariant data type bug +-- See test simplCore/should_compile/simpl012 +happyFail (-1) tk st' [] stk = happyError + +-- discard a state +happyFail (-1) tk st' (st@(HappyState action):sts) stk = +-- _trace "discarding state" $ + action (-1) (-1) tk st sts stk + +-- Enter error recovery: generate an error token, +-- save the old token and carry on. + +-- we push the error token on the stack in anticipation of a shift, +-- and also because this is a convenient place to store the saved token. + +happyFail i tk st@(HappyState action) sts stk = +-- _trace "entering error recovery" $ + action (-1) (-1) tk st sts (HappyErrorToken i : stk) + +-- Internal happy errors: + +notHappyAtAll = error "Internal Happy error\n" + +-- end of Happy Template. |