X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FRdrHsSyn.lhs;h=ae4a15a2a1c29eafc0f0940978ba0c2e3d77546a;hp=d18b8d8fd91ce989236c092efce6030664e2ad40;hb=0a5613f40b0e32cf59966e6b56b807cdbe80aa7b;hpb=6e9c0431a7cf2bf1a48f01db48c6a1d41fe15a09

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index d18b8d8..ae4a15a 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -18,7 +18,6 @@ module RdrHsSyn (
 	cvBindGroup,
         cvBindsAndSigs,
 	cvTopDecls,
-	findSplice, checkDecBrGroup,
         placeHolderPunRhs,
 
 	-- Stuff to do with Foreign declarations
@@ -65,7 +64,7 @@ import PrelNames	( forall_tv_RDR )
 import DynFlags
 import SrcLoc
 import OrdList		( OrdList, fromOL )
-import Bag		( Bag, emptyBag, snocBag, consBag, foldrBag )
+import Bag		( Bag, emptyBag, consBag, foldrBag )
 import Outputable
 import FastString
 import Maybes
@@ -127,8 +126,8 @@ extract_lty (L loc ty) acc
       HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
       HsParTy ty               	-> extract_lty ty acc
       HsNumTy _                 -> acc
+      HsQuasiQuoteTy {}	        -> acc  -- Quasi quotes mention no type variables
       HsSpliceTy {}           	-> acc	-- Type splices mention no type variables
-      HsSpliceTyOut {}         	-> acc	-- Type splices mention no type variables
       HsKindSig ty _            -> extract_lty ty acc
       HsForAllTy _ [] cx ty     -> extract_lctxt cx (extract_lty ty acc)
       HsForAllTy _ tvs cx ty    -> acc ++ (filter ((`notElem` locals) . unLoc) $
@@ -226,17 +225,14 @@ mkTyFamily loc flavour lhs ksig
 
 mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
 -- If the user wrote
---	$(e)
--- then that's the splice, but if she wrote, say,
---      f x
--- then behave as if she'd written
---      $(f x)
-mkTopSpliceDecl expr
-  = SpliceD (SpliceDecl expr')
-  where
-    expr' = case expr of
-              (L _ (HsSpliceE (HsSplice _ expr))) -> expr
-              _other                              -> expr
+--      [pads| ... ]   then return a QuasiQuoteD
+--	$(e)           then return a SpliceD
+-- but if she wrote, say,
+--      f x            then behave as if she'd written $(f x)
+--		       ie a SpliceD
+mkTopSpliceDecl (L _ (HsQuasiQuoteE qq))            = QuasiQuoteD qq
+mkTopSpliceDecl (L _ (HsSpliceE (HsSplice _ expr))) = SpliceD (SpliceDecl expr)
+mkTopSpliceDecl other_expr                          = SpliceD (SpliceDecl other_expr)
 \end{code}
 
 %************************************************************************
@@ -334,80 +330,6 @@ has_args ((L _ (Match args _ _)) : _) = not (null args)
 	-- than pattern bindings (tests/rename/should_fail/rnfail002).
 \end{code}
 
-\begin{code}
-findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
-findSplice ds = addl emptyRdrGroup ds
-
-checkDecBrGroup :: [LHsDecl a] -> P (HsGroup a)
--- Turn the body of a [d| ... |] into a HsGroup
--- There should be no splices in the "..."
-checkDecBrGroup decls 
-  = case addl emptyRdrGroup decls of
-	(group, Nothing) -> return group
-	(_, Just (SpliceDecl (L loc _), _)) -> 
-		parseError loc "Declaration splices are not permitted inside declaration brackets"
-		-- Why not?  See Section 7.3 of the TH paper.  
-
-addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
-	-- This stuff reverses the declarations (again) but it doesn't matter
-
--- Base cases
-addl gp []	     = (gp, Nothing)
-addl gp (L l d : ds) = add gp l d ds
-
-
-add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
-  -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
-
-add gp _ (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}) 
-    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}) ds
-	| otherwise =
-		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}) 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}) 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
-  = addl (gp { hs_instds = L l d : ts }) ds
-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}) l (ForD d) ds
-  = addl (gp { hs_fords = L l d : ts }) ds
-add gp@(HsGroup {hs_warnds  = ts})  l (WarningD d) ds
-  = addl (gp { hs_warnds = L l d : ts }) ds
-add gp@(HsGroup {hs_annds  = ts}) l (AnnD d) ds
-  = addl (gp { hs_annds = 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 = (L l d) : (hs_docs gp) })  ds
-
-add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
-add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
-add_bind _ (ValBindsOut {})     = panic "RdrHsSyn:add_bind"
-
-add_sig :: LSig a -> HsValBinds a -> HsValBinds a
-add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) 
-add_sig _ (ValBindsOut {})     = panic "RdrHsSyn:add_sig"
-\end{code}
-
 %************************************************************************
 %*									*
 \subsection[PrefixToHS-utils]{Utilities for conversion}
@@ -549,12 +471,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])
@@ -578,8 +502,7 @@ checkTParams is_family tparams
   = do { tyvars <- checkTyVars tparams
        ; return (tyvars, Nothing) }
   | otherwise		 -- Family case (b)
-  = do { let tyvars = [L l (UserTyVar tv) 
-                      | L l tv <- extractHsTysRdrTyVars tparams]
+  = do { let tyvars = userHsTyVarBndrs (extractHsTysRdrTyVars tparams)
        ; return (tyvars, Just tparams) }
 
 checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
@@ -594,7 +517,7 @@ checkTyVars tparms = mapM chk tparms
     chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
 	| isRdrTyVar tv    = return (L l (KindedTyVar tv k))
     chk (L l (HsTyVar tv))
-        | isRdrTyVar tv    = return (L l (UserTyVar tv))
+        | isRdrTyVar tv    = return (L l (UserTyVar tv placeHolderKind))
     chk (L l _)            =
 	  parseError l "Type found where type variable expected"
 
@@ -794,10 +717,10 @@ checkAPat dynflags loc e = case e of
    HsType ty          -> return (TypePat ty) 
    _                  -> patFail loc
 
-placeHolderPunRhs :: HsExpr RdrName
+placeHolderPunRhs :: LHsExpr RdrName
 -- The RHS of a punned record field will be filled in by the renamer
 -- It's better not to make it an error, in case we want to print it when debugging
-placeHolderPunRhs = HsVar pun_RDR
+placeHolderPunRhs = noLoc (HsVar pun_RDR)
 
 plus_RDR, bang_RDR, pun_RDR :: RdrName
 plus_RDR = mkUnqual varName (fsLit "+")	-- Hack
@@ -865,8 +788,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}
 
 
@@ -963,6 +898,7 @@ 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