From dbc5175b51bd894a47b2ef6d69b76c5eb660c294 Mon Sep 17 00:00:00 2001
From: simonm <unknown>
Date: Mon, 23 Feb 1998 15:35:32 +0000
Subject: [PATCH] [project @ 1998-02-23 15:35:31 by simonm] Hugs type-checker
 bug.

---
 ghc/tests/typecheck/should_compile/tc095.hs   | 234 ++++++++++++++++++
 .../typecheck/should_compile/tc095.stderr     |  54 ++++
 2 files changed, 288 insertions(+)
 create mode 100644 ghc/tests/typecheck/should_compile/tc095.hs
 create mode 100644 ghc/tests/typecheck/should_compile/tc095.stderr

diff --git a/ghc/tests/typecheck/should_compile/tc095.hs b/ghc/tests/typecheck/should_compile/tc095.hs
new file mode 100644
index 000000000000..95205ba0f4a0
--- /dev/null
+++ b/ghc/tests/typecheck/should_compile/tc095.hs
@@ -0,0 +1,234 @@
+{-
+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.1 1998/02/23 15:35:31 simonm 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
+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.
diff --git a/ghc/tests/typecheck/should_compile/tc095.stderr b/ghc/tests/typecheck/should_compile/tc095.stderr
new file mode 100644
index 000000000000..21ade02ef25a
--- /dev/null
+++ b/ghc/tests/typecheck/should_compile/tc095.stderr
@@ -0,0 +1,54 @@
+ghc: module version changed to 1; reason: no old .hi file
+_interface_ ShouldSucceed 1
+_instance_modules_
+IO PrelAddr PrelArr PrelBounded PrelCCall PrelForeign PrelNum
+_usages_
+PrelBase 1 :: $d1 1 $d10 1 $d11 1 $d12 1 $d13 1 $d15 1 $d19 1 $d2 1 $d20 1 $d21 1 $d24 1 $d25 1 $d26 1 $d27 1 $d28 1 $d29 1 $d3 1 $d30 1 $d31 1 $d33 1 $d34 1 $d36 1 $d37 1 $d38 1 $d39 1 $d4 1 $d40 1 $d41 1 $d42 1 $d43 1 $d5 1 $d6 1 $d7 1 $d8 1 $d9 1 $m- 1 $m/= 1 $m< 1 $m<= 1 $m> 1 $m>= 1 $mcompare 1 $menumFromThenTo 1 $menumFromTo 1 $mfromInt 1 $mmax 1 $mmin 1 $mshowList 1 . 1 showList__ 1 showParen 1 showSpace 1 showString 1 Enum 1 Eq 1 Eval 1 Functor 1 Num 1 Ord 1 Ordering 1 Show 1 ShowS 1 String 1;
+PrelIO 1 :: print 1;
+PrelIOBase 1 :: $d2 1 $d4 1 $d7 1 IO 1;
+PrelList 1 :: drop 1;
+PrelNum 1 :: $d1 1 $d10 1 $d14 1 $d15 1 $d16 1 $d17 1 $d18 1 $d2 1 $d29 1 $d30 1 $d31 1 $d32 1 $d33 1 $d34 1 $d35 1 $d36 1 $d37 1 $d38 1 $d39 1 $d4 1 $d5 1 $d6 1 $d7 1 $d8 1 $mdiv 1 $mdivMod 1 $mmod 1 $mquot 1 $mrecip 1 $mrem 1 Fractional 1 Integral 1 Ratio 1 Rational 1 Real 1;
+PrelTup 1 :: $d13 1 $d4 1 $d49 1 $d9 1;
+_exports_
+ShouldSucceed action_0 action_1 action_2 action_3 action_4 action_5 action_6 happyAccept happyError happyFail happyGoto happyMonadReduce happyNewToken happyParse happyReduce happyReduce_1 happyReduce_2 happyReduce_3 happyReturn happyShift happySpecReduce_0 happySpecReduce_1 happySpecReduce_2 happySpecReduce_3 happyThen main myparser notHappyAtAll HappyAbsSyn(HappyTerminal HappyErrorToken HappyAbsSyn1 HappyAbsSyn2 HappyAbsSyn3) HappyState(HappyState) Token(TokenInt TokenVar TokenEq);
+_instances_
+instance _forall_ [a b] => {PrelBase.Eval (HappyState a b)} = $d1;
+instance {PrelBase.Eval Token} = $d2;
+instance _forall_ [a b c] => {PrelBase.Eval (HappyAbsSyn a b c)} = $d3;
+instance {PrelBase.Show Token} = $d4;
+_declarations_
+1 $d1 _:_ _forall_ [a b] => {PrelBase.Eval (HappyState a b)} ;;
+1 $d2 _:_ {PrelBase.Eval Token} ;;
+1 $d3 _:_ _forall_ [a b c] => {PrelBase.Eval (HappyAbsSyn a b c)} ;;
+1 $d4 _:_ {PrelBase.Show Token} ;;
+1 action_0 _:_ _forall_ [a b] {PrelBase.Num a} => a -> PrelBase.Int -> Token -> HappyState Token ([HappyAbsSyn (b -> PrelBase.Double) [(PrelBase.String, b -> PrelBase.Int)] (b -> PrelBase.Int)] -> [Token] -> b -> PrelBase.Double) -> [HappyState Token ([HappyAbsSyn (b -> PrelBase.Double) [(PrelBase.String, b -> PrelBase.Int)] (b -> PrelBase.Int)] -> [Token] -> b -> PrelBase.Double)] -> [HappyAbsSyn (b -> PrelBase.Double) [(PrelBase.String, b -> PrelBase.Int)] (b -> PrelBase.Int)] -> [Token] -> b -> PrelBase.Double ;;
+1 action_1 _:_ _forall_ [a b c d e] {PrelBase.Num a} => a -> PrelBase.Int -> b -> HappyState b ([HappyAbsSyn e c d] -> [Token] -> e) -> [HappyState b ([HappyAbsSyn e c d] -> [Token] -> e)] -> [HappyAbsSyn e c d] -> [Token] -> e ;;
+1 action_2 _:_ _forall_ [a b c d e f g h] => a -> PrelBase.Int -> b -> c -> [HappyState b ([HappyAbsSyn (d -> PrelBase.Double) [(e, d -> f)] g] -> h)] -> [HappyAbsSyn (d -> PrelBase.Double) [(e, d -> f)] g] -> h ;;
+1 action_3 _:_ _forall_ [a b c d] {PrelBase.Num a} => a -> PrelBase.Int -> Token -> HappyState Token ([HappyAbsSyn c [(PrelBase.String, b -> PrelBase.Int)] (b -> PrelBase.Int)] -> [Token] -> d) -> [HappyState Token ([HappyAbsSyn c [(PrelBase.String, b -> PrelBase.Int)] (b -> PrelBase.Int)] -> [Token] -> d)] -> [HappyAbsSyn c [(PrelBase.String, b -> PrelBase.Int)] (b -> PrelBase.Int)] -> [Token] -> d ;;
+1 action_4 _:_ _forall_ [a b c d] {PrelBase.Num a} => a -> PrelBase.Int -> Token -> HappyState Token ([HappyAbsSyn c [(PrelBase.String, b -> PrelBase.Int)] (b -> PrelBase.Int)] -> [Token] -> d) -> [HappyState Token ([HappyAbsSyn c [(PrelBase.String, b -> PrelBase.Int)] (b -> PrelBase.Int)] -> [Token] -> d)] -> [HappyAbsSyn c [(PrelBase.String, b -> PrelBase.Int)] (b -> PrelBase.Int)] -> [Token] -> d ;;
+1 action_5 _:_ _forall_ [a b c d e f] => a -> PrelBase.Int -> b -> c -> [HappyState b ([HappyAbsSyn d [(PrelBase.String, e)] e] -> f)] -> [HappyAbsSyn d [(PrelBase.String, e)] e] -> f ;;
+1 action_6 _:_ _forall_ [a b c d e f g] => a -> PrelBase.Int -> b -> c -> [HappyState b ([HappyAbsSyn d e (f -> PrelBase.Int)] -> g)] -> [HappyAbsSyn d e (f -> PrelBase.Int)] -> g ;;
+1 data HappyAbsSyn t1 t2 t3 = HappyTerminal Token |  HappyErrorToken PrelBase.Int |  HappyAbsSyn1 t1 |  HappyAbsSyn2 t2 |  HappyAbsSyn3 t3 ;
+1 newtype HappyState b c = HappyState (PrelBase.Int -> PrelBase.Int -> b -> HappyState b c -> [HappyState b c] -> c) ;
+1 data Token = TokenInt PrelBase.Int |  TokenVar PrelBase.String |  TokenEq ;
+1 happyAccept _:_ _forall_ [a b c d e f g h] => a -> b -> c -> d -> [HappyAbsSyn e f g] -> h -> e ;;
+1 happyError _:_ _forall_ [a] => [Token] -> a ;;
+1 happyFail _:_ _forall_ [a b c d e] => PrelBase.Int -> b -> HappyState b ([HappyAbsSyn c d e] -> [Token] -> a) -> [HappyState b ([HappyAbsSyn c d e] -> [Token] -> a)] -> [HappyAbsSyn c d e] -> [Token] -> a ;;
+1 happyGoto _:_ _forall_ [a b c] => (PrelBase.Int -> PrelBase.Int -> b -> HappyState b c -> [HappyState b c] -> c) -> PrelBase.Int -> b -> a -> [HappyState b c] -> c ;;
+1 happyMonadReduce _:_ _forall_ [a b c d] => PrelBase.Int -> PrelBase.Int -> (c -> d) -> ([d] -> c) -> PrelBase.Int -> a -> HappyState a ([d] -> [Token] -> b) -> [HappyState a ([d] -> [Token] -> b)] -> [d] -> [Token] -> b ;;
+1 happyNewToken _:_ _forall_ [a b] => (PrelBase.Int -> PrelBase.Int -> Token -> HappyState Token (a -> [Token] -> b) -> [HappyState Token (a -> [Token] -> b)] -> a -> [Token] -> b) -> [HappyState Token (a -> [Token] -> b)] -> a -> [Token] -> b ;;
+1 happyParse _:_ _forall_ [a] => [Token] -> a -> PrelBase.Double ;;
+1 happyReduce _:_ _forall_ [a b c] => PrelBase.Int -> PrelBase.Int -> (c -> c) -> PrelBase.Int -> a -> HappyState a (c -> b) -> [HappyState a (c -> b)] -> c -> b ;;
+1 happyReduce_1 _:_ _forall_ [a b c d e f g] => PrelBase.Int -> a -> b -> [HappyState a ([HappyAbsSyn (e -> PrelBase.Double) [(d, e -> f)] g] -> c)] -> [HappyAbsSyn (e -> PrelBase.Double) [(d, e -> f)] g] -> c ;;
+1 happyReduce_2 _:_ _forall_ [a b c d e] => PrelBase.Int -> a -> b -> [HappyState a ([HappyAbsSyn d [(PrelBase.String, e)] e] -> c)] -> [HappyAbsSyn d [(PrelBase.String, e)] e] -> c ;;
+1 happyReduce_3 _:_ _forall_ [a b c d e f] => PrelBase.Int -> a -> b -> [HappyState a ([HappyAbsSyn d e (f -> PrelBase.Int)] -> c)] -> [HappyAbsSyn d e (f -> PrelBase.Int)] -> c ;;
+1 happyReturn _:_ _forall_ [a b] => a -> b -> a ;;
+1 happyShift _:_ _forall_ [a b c d e] {PrelBase.Num a} => (PrelBase.Int -> PrelBase.Int -> Token -> HappyState Token ([HappyAbsSyn c d e] -> [Token] -> b) -> [HappyState Token ([HappyAbsSyn c d e] -> [Token] -> b)] -> [HappyAbsSyn c d e] -> [Token] -> b) -> a -> Token -> HappyState Token ([HappyAbsSyn c d e] -> [Token] -> b) -> [HappyState Token ([HappyAbsSyn c d e] -> [Token] -> b)] -> [HappyAbsSyn c d e] -> [Token] -> b ;;
+1 happySpecReduce_0 _:_ _forall_ [a b c] => PrelBase.Int -> c -> PrelBase.Int -> a -> HappyState a ([c] -> [Token] -> b) -> [HappyState a ([c] -> [Token] -> b)] -> [c] -> [Token] -> b ;;
+1 happySpecReduce_1 _:_ _forall_ [a b c d] => PrelBase.Int -> (c -> c) -> PrelBase.Int -> b -> a -> [HappyState b ([c] -> d)] -> [c] -> d ;;
+1 happySpecReduce_2 _:_ _forall_ [a b c d] => PrelBase.Int -> (c -> c -> c) -> PrelBase.Int -> b -> a -> [HappyState b ([c] -> d)] -> [c] -> d ;;
+1 happySpecReduce_3 _:_ _forall_ [a b c d] => PrelBase.Int -> (c -> c -> c -> c) -> PrelBase.Int -> b -> a -> [HappyState b ([c] -> d)] -> [c] -> d ;;
+1 happyThen _:_ _forall_ [a b] => a -> (a -> b) -> b ;;
+1 main _:_ PrelIOBase.IO PrelBase.() ;;
+1 myparser _:_ _forall_ [a] => [Token] -> a -> PrelBase.Double ;;
+1 notHappyAtAll _:_ _forall_ [a] => a ;;
-- 
GitLab