Clarify error message (Trac #3805)

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

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 03ca542..b86068c 100644 (file)
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -12,7 +12,7 @@ module RdrHsSyn (
        mkHsIntegral, mkHsFractional, mkHsIsString,
        mkHsDo, mkHsSplice, mkTopSpliceDecl,
         mkClassDecl, mkTyData, mkTyFamily, mkTySynonym,
-        splitCon, mkInlineSpec,        
+        splitCon, mkInlinePragma,      
        mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
 
        cvBindGroup,
@@ -54,9 +54,8 @@ import Class            ( FunDep )
 import TypeRep          ( Kind )
 import RdrName         ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, 
                          isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace )
-import BasicTypes      ( maxPrecedence, Activation, RuleMatchInfo,
-                          InlinePragma(..),  InlineSpec(..),
-                          alwaysInlineSpec, neverInlineSpec )
+import BasicTypes      ( maxPrecedence, Activation(..), RuleMatchInfo,
+                          InlinePragma(..) )
 import Lexer
 import TysWiredIn      ( unitTyCon ) 
 import ForeignCall
@@ -74,7 +73,7 @@ import Maybes
 import Control.Applicative ((<$>))       
 import Text.ParserCombinators.ReadP as ReadP
 import Data.List        ( nubBy )
-import Data.Char        ( isAscii, isAlphaNum, isAlpha )
+import Data.Char
 
 #include "HsVersions.h"
 \end{code}
@@ -550,12 +549,14 @@ checkInstType (L l t)
 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 (HsTyVar tc)            args | isRdrTc tc = done tc args
+  check (HsOpTy t1 (L _ tc) t2) args | isRdrTc tc = done tc (t1:t2: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"
 
+  done tc args = return (L spn (HsPredTy (HsClassP tc args)))
+
 checkTParams :: Bool     -- Type/data family
             -> [LHsType RdrName]
             -> P ([LHsTyVarBndr RdrName], Maybe [LHsType RdrName])
@@ -866,8 +867,20 @@ checkValSig
 checkValSig (L l (HsVar v)) ty 
   | isUnqual v && not (isDataOcc (rdrNameOcc v))
   = return (TypeSig (L l v) ty)
-checkValSig (L l _)         _
-  = parseError l "Invalid type signature"
+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>"
+  where
+    -- 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
+    looks_like_foreign (L _ (HsVar v))     = v == foreign_RDR
+    looks_like_foreign (L _ (HsApp lhs _)) = looks_like_foreign lhs
+    looks_like_foreign _                   = False
+
+    foreign_RDR = mkUnqual varName (fsLit "foreign")
 \end{code}
 
 
@@ -960,13 +973,21 @@ mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg
 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
 mk_rec_fields fs True  = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
 
-mkInlineSpec :: Maybe Activation -> RuleMatchInfo -> Bool -> InlineSpec
--- The Maybe is becuase the user can omit the activation spec (and usually does)
-mkInlineSpec Nothing    match_info True  = alwaysInlineSpec match_info
-                                                                -- INLINE
-mkInlineSpec Nothing   match_info False = neverInlineSpec  match_info
-                                                                -- NOINLINE
-mkInlineSpec (Just act) match_info inl   = Inline (InlinePragma act match_info) inl
+mkInlinePragma :: Maybe Activation -> RuleMatchInfo -> Bool -> InlinePragma
+-- The Maybe is because the user can omit the activation spec (and usually does)
+mkInlinePragma mb_act match_info inl 
+  = InlinePragma { inl_inline = inl
+                 , inl_sat    = Nothing
+                 , inl_act    = act
+                 , inl_rule   = match_info }
+  where
+    act = case mb_act of
+            Just act -> act
+            Nothing | inl       -> AlwaysActive
+                    | otherwise -> NeverActive
+        -- If no specific phase is given then:
+       --   NOINLINE => NeverActive
+        --   INLINE   => Active
 
 -----------------------------------------------------------------------------
 -- utilities for foreign declarations
@@ -979,9 +1000,10 @@ mkImport :: CCallConv
         -> P (HsDecl RdrName)
 mkImport cconv safety (L loc entity, v, ty)
   | cconv == PrimCallConv                      = do
-  let funcTarget = CFunction (StaticTarget entity)
+  let funcTarget = CFunction (StaticTarget entity Nothing)
       importSpec = CImport PrimCallConv safety nilFS funcTarget
   return (ForD (ForeignImport v ty importSpec))
+
   | otherwise = do
     case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of
       Nothing         -> parseError loc "Malformed entity string"
@@ -996,21 +1018,27 @@ parseCImport cconv safety nm str =
  listToMaybe $ map fst $ filter (null.snd) $ 
      readP_to_S parse str
  where
-   parse = choice [
+   parse = do
+       skipSpaces
+       r <- choice [
           string "dynamic" >> return (mk nilFS (CFunction DynamicTarget)),
           string "wrapper" >> return (mk nilFS CWrapper),
           optional (string "static" >> skipSpaces) >> 
            (mk nilFS <$> cimp nm) +++
            (do h <- munch1 hdr_char; skipSpaces; mk (mkFastString h) <$> cimp nm)
-       ]
+         ]
+       skipSpaces
+       return r
 
    mk = CImport cconv safety
 
-   hdr_char c = isAscii c && (isAlphaNum c || c `elem` "._")
+   hdr_char c = not (isSpace c) -- header files are filenames, which can contain
+                                -- pretty much any char (depending on the platform),
+                                -- so just accept any non-space character
    id_char  c = isAlphaNum c || c == '_'
 
    cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
-             +++ ((CFunction . StaticTarget) <$> cid)
+             +++ ((\c -> CFunction (StaticTarget c Nothing)) <$> cid)
           where 
             cid = return nm +++
                   (do c  <- satisfy (\c -> isAlpha c || c == '_')