ghc/tests/typecheck/should_compile/tc095.hs

   1 {-
   2 Bug report from Jon Mountjoy:
   3
   4 While playing with Happy I managed to generate a Haskell program
   5 which compiles fine under ghc but not under Hugs.  I don't know which
   6 one is the culprit....
   7
   8 In Hugs(January 1998), one gets
   9
  10      ERROR "hugs.hs" (line 32): Unresolved top-level overloading
  11      *** Binding             : happyReduce_1
  12      *** Outstanding context : Functor b
  13
  14 where line 32 is the one marked -- ##
  15
  16 It compiles in ghc-3.00.  Changing very small things, like the
  17 line marked ---**** to
  18       action_0 (6) = happyShift action_0        ---****
  19
  20 then makes ghc produce a similar message:
  21
  22    hugs.hs:37:
  23    Cannot resolve the ambiguous context (Functor a1Ab)
  24    `Functor a1Ab' arising from use of `reduction', at hugs.hs:37
  25 -}
  26
  27 module ShouldSucceed where
  28
  29 data HappyAbsSyn t1 t2 t3
  30         = HappyTerminal Token
  31         | HappyErrorToken Int
  32         | HappyAbsSyn1 t1
  33         | HappyAbsSyn2 t2
  34         | HappyAbsSyn3 t3
  35
  36 action_0 (6) = happyShift action_3        --- *****
  37 action_0 (1) = happyGoto action_1
  38 action_0 (2) = happyGoto action_2
  39 action_0 _ = happyFail
  40
  41 action_1 (7) = happyAccept
  42 action_1 _ = happyFail
  43
  44 action_2 _ = happyReduce_1
  45
  46 action_3 (5) = happyShift action_4
  47 action_3 _ = happyFail
  48
  49 action_4 (4) = happyShift action_6
  50 action_4 (3) = happyGoto action_5
  51 action_4 _ = happyFail
  52
  53 action_5 _ = happyReduce_2
  54
  55 action_6 _ = happyReduce_3
  56
  57 happyReduce_1 = happySpecReduce_1 1 reduction where {    -- ##
  58   reduction
  59         (HappyAbsSyn2  happy_var_1)
  60          =  HappyAbsSyn1
  61                  (\p -> let q = map (\(x,y) -> (x,y p)) happy_var_1 in  (10.1))
  62 ;
  63   reduction _  = notHappyAtAll }
  64
  65 happyReduce_2 = happySpecReduce_3 2 reduction where {
  66   reduction
  67         (HappyAbsSyn3  happy_var_3)
  68         _
  69         (HappyTerminal (TokenVar happy_var_1))
  70          =  HappyAbsSyn2
  71                  ([(happy_var_1,happy_var_3)]);
  72   reduction _ _ _  = notHappyAtAll }
  73
  74 happyReduce_3 = happySpecReduce_1 3 reduction where {
  75   reduction
  76         (HappyTerminal (TokenInt happy_var_1))
  77          =  HappyAbsSyn3
  78                  (\p -> happy_var_1);
  79   reduction _  = notHappyAtAll }
  80
  81 happyNewToken action sts stk [] =
  82         action 7 7 (error "reading EOF!") (HappyState action) sts stk []
  83
  84 happyNewToken action sts stk (tk:tks) =
  85         let cont i = action i i tk (HappyState action) sts stk tks in
  86         case tk of {
  87         TokenInt happy_dollar_dollar -> cont 4;
  88         TokenEq -> cont 5;
  89         TokenVar happy_dollar_dollar -> cont 6;
  90         }
  91
  92 happyThen = \m k -> k m
  93 happyReturn = \a tks -> a
  94 myparser = happyParse
  95
  96
  97
  98 happyError ::[Token] -> a
  99 happyError _ = error "Parse error\n"
 100
 101 --Here are our tokens
 102 data Token  =
 103               TokenInt Int
 104             | TokenVar String
 105             | TokenEq
 106             deriving Show
 107
 108 main = print (myparser [] [])
 109 -- $Id: tc095.hs,v 1.2 1999/01/23 17:58:16 sof Exp $
 110
 111 {-
 112         The stack is in the following order throughout the parse:
 113
 114         i       current token number
 115         j       another copy of this to avoid messing with the stack
 116         tk      current token semantic value
 117         st      current state
 118         sts     state stack
 119         stk     semantic stack
 120 -}
 121
 122 -----------------------------------------------------------------------------
 123
 124 happyParse = happyNewToken action_0 [] []
 125
 126 -- All this HappyState stuff is simply because we can't have recursive
 127 -- types in Haskell without an intervening data structure.
 128
 129 newtype HappyState b c = HappyState
 130         (Int ->                         -- token number
 131          Int ->                         -- token number (yes, again)
 132          b ->                           -- token semantic value
 133          HappyState b c ->              -- current state
 134          [HappyState b c] ->            -- state stack
 135          c)
 136
 137 -----------------------------------------------------------------------------
 138 -- Accepting the parse
 139
 140 happyAccept j tk st sts [ HappyAbsSyn1 ans ] = happyReturn ans
 141 happyAccept j tk st sts _                    = notHappyAtAll
 142
 143 -----------------------------------------------------------------------------
 144 -- Shifting a token
 145
 146 happyShift new_state (-1) tk st sts stk@(HappyErrorToken i : _) =
 147 --     _trace "shifting the error token" $
 148      new_state i i tk (HappyState new_state) (st:sts) stk
 149
 150 happyShift new_state i tk st sts stk =
 151      happyNewToken new_state (st:sts) (HappyTerminal tk:stk)
 152
 153 -----------------------------------------------------------------------------
 154 -- Reducing
 155
 156 -- happyReduce is specialised for the common cases.
 157
 158 -- don't allow reductions when we're in error recovery, because this can
 159 -- lead to an infinite loop.
 160
 161 happySpecReduce_0 i fn (-1) tk _ sts stk
 162      = case sts of
 163         st@(HappyState action):sts -> action (-1) (-1) tk st sts stk
 164         _ -> happyError
 165 happySpecReduce_0 i fn j tk st@(HappyState action) sts stk
 166      = action i j tk st (st:sts) (fn : stk)
 167
 168 happySpecReduce_1 i fn (-1) tk _ (st@(HappyState action):sts) stk
 169      = action (-1) (-1) tk st sts stk
 170 happySpecReduce_1 i fn j tk _ sts@(st@(HappyState action):_) (v1:stk')
 171      = action i j tk st sts (fn v1 : stk')
 172 happySpecReduce_1 _ _ _ _ _ _ _
 173      = notHappyAtAll
 174
 175 happySpecReduce_2 i fn (-1) tk _ (st@(HappyState action):sts) stk
 176      = action (-1) (-1) tk st sts stk
 177 happySpecReduce_2 i fn j tk _ (_:sts@(st@(HappyState action):_)) (v1:v2:stk')
 178      = action i j tk st sts (fn v1 v2 : stk')
 179 happySpecReduce_2 _ _ _ _ _ _ _
 180      = notHappyAtAll
 181
 182 happySpecReduce_3 i fn (-1) tk _ (st@(HappyState action):sts) stk
 183      = action (-1) (-1) tk st sts stk
 184 happySpecReduce_3 i fn j tk _ (_:_:sts@(st@(HappyState action):_))
 185         (v1:v2:v3:stk')
 186      = action i j tk st sts (fn v1 v2 v3 : stk')
 187 happySpecReduce_3 _ _ _ _ _ _ _
 188      = notHappyAtAll
 189
 190 happyReduce k i fn (-1) tk _ (st@(HappyState action):sts) stk
 191      = action (-1) (-1) tk st sts stk
 192 happyReduce k i fn j tk st sts stk = action i j tk st' sts' (fn stk)
 193        where sts'@(st'@(HappyState action):_) = drop (k::Int) (st:sts)
 194
 195 happyMonadReduce k i c fn (-1) tk _ sts stk
 196       = case sts of
 197              (st@(HappyState action):sts) -> action (-1) (-1) tk st sts stk
 198              [] -> happyError
 199 happyMonadReduce k i c fn j tk st sts stk =
 200         happyThen (fn stk) (\r -> action i j tk st' sts' (c r : stk'))
 201        where sts'@(st'@(HappyState action):_) = drop (k::Int) (st:sts)
 202              stk' = drop (k::Int) stk
 203
 204 -----------------------------------------------------------------------------
 205 -- Moving to a new state after a reduction
 206
 207 happyGoto action j tk st = action j j tk (HappyState action)
 208
 209 -----------------------------------------------------------------------------
 210 -- Error recovery (-1 is the error token)
 211
 212 -- fail if we are in recovery and no more states to discard
 213 happyFail  (-1) tk st' [] stk = happyError
 214
 215 -- discard a state
 216 happyFail  (-1) tk st' (st@(HappyState action):sts) stk =
 217 --      _trace "discarding state" $
 218         action (-1) (-1) tk st sts stk
 219
 220 -- Enter error recovery: generate an error token,
 221 --                       save the old token and carry on.
 222
 223 -- we push the error token on the stack in anticipation of a shift,
 224 -- and also because this is a convenient place to store the saved token.
 225
 226 happyFail  i tk st@(HappyState action) sts stk =
 227 --      _trace "entering error recovery" $
 228         action (-1) (-1) tk st sts (HappyErrorToken i : stk)
 229
 230 -- Internal happy errors:
 231
 232 notHappyAtAll = error "Internal Happy error\n"
 233
 234 -- end of Happy Template.