Lexing and parsing for "foreign import prim"

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

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index bccf27f..c1c5972 100644 (file)
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -28,7 +28,7 @@ module RdrHsSyn (
                              -- -> (FastString, RdrName, RdrNameHsType)
                              -- -> P RdrNameHsDecl
        mkExtName,           -- RdrName -> CLabelString
-       mkGadtDecl,          -- Located RdrName -> LHsType RdrName -> ConDecl RdrName
+       mkGadtDecl,          -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
                              
        -- Bunch of functions in the parser monad for 
        -- checking and constructing values
@@ -49,7 +49,8 @@ module RdrHsSyn (
        checkMDo,             -- [Stmt] -> P [Stmt]
        checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
        checkValSig,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
-       parseError,           -- String -> Pa
+       parseError,         
+       parseErrorSDoc,     
     ) where
 
 import HsSyn           -- Lots of it
@@ -58,10 +59,12 @@ import TypeRep          ( Kind )
 import RdrName         ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, 
                          isRdrDataCon, isUnqual, getRdrName, isQual,
                          setRdrNameSpace, showRdrName )
-import BasicTypes      ( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec )
+import BasicTypes      ( maxPrecedence, Activation, RuleMatchInfo,
+                          InlinePragma(..),  InlineSpec(..),
+                          alwaysInlineSpec, neverInlineSpec )
 import Lexer           ( P, failSpanMsgP, extension, standaloneDerivingEnabled, bangPatEnabled )
 import TysWiredIn      ( unitTyCon ) 
-import ForeignCall     ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
+import ForeignCall     ( CCallConv(..), Safety, CCallTarget(..), CExportSpec(..),
                          DNCallSpec(..), DNKind(..), CLabelString )
 import OccName         ( srcDataName, varName, isDataOcc, isTcOcc, 
                          occNameString )
@@ -810,11 +813,19 @@ checkValSig (L l (HsVar v)) ty
 checkValSig (L l _)         _
   = parseError l "Invalid type signature"
 
-mkGadtDecl :: Located RdrName
+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
+           -> [ConDecl RdrName]
+-- We allow C,D :: ty
+-- and expand it as if it had been 
+--    C :: ty; D :: ty
+-- (Just like type signatures in general.)
+mkGadtDecl names ty
+  = [mk_gadt_con name qvars cxt tau | name <- names]
+  where
+    (qvars,cxt,tau) = case ty of
+                       L _ (HsForAllTy _ qvars cxt tau) -> (qvars, cxt,      tau)
+                       _                                -> ([],    noLoc [], ty)
 
 mk_gadt_con :: Located RdrName
             -> [LHsTyVarBndr RdrName]
@@ -923,11 +934,13 @@ 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 -> Bool -> InlineSpec
+mkInlineSpec :: Maybe Activation -> RuleMatchInfo -> Bool -> InlineSpec
 -- The Maybe is becuase the user can omit the activation spec (and usually does)
-mkInlineSpec Nothing   True  = alwaysInlineSpec        -- INLINE
-mkInlineSpec Nothing   False = neverInlineSpec         -- NOINLINE
-mkInlineSpec (Just act) inl   = Inline act inl
+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
 
 
 -----------------------------------------------------------------------------
@@ -944,6 +957,11 @@ mkImport :: CallConv
         -> Safety 
         -> (Located FastString, Located RdrName, LHsType RdrName) 
         -> P (HsDecl RdrName)
+mkImport (CCall  cconv) safety (entity, v, ty)
+  | cconv == PrimCallConv                      = do
+  let funcTarget = CFunction (StaticTarget (unLoc entity))
+      importSpec = CImport PrimCallConv safety nilFS nilFS funcTarget
+  return (ForD (ForeignImport v ty importSpec))
 mkImport (CCall  cconv) safety (entity, v, ty) = do
   importSpec <- parseCImport entity cconv safety v
   return (ForD (ForeignImport v ty importSpec))