Make another parse error more informative

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

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index ef761e6..90220d3 100644 (file)
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -70,6 +70,7 @@ import FastString
 import Maybes
 
 import Control.Applicative ((<$>))       
 import Maybes
 
 import Control.Applicative ((<$>))       

+import Control.Monad

 import Text.ParserCombinators.ReadP as ReadP
 import Data.List        ( nubBy )
 import Data.Char
 import Text.ParserCombinators.ReadP as ReadP
 import Data.List        ( nubBy )
 import Data.Char

@@ -172,13 +173,14 @@ Similarly for mkConDecl, mkClassOpSig and default-method names.
   
 \begin{code}
 mkClassDecl :: SrcSpan
   
 \begin{code}
 mkClassDecl :: SrcSpan

-            -> Located (LHsContext RdrName, LHsType RdrName) 
+            -> Located (Maybe (LHsContext RdrName), LHsType RdrName)

             -> Located [Located (FunDep RdrName)]
             -> Located (OrdList (LHsDecl RdrName))
            -> P (LTyClDecl RdrName)
 
             -> Located [Located (FunDep RdrName)]
             -> Located (OrdList (LHsDecl RdrName))
            -> P (LTyClDecl RdrName)
 

-mkClassDecl loc (L _ (cxt, tycl_hdr)) fds where_cls
+mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls

   = do { let (binds, sigs, ats, docs) = cvBindsAndSigs (unLoc where_cls)
   = do { let (binds, sigs, ats, docs) = cvBindsAndSigs (unLoc where_cls)

+       ; let cxt = fromMaybe (noLoc []) mcxt

        ; (cls, tparams) <- checkTyClHdr tycl_hdr
        ; tyvars <- checkTyVars tparams      -- Only type vars allowed
        ; checkKindSigs ats
        ; (cls, tparams) <- checkTyClHdr tycl_hdr
        ; tyvars <- checkTyVars tparams      -- Only type vars allowed
        ; checkKindSigs ats

@@ -189,14 +191,16 @@ mkClassDecl loc (L _ (cxt, tycl_hdr)) fds where_cls
 mkTyData :: SrcSpan
          -> NewOrData
         -> Bool                -- True <=> data family instance
 mkTyData :: SrcSpan
          -> NewOrData
         -> Bool                -- True <=> data family instance

-         -> Located (LHsContext RdrName, LHsType RdrName)
+         -> Located (Maybe (LHsContext RdrName), LHsType RdrName)

          -> Maybe Kind
          -> [LConDecl RdrName]
          -> Maybe [LHsType RdrName]
          -> P (LTyClDecl RdrName)
          -> Maybe Kind
          -> [LConDecl RdrName]
          -> Maybe [LHsType RdrName]
          -> P (LTyClDecl RdrName)

-mkTyData loc new_or_data is_family (L _ (cxt, tycl_hdr)) ksig data_cons maybe_deriv
+mkTyData loc new_or_data is_family (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv

   = do { (tc, tparams) <- checkTyClHdr tycl_hdr
 
   = do { (tc, tparams) <- checkTyClHdr tycl_hdr
 

+       ; checkDatatypeContext mcxt
+       ; let cxt = fromMaybe (noLoc []) mcxt

        ; (tyvars, typats) <- checkTParams is_family tparams
        ; return (L loc (TyData { tcdND = new_or_data, tcdCtxt = cxt, tcdLName = tc,
                                 tcdTyVars = tyvars, tcdTyPats = typats, 
        ; (tyvars, typats) <- checkTParams is_family tparams
        ; return (L loc (TyData { tcdND = new_or_data, tcdCtxt = cxt, tcdLName = tc,
                                 tcdTyVars = tyvars, tcdTyPats = typats, 

@@ -358,7 +362,7 @@ splitCon ty
    split (L _ (HsAppTy t u)) ts = split t (u : ts)
    split (L l (HsTyVar tc))  ts = do data_con <- tyConToDataCon l tc
                                     return (data_con, mk_rest ts)
    split (L _ (HsAppTy t u)) ts = split t (u : ts)
    split (L l (HsTyVar tc))  ts = do data_con <- tyConToDataCon l tc
                                     return (data_con, mk_rest ts)

-   split (L l _) _             = parseError l "parse error in data/newtype declaration"
+   split (L l _) _             = parseErrorSDoc l (text "parse error in constructor in data/newtype declaration:" <+> ppr ty)

 
    mk_rest [L _ (HsRecTy flds)] = RecCon flds
    mk_rest ts                   = PrefixCon ts
 
    mk_rest [L _ (HsRecTy flds)] = RecCon flds
    mk_rest ts                   = PrefixCon ts

@@ -521,6 +525,13 @@ checkTyVars tparms = mapM chk tparms
     chk (L l _)            =
          parseError l "Type found where type variable expected"
 
     chk (L l _)            =
          parseError l "Type found where type variable expected"
 

+checkDatatypeContext :: Maybe (LHsContext RdrName) -> P ()
+checkDatatypeContext Nothing = return ()
+checkDatatypeContext (Just (L loc _))
+    = do allowed <- extension datatypeContextsEnabled
+         unless allowed $
+             parseError loc "Illegal datatype context (use -XDatatypeContexts)"
+

 checkTyClHdr :: LHsType RdrName
              -> P (Located RdrName,         -- the head symbol (type or class name)
                   [LHsType RdrName])        -- parameters of head symbol
 checkTyClHdr :: LHsType RdrName
              -> P (Located RdrName,         -- the head symbol (type or class name)
                   [LHsType RdrName])        -- parameters of head symbol

@@ -788,12 +799,14 @@ checkValSig
 checkValSig (L l (HsVar v)) ty 
   | isUnqual v && not (isDataOcc (rdrNameOcc v))
   = return (TypeSig (L l v) ty)
 checkValSig (L l (HsVar v)) ty 
   | isUnqual v && not (isDataOcc (rdrNameOcc v))
   = return (TypeSig (L l v) ty)

-checkValSig lhs@(L l _)         _
-  | looks_like_foreign lhs
-  = parseError l "Invalid type signature; perhaps you meant to use -XForeignFunctionInterface?"
-  | otherwise
-  = parseError l "Invalid type signature: should be of form <variable> :: <type>"
+checkValSig lhs@(L l _) ty
+  = parseErrorSDoc l ((text "Invalid type signature:" <+>
+                       ppr lhs <+> text "::" <+> ppr ty)
+                   $$ text hint)

   where
   where

+    hint = if looks_like_foreign lhs
+           then "Perhaps you meant to use -XForeignFunctionInterface?"
+           else "Should be of form <variable> :: <type>"

     -- A common error is to forget the ForeignFunctionInterface flag
     -- so check for that, and suggest.  cf Trac #3805
     -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword
     -- A common error is to forget the ForeignFunctionInterface flag
     -- so check for that, and suggest.  cf Trac #3805
     -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword