X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fparser%2FRdrHsSyn.lhs;h=ddff68f5761ef3650fdb8d871fa08d55ccee09c1;hb=3bec818f91e382b882f8de4bdab8036884eb657f;hp=03d4c413a149b38b594b961573108a8204b8c2d0;hpb=e343a6ca48114f26ac8bb90af543c6ec5bd5a2d4;p=ghc-hetmet.git

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 03d4c41..ddff68f 100644
--- 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 )
@@ -97,8 +97,9 @@ extractHsRhoRdrTyVars ctxt ty
 
 extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
 
-extract_pred (HsClassP cls tys) acc	= foldr extract_lty acc tys
-extract_pred (HsIParam n ty) acc	= extract_lty ty acc
+extract_pred (HsClassP cls tys) acc = foldr extract_lty acc tys
+extract_pred (HsEqualP ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
+extract_pred (HsIParam n ty   ) acc = extract_lty ty acc
 
 extract_lty (L loc ty) acc 
   = case ty of
@@ -214,21 +215,21 @@ cvBindGroup binding
         ValBindsIn mbs sigs
 
 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
-  -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [DocEntity RdrName])
+  -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl RdrName])
 -- Input decls contain just value bindings and signatures
 -- and in case of class or instance declarations also
 -- associated type declarations. They might also contain Haddock comments.
 cvBindsAndSigs  fb = go (fromOL fb)
   where
     go [] 		   = (emptyBag, [], [], [])
-    go (L l x@(SigD s) : ds) = (bs, L l s : ss, ts, add_doc x docs)
+    go (L l x@(SigD s) : ds) = (bs, L l s : ss, ts, docs)
 			    where (bs, ss, ts, docs) = go ds
-    go (L l x@(ValD b) : ds) = (b' `consBag` bs, ss, ts, add_doc x docs)
+    go (L l x@(ValD b) : ds) = (b' `consBag` bs, ss, ts, docs)
 			    where (b', ds')    = getMonoBind (L l b) ds
 				  (bs, ss, ts, docs) = go ds'
     go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
 			    where (bs, ss, ts, docs) = go ds
-    go (L _ (DocD d) : ds)     =  (bs, ss, ts, DocEntity d : docs)
+    go (L l (DocD d) : ds)     =  (bs, ss, ts, (L l d) : docs)
 			    where (bs, ss, ts, docs) = go ds
 
 -----------------------------------------------------------------------------
@@ -303,28 +304,25 @@ add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
 add gp l (SpliceD e) ds = (gp, Just (e, ds))
 
 -- Class declarations: pull out the fixity signatures to the top
-add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs, hs_docs = docs}) 
-    l decl@(TyClD d) ds
+add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) 
+    l (TyClD d) ds
 	| isClassDecl d = 	
 		let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
-		addl (gp { hs_tyclds = L l d : ts, 
-                           hs_fixds = fsigs ++ fs,
-                           hs_docs = add_doc decl docs}) ds
-	| isIdxTyDecl d = 
+		addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds
+	| isFamInstDecl d = 
 	        addl (gp { hs_tyclds = L l d : ts }) ds
 	| otherwise =
-		addl (gp { hs_tyclds = L l d : ts, 
-                           hs_docs = add_doc decl docs }) ds
+		addl (gp { hs_tyclds = L l d : ts }) ds
 
 -- Signatures: fixity sigs go a different place than all others
 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
   = addl (gp {hs_fixds = L l f : ts}) ds
-add gp@(HsGroup {hs_valds = ts, hs_docs = docs}) l x@(SigD d) ds
-  = addl (gp {hs_valds = add_sig (L l d) ts, hs_docs = add_doc x docs}) ds
+add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
+  = addl (gp {hs_valds = add_sig (L l d) ts}) ds
 
 -- Value declarations: use add_bind
-add gp@(HsGroup {hs_valds  = ts, hs_docs = docs}) l x@(ValD d) ds
-  = addl (gp { hs_valds = add_bind (L l d) ts, hs_docs = add_doc x docs }) ds
+add gp@(HsGroup {hs_valds  = ts}) l (ValD d) ds
+  = addl (gp { hs_valds = add_bind (L l d) ts }) ds
 
 -- The rest are routine
 add gp@(HsGroup {hs_instds = ts})  l (InstD d) ds
@@ -333,20 +331,16 @@ add gp@(HsGroup {hs_derivds = ts})  l (DerivD d) ds
   = addl (gp { hs_derivds = L l d : ts }) ds
 add gp@(HsGroup {hs_defds  = ts})  l (DefD d) ds
   = addl (gp { hs_defds = L l d : ts }) ds
-add gp@(HsGroup {hs_fords  = ts, hs_docs = docs}) l x@(ForD d) ds
-  = addl (gp { hs_fords = L l d : ts, hs_docs = add_doc x docs }) ds
+add gp@(HsGroup {hs_fords  = ts}) l (ForD d) ds
+  = addl (gp { hs_fords = L l d : ts }) ds
 add gp@(HsGroup {hs_depds  = ts})  l (DeprecD d) ds
   = addl (gp { hs_depds = L l d : ts }) ds
 add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD d) ds
   = addl (gp { hs_ruleds = L l d : ts }) ds
 
 add gp l (DocD d) ds
-  = addl (gp { hs_docs = DocEntity d : (hs_docs gp) })  ds
+  = addl (gp { hs_docs = (L l d) : (hs_docs gp) })  ds
 
-add_doc decl docs = case getMainDeclBinder decl of 
-  Just name -> DeclEntity name : docs
-  Nothing   -> docs
- 
 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
 add_sig  s (ValBindsIn bs sigs) = ValBindsIn bs	              (s:sigs) 
 \end{code}
@@ -406,6 +400,15 @@ checkInstType (L l t)
 	ty ->   do dict_ty <- checkDictTy (L l ty)
 	      	   return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
 
+checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
+checkDictTy (L spn ty) = check ty []
+  where
+  check (HsTyVar t) args | not (isRdrTyVar t) 
+  	= return (L spn (HsPredTy (HsClassP t args)))
+  check (HsAppTy l r) args = check (unLoc l) (r:args)
+  check (HsParTy t)   args = check (unLoc t) args
+  check _ _ = parseError spn "Malformed instance header"
+
 -- Check whether the given list of type parameters are all type variables
 -- (possibly with a kind signature).  If the second argument is `False',
 -- only type variables are allowed and we raise an error on encountering a
@@ -465,22 +468,23 @@ 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    = 
       parseError l "Malformed head of type or class declaration"
 
-	-- The predicates in a type or class decl must all
-	-- be HsClassPs.  They need not all be type variables,
-	-- even in Haskell 98.  E.g. class (Monad m, Monad (t m)) => MonadT t m
-    chk_pred (L l (HsClassP _ args)) = return ()
+	-- The predicates in a type or class decl must be class predicates or 
+	-- equational constraints.  They need not all have variable-only
+	-- arguments, even in Haskell 98.  
+	-- E.g. class (Monad m, Monad (t m)) => MonadT t m
+    chk_pred (L l (HsClassP _ _)) = return ()
+    chk_pred (L l (HsEqualP _ _)) = return ()
     chk_pred (L l _)
        = parseError l "Malformed context in type or class declaration"
 
@@ -536,7 +540,7 @@ checkKindSigs :: [LTyClDecl RdrName] -> P ()
 checkKindSigs = mapM_ check
   where
     check (L l tydecl) 
-      | isKindSigDecl tydecl
+      | isFamilyDecl tydecl
         || isSynDecl tydecl  = return ()
       | otherwise	     = 
 	parseError l "Type declaration in a class must be a kind signature or synonym default"
@@ -571,22 +575,16 @@ checkPred (L spn ty)
   where
     checkl (L l ty) args = check l ty args
 
+    check _loc (HsPredTy pred@(HsEqualP _ _)) 
+                                       args | null args
+					    = return $ L spn pred
     check _loc (HsTyVar t)             args | not (isRdrTyVar t) 
 		 		  	    = return (L spn (HsClassP t args))
     check _loc (HsAppTy l r)           args = checkl l (r:args)
     check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
     check _loc (HsParTy t)  	       args = checkl t args
-    check loc _                        _    = parseError loc  "malformed class assertion"
-
-checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
-checkDictTy (L spn ty) = check ty []
-  where
-  check (HsTyVar t) args | not (isRdrTyVar t) 
-  	= return (L spn (HsPredTy (HsClassP t args)))
-  check (HsAppTy l r) args = check (unLoc l) (r:args)
-  check (HsParTy t)   args = check (unLoc t) args
-  check _ _ = parseError spn "Malformed context in instance header"
-
+    check loc _                        _    = parseError loc  
+					        "malformed class assertion"
 
 ---------------------------------------------------------------------------
 -- Checking stand-alone deriving declarations
@@ -798,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
@@ -810,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