Fix Trac #1122; spot absence of TyCon in data/newtype header

[ghc-hetmet.git] / compiler / parser / RdrHsSyn.lhs

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 0cfa292..ddff68f 100644 (file)
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -9,7 +9,7 @@ module RdrHsSyn (
        extractHsRhoRdrTyVars, extractGenericPatTyVars,
  
        mkHsOpApp, mkClassDecl,
-       mkHsNegApp, mkHsIntegral, mkHsFractional,
+       mkHsNegApp, mkHsIntegral, mkHsFractional, mkHsIsString,
        mkHsDo, mkHsSplice,
         mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec, 
        mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
@@ -54,7 +54,7 @@ module RdrHsSyn (
 #include "HsVersions.h"
 
 import HsSyn           -- Lots of it
-import RdrName         ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc, 
+import RdrName         ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, 
                          isRdrDataCon, isUnqual, getRdrName, isQual,
                          setRdrNameSpace )
 import BasicTypes      ( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec )
@@ -468,13 +468,12 @@ checkTyClHdr (L l cxt) ty
   where
     gol (L l ty) acc = go l ty acc
 
-    go l (HsTyVar tc)    acc 
-       | not (isRdrTyVar tc)   = do
-                                   tvs <- extractTyVars acc
-                                   return (L l tc, tvs, acc)
-    go l (HsOpTy t1 tc t2) acc  = do
-                                   tvs <- extractTyVars (t1:t2:acc)
-                                   return (tc, tvs, acc)
+    go l (HsTyVar tc) acc 
+       | isRdrTc tc            = do tvs <- extractTyVars acc
+                                    return (L l tc, tvs, acc)
+    go l (HsOpTy t1 ltc@(L _ tc) t2) acc
+       | isRdrTc tc            = do tvs <- extractTyVars (t1:t2:acc)
+                                    return (ltc, tvs, acc)
     go l (HsParTy ty)    acc    = gol ty acc
     go l (HsAppTy t1 t2) acc    = gol t1 (t2:acc)
     go l other          acc    = 
@@ -797,7 +796,7 @@ mk_gadt_con name qvars cxt ty
        -- The parser left-associates, so there should 
        -- not be any OpApps inside the e's
 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
--- Splits (f ! g a b) into (f, [(! g), a, g])
+-- Splits (f ! g a b) into (f, [(! g), a, b])
 splitBang (L loc (OpApp l_arg bang@(L loc' (HsVar op)) _ r_arg))
   | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
   where
@@ -809,6 +808,16 @@ splitBang other = Nothing
 isFunLhs :: LHsExpr RdrName 
         -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
 -- Just (fun, is_infix, arg_pats) if e is a function LHS
+--
+-- The whole LHS is parsed as a single expression.  
+-- Any infix operators on the LHS will parse left-associatively
+-- E.g.        f !x y !z
+--     will parse (rather strangely) as 
+--             (f ! x y) ! z
+--     It's up to isFunLhs to sort out the mess
+--
+-- a .!. !b 
+
 isFunLhs e = go e []
  where
    go (L loc (HsVar f)) es