summaryrefslogtreecommitdiff
path: root/testsuite/tests/typecheck/should_compile/tc095.hs
diff options
context:
space:
mode:
Diffstat (limited to 'testsuite/tests/typecheck/should_compile/tc095.hs')
-rw-r--r--testsuite/tests/typecheck/should_compile/tc095.hs237
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.
View Lorry Controller Status