Merge remote-tracking branch 'origin/master' into type-nats

Conflicts:
	compiler/coreSyn/CoreLint.lhs
	compiler/deSugar/DsBinds.lhs
	compiler/hsSyn/HsTypes.lhs
	compiler/iface/IfaceType.lhs
	compiler/rename/RnHsSyn.lhs
	compiler/rename/RnTypes.lhs
	compiler/stgSyn/StgLint.lhs
	compiler/typecheck/TcHsType.lhs
	compiler/utils/ListSetOps.lhs

4 files changed, 69 insertions, 38 deletions

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 6e74cfbc4a..74da99a005 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -487,6 +487,7 @@ data Token
   | ITvect_prag
   | ITvect_scalar_prag
   | ITnovect_prag
+  | ITctype
 
   | ITdotdot                    -- reserved symbols
   | ITcolon
@@ -2287,7 +2288,8 @@ oneWordPrags = Map.fromList([("rules", rulePrag),
                            ("nounpack", token ITnounpack_prag),
                            ("ann", token ITann_prag),
                            ("vectorize", token ITvect_prag),
-                           ("novectorize", token ITnovect_prag)])
+                           ("novectorize", token ITnovect_prag),
+                           ("ctype", token ITctype)])
 
 twoWordPrags = Map.fromList([("inline conlike", token (ITinline_prag Inline ConLike)),
                              ("notinline conlike", token (ITinline_prag NoInline ConLike)),
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 61eb5748a3..35f8e487ab 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -38,9 +38,7 @@ import TysWiredIn       ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataC
                           unboxedUnitTyCon, unboxedUnitDataCon,
                           listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR, eqTyCon_RDR )
 import Type             ( funTyCon )
-import ForeignCall      ( Safety(..), CExportSpec(..), CLabelString,
-                          CCallConv(..), CCallTarget(..), defaultCCallConv
-                        )
+import ForeignCall
 import OccName          ( varName, dataName, tcClsName, tvName )
 import DataCon          ( DataCon, dataConName )
 import SrcLoc
@@ -269,6 +267,7 @@ incorrect.
  '{-# VECTORISE'          { L _ ITvect_prag }
  '{-# VECTORISE_SCALAR'   { L _ ITvect_scalar_prag }
  '{-# NOVECTORISE'        { L _ ITnovect_prag }
+ '{-# CTYPE'              { L _ ITctype }
  '#-}'                                          { L _ ITclose_prag }
 
  '..'           { L _ ITdotdot }                        -- reserved symbols
@@ -631,18 +630,18 @@ ty_decl :: { LTyClDecl RdrName }
                 {% mkTyFamily (comb3 $1 $3 $4) TypeFamily $3 (unLoc $4) }
 
           -- ordinary data type or newtype declaration
-        | data_or_newtype tycl_hdr constrs deriving
-                {% mkTyData (comb4 $1 $2 $3 $4) (unLoc $1) False $2 
-                            Nothing (reverse (unLoc $3)) (unLoc $4) }
+        | data_or_newtype capi_ctype tycl_hdr constrs deriving
+                {% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) False $2 $3 
+                            Nothing (reverse (unLoc $4)) (unLoc $5) }
                                    -- We need the location on tycl_hdr in case 
                                    -- constrs and deriving are both empty
 
           -- ordinary GADT declaration
-        | data_or_newtype tycl_hdr opt_kind_sig 
+        | data_or_newtype capi_ctype tycl_hdr opt_kind_sig 
                  gadt_constrlist
                  deriving
-                {% mkTyData (comb4 $1 $2 $4 $5) (unLoc $1) False $2 
-                            (unLoc $3) (unLoc $4) (unLoc $5) }
+                {% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) False $2 $3 
+                            (unLoc $4) (unLoc $5) (unLoc $6) }
                                    -- We need the location on tycl_hdr in case 
                                    -- constrs and deriving are both empty
 
@@ -664,7 +663,7 @@ inst_decl :: { LInstDecl RdrName }
 
           -- data/newtype instance declaration
         | data_or_newtype 'instance' tycl_hdr constrs deriving
-                {% do { L loc d <- mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) True $3
+                {% do { L loc d <- mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) True Nothing $3
                                       Nothing (reverse (unLoc $4)) (unLoc $5)
                       ; return (L loc (FamInstDecl d)) } }
 
@@ -672,7 +671,7 @@ inst_decl :: { LInstDecl RdrName }
         | data_or_newtype 'instance' tycl_hdr opt_kind_sig 
                  gadt_constrlist
                  deriving
-                {% do { L loc d <- mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) True $3
+                {% do { L loc d <- mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) True Nothing $3
                                             (unLoc $4) (unLoc $5) (unLoc $6)
                       ; return (L loc (FamInstDecl d)) } }
         
@@ -689,7 +688,7 @@ at_decl_cls :: { LTyClDecl RdrName }
            -- type family declarations
         : 'type' type opt_kind_sig
                 -- Note the use of type for the head; this allows
-                -- infix type constructors to be declared
+                -- infix type constructors to be declared.
                 {% mkTyFamily (comb3 $1 $2 $3) TypeFamily $2 (unLoc $3) }
 
            -- default type instance
@@ -712,16 +711,16 @@ at_decl_inst :: { LTyClDecl RdrName }
                 {% mkTySynonym (comb2 $1 $4) True $2 $4 }
 
         -- data/newtype instance declaration
-        | data_or_newtype tycl_hdr constrs deriving
-                {% mkTyData (comb4 $1 $2 $3 $4) (unLoc $1) True $2 
-                            Nothing (reverse (unLoc $3)) (unLoc $4) }
+        | data_or_newtype capi_ctype tycl_hdr constrs deriving
+                {% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) True $2 $3 
+                            Nothing (reverse (unLoc $4)) (unLoc $5) }
 
         -- GADT instance declaration
-        | data_or_newtype tycl_hdr opt_kind_sig 
+        | data_or_newtype capi_ctype tycl_hdr opt_kind_sig 
                  gadt_constrlist
                  deriving
-                {% mkTyData (comb4 $1 $2 $4 $5) (unLoc $1) True $2 
-                            (unLoc $3) (unLoc $4) (unLoc $5) }
+                {% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) True $2 $3 
+                            (unLoc $4) (unLoc $5) (unLoc $6) }
 
 data_or_newtype :: { Located NewOrData }
         : 'data'        { L1 DataType }
@@ -742,6 +741,11 @@ tycl_hdr :: { Located (Maybe (LHsContext RdrName), LHsType RdrName) }
         : context '=>' type             { LL (Just $1, $3) }
         | type                          { L1 (Nothing, $1) }
 
+capi_ctype :: { Maybe CType }
+capi_ctype : '{-# CTYPE' STRING STRING '#-}' { Just (CType (Just (Header (getSTRING $2))) (getSTRING $3)) }
+           | '{-# CTYPE'        STRING '#-}' { Just (CType Nothing                        (getSTRING $2)) }
+           |                                 { Nothing }
+
 -----------------------------------------------------------------------------
 -- Stand-alone deriving
 
@@ -871,7 +875,7 @@ rule_var_list :: { [RuleBndr RdrName] }
 
 rule_var :: { RuleBndr RdrName }
         : varid                                 { RuleBndr $1 }
-        | '(' varid '::' ctype ')'              { RuleBndrSig $2 $4 }
+        | '(' varid '::' ctype ')'              { RuleBndrSig $2 (HsBSig $4 placeHolderBndrs) }
 
 -----------------------------------------------------------------------------
 -- Warnings and deprecations (c.f. rules)
@@ -1104,7 +1108,7 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] }
 
 tv_bndr :: { LHsTyVarBndr RdrName }
         : tyvar                         { L1 (UserTyVar (unLoc $1) placeHolderKind) }
-        | '(' tyvar '::' kind ')'       { LL (KindedTyVar (unLoc $2) $4 placeHolderKind) }
+        | '(' tyvar '::' kind ')'       { LL (KindedTyVar (unLoc $2) (HsBSig $4 placeHolderBndrs) placeHolderKind) }
 
 fds :: { Located [Located (FunDep RdrName)] }
         : {- empty -}                   { noLoc [] }
@@ -1137,6 +1141,7 @@ akind :: { LHsKind RdrName }
         : '*'                    { L1 $ HsTyVar (nameRdrName liftedTypeKindTyConName) }
         | '(' kind ')'           { LL $ HsParTy $2 }
         | pkind                  { $1 }
+        | tyvar                  { L1 $ HsTyVar (unLoc $1) }
 
 pkind :: { LHsKind RdrName }  -- promoted type, see Note [Promotion]
         : qtycon                          { L1 $ HsTyVar $ unLoc $1 }
diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y
index 3a786ea04b..872bcdefc0 100644
--- a/compiler/parser/ParserCore.y
+++ b/compiler/parser/ParserCore.y
@@ -278,7 +278,7 @@ exp	:: { IfaceExpr }
 --	       "InlineMe"   -> IfaceNote IfaceInlineMe $3
 --            }
         | '%external' STRING aty   { IfaceFCall (ForeignCall.CCall 
-                                                    (CCallSpec (StaticTarget (mkFastString $2) Nothing) 
+                                                    (CCallSpec (StaticTarget (mkFastString $2) Nothing True) 
                                                                CCallConv PlaySafe)) 
                                                  $3 }
 
@@ -375,7 +375,9 @@ ifaceUnliftedTypeKind = ifaceTcType (IfaceTc unliftedTypeKindTyConName)
 ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2
 
 toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName
-toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) (toHsKind k) placeHolderKind
+toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) bsig placeHolderKind
+                  where
+                    bsig = HsBSig (toHsKind k) placeHolderBndrs
 
 ifaceExtRdrName :: Name -> RdrName
 ifaceExtRdrName name = mkOrig (nameModule name) (nameOccName name)
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 8900f9fdec..9c000ee765 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -200,18 +200,20 @@ mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
 mkTyData :: SrcSpan
          -> NewOrData
          -> Bool                -- True <=> data family instance
+         -> Maybe CType
          -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
          -> Maybe (LHsKind RdrName)
          -> [LConDecl RdrName]
          -> Maybe [LHsType RdrName]
          -> P (LTyClDecl RdrName)
-mkTyData loc new_or_data is_family (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
+mkTyData loc new_or_data is_family cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
   = do { (tc, tparams) <- checkTyClHdr tycl_hdr
 
        ; checkDatatypeContext mcxt
        ; let cxt = fromMaybe (noLoc []) mcxt
        ; (tyvars, typats) <- checkTParams is_family tycl_hdr tparams
-       ; return (L loc (TyData { tcdND = new_or_data, tcdCtxt = cxt, tcdLName = tc,
+       ; return (L loc (TyData { tcdND = new_or_data, tcdCType = cType,
+                                 tcdCtxt = cxt, tcdLName = tc,
                                  tcdTyVars = tyvars, tcdTyPats = typats,
                                  tcdCons = data_cons,
                                  tcdKindSig = ksig, tcdDerivs = maybe_deriv })) }
@@ -224,7 +226,9 @@ mkTySynonym :: SrcSpan
 mkTySynonym loc is_family lhs rhs
   = do { (tc, tparams) <- checkTyClHdr lhs
        ; (tyvars, typats) <- checkTParams is_family lhs tparams
-       ; return (L loc (TySynonym tc tyvars typats rhs)) }
+       ; return (L loc (TySynonym { tcdLName = tc
+                                  , tcdTyVars = tyvars, tcdTyPats = typats
+                                  , tcdSynRhs = rhs, tcdFVs = placeHolderNames })) }
 
 mkTyFamily :: SrcSpan
            -> FamilyFlavour
@@ -505,7 +509,7 @@ checkTyVars tycl_hdr tparms = mapM chk tparms
   where
         -- Check that the name space is correct!
     chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
-        | isRdrTyVar tv    = return (L l (KindedTyVar tv k placeHolderKind))
+        | isRdrTyVar tv    = return (L l (KindedTyVar tv (HsBSig k placeHolderBndrs) placeHolderKind))
     chk (L l (HsTyVar tv))
         | isRdrTyVar tv    = return (L l (UserTyVar tv placeHolderKind))
     chk t@(L l _)
@@ -642,7 +646,7 @@ checkAPat dynflags loc e0 = case e0 of
                             let t' = case t of
                                        L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
                                        other -> other
-                            return (SigPatIn e t')
+                            return (SigPatIn e (HsBSig t' placeHolderBndrs))
 
    -- n+k patterns
    OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
@@ -920,8 +924,8 @@ mkImport :: CCallConv
          -> P (HsDecl RdrName)
 mkImport cconv safety (L loc entity, v, ty)
   | cconv == PrimCallConv                      = do
-  let funcTarget = CFunction (StaticTarget entity Nothing)
-      importSpec = CImport PrimCallConv safety nilFS funcTarget
+  let funcTarget = CFunction (StaticTarget entity Nothing True)
+      importSpec = CImport PrimCallConv safety Nothing funcTarget
   return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec))
 
   | otherwise = do
@@ -941,27 +945,45 @@ parseCImport cconv safety nm str =
    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)
+          string "dynamic" >> return (mk Nothing (CFunction DynamicTarget)),
+          string "wrapper" >> return (mk Nothing CWrapper),
+          do optional (token "static" >> skipSpaces)
+             ((mk Nothing <$> cimp nm) +++
+              (do h <- munch1 hdr_char
+                  skipSpaces
+                  mk (Just (Header (mkFastString h))) <$> cimp nm))
          ]
        skipSpaces
        return r
 
+   token str = do _ <- string str
+                  toks <- look
+                  case toks of
+                      c : _
+                       | id_char c -> pfail
+                      _            -> return ()
+
    mk = CImport cconv safety
 
    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 == '_'
+   id_first_char c = isAlpha    c || c == '_'
+   id_char       c = isAlphaNum c || c == '_'
 
    cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
-             +++ ((\c -> CFunction (StaticTarget c Nothing)) <$> cid)
+             +++ (do isFun <- case cconv of
+                              CApiConv ->
+                                  option True
+                                         (do token "value"
+                                             skipSpaces
+                                             return False)
+                              _ -> return True
+                     cid' <- cid
+                     return (CFunction (StaticTarget cid' Nothing isFun)))
           where
             cid = return nm +++
-                  (do c  <- satisfy (\c -> isAlpha c || c == '_')
+                  (do c  <- satisfy id_first_char
                       cs <-  many (satisfy id_char)
                       return (mkFastString (c:cs)))