X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FRdrHsSyn.lhs;h=ca24070a04f8115fbee4a8baef5064b90c4aafa3;hp=15aa859e016a967f089bfdf0dd734fe21b95fffe;hb=143f4381d242e4a1c3174e8a0732a1e48f00a1aa;hpb=cbc86d748d5f7b5ad5503c9e87c0b5c0402f27bc

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 15aa859..ca24070 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -530,8 +530,12 @@ checkAPat loc e = case e of
    NegApp (L _ (HsOverLit pos_lit)) _ 
 			-> return (mkNPat pos_lit (Just noSyntaxExpr))
    
-   SectionR (L _ (HsVar bang)) e 
- 	| bang == bang_RDR -> checkLPat e >>= (return . BangPat)
+   SectionR (L _ (HsVar bang)) e 	-- (! x)
+ 	| bang == bang_RDR 
+	-> do { bang_on <- extension bangPatEnabled
+	      ; if bang_on then checkLPat e >>= (return . BangPat)
+		else parseError loc "Illegal bang-pattern (use -fbang-patterns)" }
+
    ELazyPat e	      -> checkLPat e >>= (return . LazyPat)
    EAsPat n e	      -> checkLPat e >>= (return . AsPat n)
    ExprWithTySig e t  -> checkLPat e >>= \e ->
@@ -592,6 +596,10 @@ checkValDef :: LHsExpr RdrName
 	    -> Located (GRHSs RdrName)
 	    -> P (HsBind RdrName)
 
+checkValDef lhs (Just sig) grhss
+   	-- x :: ty = rhs  parses as a *pattern* binding
+  = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
+
 checkValDef lhs opt_sig grhss
   = do	{ mb_fun <- isFunLhs lhs
 	; case mb_fun of
@@ -630,30 +638,22 @@ checkValSig (L l (HsVar v)) ty
 checkValSig (L l other)     ty
   = parseError l "Invalid type signature"
 
-mkGadtDecl
-        :: Located RdrName
-        -> LHsType RdrName -- assuming HsType
-        -> ConDecl RdrName
-mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = ConDecl
-  { con_name     = name
-  , con_explicit = Implicit
-  , con_qvars    = qvars
-  , con_cxt      = cxt
-  , con_details  = PrefixCon args
-  , con_res      = ResTyGADT res
-  }
-  where
-  (args, res) = splitHsFunType ty
-mkGadtDecl name ty = ConDecl
-  { con_name     = name
-  , con_explicit = Implicit
-  , con_qvars    = []
-  , con_cxt      = noLoc []
-  , con_details  = PrefixCon args
-  , con_res      = ResTyGADT res
-  }
-  where
-  (args, res) = splitHsFunType ty
+mkGadtDecl :: Located RdrName
+           -> LHsType RdrName -- assuming HsType
+           -> ConDecl RdrName
+mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = mk_gadt_con name qvars cxt ty
+mkGadtDecl name ty				  = mk_gadt_con name [] (noLoc []) ty
+
+mk_gadt_con name qvars cxt ty
+  = ConDecl { con_name     = name
+	    , con_explicit = Implicit
+	    , con_qvars    = qvars
+	    , con_cxt      = cxt
+	    , con_details  = PrefixCon []
+	    , con_res      = ResTyGADT ty }
+  -- NB: we put the whole constr type into the ResTyGADT for now; 
+  -- the renamer will unravel it once it has sorted out
+  -- operator fixities
 
 -- A variable binding is parsed as a FunBind.
 
@@ -755,10 +755,10 @@ mkImport :: CallConv
 	 -> P (HsDecl RdrName)
 mkImport (CCall  cconv) safety (entity, v, ty) = do
   importSpec <- parseCImport entity cconv safety v
-  return (ForD (ForeignImport v ty importSpec False))
+  return (ForD (ForeignImport v ty importSpec))
 mkImport (DNCall      ) _      (entity, v, ty) = do
   spec <- parseDImport entity
-  return $ ForD (ForeignImport v ty (DNImport spec) False)
+  return $ ForD (ForeignImport v ty (DNImport spec))
 
 -- parse the entity string of a foreign import declaration for the `ccall' or
 -- `stdcall' calling convention'
@@ -859,7 +859,7 @@ mkExport :: CallConv
          -> (Located FastString, Located RdrName, LHsType RdrName) 
 	 -> P (HsDecl RdrName)
 mkExport (CCall  cconv) (L loc entity, v, ty) = return $ 
-  ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False)
+  ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
   where
     entity' | nullFS entity = mkExtName (unLoc v)
 	    | otherwise     = entity