Migrate cvs diff from fptools-assoc branch

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

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 8d59e2b..777ff64 100644 (file)
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -8,7 +8,7 @@ module RdrHsSyn (
        extractHsTyRdrTyVars, 
        extractHsRhoRdrTyVars, extractGenericPatTyVars,
  
        extractHsTyRdrTyVars, 
        extractHsRhoRdrTyVars, extractGenericPatTyVars,
  

-       mkHsOpApp, mkClassDecl, 
+       mkHsOpApp, mkClassDecl,

        mkHsNegApp, mkHsIntegral, mkHsFractional,
        mkHsDo, mkHsSplice,
         mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec, 
        mkHsNegApp, mkHsIntegral, mkHsFractional,
        mkHsDo, mkHsSplice,
         mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec, 

@@ -36,7 +36,9 @@ module RdrHsSyn (
        checkContext,         -- HsType -> P HsContext
        checkPred,            -- HsType -> P HsPred
        checkTyClHdr,         -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
        checkContext,         -- HsType -> P HsContext
        checkPred,            -- HsType -> P HsPred
        checkTyClHdr,         -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])

+       checkTyVars,          -- [LHsType RdrName] -> P ()

        checkSynHdr,          -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName])
        checkSynHdr,          -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName])

+       checkTopTyClD,        -- LTyClDecl RdrName -> P (HsDecl RdrName)

        checkInstType,        -- HsType -> P HsType
        checkPattern,         -- HsExp -> P HsPat
        checkPatterns,        -- SrcLoc -> [HsExp] -> P [HsPat]
        checkInstType,        -- HsType -> P HsType
        checkPattern,         -- HsExp -> P HsPat
        checkPatterns,        -- SrcLoc -> [HsExp] -> P [HsPat]

@@ -155,12 +157,13 @@ mkClassDecl (cxt, cname, tyvars) fds sigs mbinds
   = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
                tcdFDs = fds,  
                tcdSigs = sigs,
   = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
                tcdFDs = fds,  
                tcdSigs = sigs,

-               tcdMeths = mbinds
+               tcdMeths = mbinds,
+               tcdATs   = ats

                }
 
                }
 

-mkTyData new_or_data (context, tname, tyvars) ksig data_cons maybe_deriv
+mkTyData new_or_data (context, tname, tyvars, typats) ksig data_cons maybe_deriv

   = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
   = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,

-            tcdTyVars = tyvars,  tcdCons = data_cons, 
+            tcdTyVars = tyvars, tcdTyPats = typats, tcdCons = data_cons, 

             tcdKindSig = ksig, tcdDerivs = maybe_deriv }
 \end{code}
 
             tcdKindSig = ksig, tcdDerivs = maybe_deriv }
 \end{code}
 

@@ -198,23 +201,29 @@ cvTopDecls decls = go (fromOL decls)
                            where (L l' b', ds') = getMonoBind (L l b) ds
     go (d : ds)            = d : go ds
 
                            where (L l' b', ds') = getMonoBind (L l b) ds
     go (d : ds)            = d : go ds
 

+-- Declaration list may only contain value bindings and signatures
+--

 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
 cvBindGroup binding
 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
 cvBindGroup binding

-  = case (cvBindsAndSigs binding) of { (mbs, sigs) ->
-    ValBindsIn mbs sigs
-    }
+  = case cvBindsAndSigs binding of
+      (mbs, sigs, []) ->                 -- list of type decls *always* empty
+        ValBindsIn mbs sigs

 
 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
 
 cvBindsAndSigs :: OrdList (LHsDecl RdrName)

-  -> (Bag (LHsBind RdrName), [LSig RdrName])
+  -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName])

 -- Input decls contain just value bindings and signatures
 -- Input decls contain just value bindings and signatures

+-- and in case of class or instance declarations also
+-- associated data or synonym definitions

 cvBindsAndSigs  fb = go (fromOL fb)
   where
 cvBindsAndSigs  fb = go (fromOL fb)
   where

-    go []                 = (emptyBag, [])
-    go (L l (SigD s) : ds) = (bs, L l s : ss)
-                           where (bs,ss) = go ds
-    go (L l (ValD b) : ds) = (b' `consBag` bs, ss)
-                           where (b',ds') = getMonoBind (L l b) ds
-                                 (bs,ss)  = go ds'
+    go []                 = (emptyBag, [], [])
+    go (L l (SigD s) : ds) = (bs, L l s : ss, ts)
+                           where (bs, ss, ts) = go ds
+    go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts)
+                           where (b', ds')    = getMonoBind (L l b) ds
+                                 (bs, ss, ts) = go ds'
+    go (L l (TyClD t): ds) = (bs, ss, L l t : ts)
+                           where (bs, ss, ts) = go ds

 
 -----------------------------------------------------------------------------
 -- Group function bindings into equation groups
 
 -----------------------------------------------------------------------------
 -- Group function bindings into equation groups

@@ -222,7 +231,7 @@ cvBindsAndSigs  fb = go (fromOL fb)
 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
   -> (LHsBind RdrName, [LHsDecl RdrName])
 -- Suppose     (b',ds') = getMonoBind b ds
 getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
   -> (LHsBind RdrName, [LHsDecl RdrName])
 -- Suppose     (b',ds') = getMonoBind b ds

---     ds is a *reversed* list of parsed bindings
+--     ds is a list of parsed bindings

 --     b is a MonoBinds that has just been read off the front
 
 -- Then b' is the result of grouping more equations from ds that
 --     b is a MonoBinds that has just been read off the front
 
 -- Then b' is the result of grouping more equations from ds that

@@ -231,15 +240,18 @@ getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
 --
 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
 
 --
 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
 

-getMonoBind (L loc bind@(FunBind { fun_id = L _ f, fun_matches = MatchGroup mtchs _ })) binds
-  | has_args mtchs
-  = go mtchs loc binds
+getMonoBind (L loc1 bind@(FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1, 
+                                  fun_matches = MatchGroup mtchs1 _ })) binds
+  | has_args mtchs1
+  = go is_infix1 mtchs1 loc1 binds

   where
   where

-    go mtchs1 loc1 (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_matches = MatchGroup mtchs2 _ })) : binds)
-       | f == f2 = go (mtchs2++mtchs1) loc binds
-       where loc = combineSrcSpans loc1 loc2
-    go mtchs1 loc binds
-       = (L loc (bind { fun_matches = mkMatchGroup (reverse mtchs1) }), binds)
+    go is_infix mtchs loc 
+       (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
+                               fun_matches = MatchGroup mtchs2 _ })) : binds)
+       | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs) 
+                       (combineSrcSpans loc loc2) binds
+    go is_infix mtchs loc binds
+       = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), binds)

        -- Reverse the final matches, to get it back in the right order
 
 getMonoBind bind binds = (bind, binds)
        -- Reverse the final matches, to get it back in the right order
 
 getMonoBind bind binds = (bind, binds)

@@ -365,44 +377,61 @@ checkInstType (L l t)
        ty ->   do dict_ty <- checkDictTy (L l ty)
                   return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
 
        ty ->   do dict_ty <- checkDictTy (L l ty)
                   return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
 

-checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
-checkTyVars tvs 
-  = mapM chk tvs
+-- Check that the given list of type parameters are all type variables
+-- (possibly with a kind signature).
+--
+checkTyVars :: [LHsType RdrName] -> P ()
+checkTyVars tvs = mapM_ chk tvs

   where
   where

-       --  Check that the name space is correct!
+       -- Check that the name space is correct!

     chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
     chk (L l (HsKindSig (L _ (HsTyVar tv)) k))

-       | isRdrTyVar tv = return (L l (KindedTyVar tv k))
+       | isRdrTyVar tv = return ()

     chk (L l (HsTyVar tv))
     chk (L l (HsTyVar tv))

-        | isRdrTyVar tv = return (L l (UserTyVar tv))
+        | isRdrTyVar tv = return ()

     chk (L l other)
        = parseError l "Type found where type variable expected"
 
 checkSynHdr :: LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName])
     chk (L l other)
        = parseError l "Type found where type variable expected"
 
 checkSynHdr :: LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName])

-checkSynHdr ty = do { (_, tc, tvs) <- checkTyClHdr (noLoc []) ty
+checkSynHdr ty = do { (_, tc, tvs, Just tparms) <- checkTyClHdr (noLoc []) ty
+                   ; checkTyVars tparms

                    ; return (tc, tvs) }
 
 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
                    ; return (tc, tvs) }
 
 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName

-  -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
+  -> P (LHsContext RdrName,         -- the type context
+        Located RdrName,            -- the head symbol (type or class name)
+       [LHsTyVarBndr RdrName],      -- free variables of the non-context part
+       Maybe [LHsType RdrName])     -- parameters of head symbol; wrapped into
+                                    -- 'Maybe' for 'mkTyData'

 -- The header of a type or class decl should look like
 --     (C a, D b) => T a b
 -- or  T a b
 -- or  a + b
 -- etc
 -- The header of a type or class decl should look like
 --     (C a, D b) => T a b
 -- or  T a b
 -- or  a + b
 -- etc

+-- With associated types, we can also have non-variable parameters; ie,
+--      T Int [a]
+-- The unaltered parameter list is returned in the fourth component of the
+-- result.  Eg, for
+--      T Int [a]
+-- we return
+--      ('()', 'T', ['a'], Just ['Int', '[a]'])

 checkTyClHdr (L l cxt) ty
 checkTyClHdr (L l cxt) ty

-  = do (tc, tvs) <- gol ty []
+  = do (tc, tvs, parms) <- gol ty []

        mapM_ chk_pred cxt
        mapM_ chk_pred cxt

-       return (L l cxt, tc, tvs)
+       return (L l cxt, tc, tvs, Just parms)

   where
     gol (L l ty) acc = go l ty acc
 
     go l (HsTyVar tc)    acc 
   where
     gol (L l ty) acc = go l ty acc
 
     go l (HsTyVar tc)    acc 

-       | not (isRdrTyVar tc)   = checkTyVars acc               >>= \ tvs ->
-                                 return (L l tc, tvs)
-    go l (HsOpTy t1 tc t2) acc  = checkTyVars (t1:t2:acc)      >>= \ tvs ->
-                                 return (tc, tvs)
+       | not (isRdrTyVar tc)   = do
+                                   tvs <- extractTyVars acc
+                                   return (L l tc, tvs, acc)
+    go l (HsOpTy t1 tc t2) acc  = do
+                                   tvs <- extractTyVars (t1:t2:acc)
+                                   return (tc, tvs, acc)

     go l (HsParTy ty)    acc    = gol ty acc
     go l (HsAppTy t1 t2) acc    = gol t1 (t2:acc)
     go l (HsParTy ty)    acc    = gol ty acc
     go l (HsAppTy t1 t2) acc    = gol t1 (t2:acc)

-    go l other          acc    = parseError l "Malformed LHS to type of class declaration"
+    go l other          acc    = 
+      parseError l "Malformed head of type or class declaration"

 
        -- The predicates in a type or class decl must all
        -- be HsClassPs.  They need not all be type variables,
 
        -- The predicates in a type or class decl must all
        -- be HsClassPs.  They need not all be type variables,

@@ -411,7 +440,63 @@ checkTyClHdr (L l cxt) ty
     chk_pred (L l _)
        = parseError l "Malformed context in type or class declaration"
 
     chk_pred (L l _)
        = parseError l "Malformed context in type or class declaration"
 

-  
+-- Extract the type variables of a list of type parameters.
+--
+-- * Type arguments can be complex type terms (needed for associated type
+--   declarations).
+--
+extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
+extractTyVars tvs = collects [] tvs
+  where
+        -- Collect all variables (1st arg serves as an accumulator)
+    collect tvs (L l (HsForAllTy _ _ _ _)) =
+      parseError l "Forall type not allowed as type parameter"
+    collect tvs (L l (HsTyVar tv))
+      | isRdrTyVar tv                     = return $ L l (UserTyVar tv) : tvs
+      | otherwise                         = return tvs
+    collect tvs (L l (HsBangTy _ _      )) =
+      parseError l "Bang-style type annotations not allowed as type parameter"
+    collect tvs (L l (HsAppTy t1 t2     )) = do
+                                              tvs' <- collect tvs t2
+                                              collect tvs' t1
+    collect tvs (L l (HsFunTy t1 t2     )) = do
+                                              tvs' <- collect tvs t2
+                                              collect tvs' t1
+    collect tvs (L l (HsListTy t        )) = collect tvs t
+    collect tvs (L l (HsPArrTy t        )) = collect tvs t
+    collect tvs (L l (HsTupleTy _ ts    )) = collects tvs ts
+    collect tvs (L l (HsOpTy t1 _ t2    )) = do
+                                              tvs' <- collect tvs t2
+                                              collect tvs' t1
+    collect tvs (L l (HsParTy t         )) = collect tvs t
+    collect tvs (L l (HsNumTy t         )) = return tvs
+    collect tvs (L l (HsPredTy t        )) = 
+      parseError l "Predicate not allowed as type parameter"
+    collect tvs (L l (HsKindSig (L _ (HsTyVar tv)) k))
+       | isRdrTyVar tv                    = 
+         return $ L l (KindedTyVar tv k) : tvs
+       | otherwise                        =
+         parseError l "Kind signature only allowed for type variables"
+    collect tvs (L l (HsSpliceTy t      )) = 
+      parseError l "Splice not allowed as type parameter"
+
+        -- Collect all variables of a list of types
+    collects tvs []     = return tvs
+    collects tvs (t:ts) = do
+                           tvs' <- collects tvs ts
+                           collect tvs' t
+
+-- Wrap a toplevel type or class declaration into 'TyClDecl' after ensuring
+-- that all type parameters are variables only (which is in contrast to
+-- associated type declarations).
+--
+checkTopTyClD :: LTyClDecl RdrName -> P (HsDecl RdrName)
+checkTopTyClD (L _ d@TyData {tcdTyPats = Just typats}) = 
+  do
+    checkTyVars typats
+    return $ TyClD d {tcdTyPats = Nothing}
+checkTopTyClD (L _ d)                             = return $ TyClD d
+

 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
 checkContext (L l t)
   = check t
 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
 checkContext (L l t)
   = check t

@@ -527,8 +612,12 @@ checkAPat loc e = case e of
    NegApp (L _ (HsOverLit pos_lit)) _ 
                        -> return (mkNPat pos_lit (Just noSyntaxExpr))
    
    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 ->
    ELazyPat e        -> checkLPat e >>= (return . LazyPat)
    EAsPat n e        -> checkLPat e >>= (return . AsPat n)
    ExprWithTySig e t  -> checkLPat e >>= \e ->

@@ -589,6 +678,10 @@ checkValDef :: LHsExpr RdrName
            -> Located (GRHSs RdrName)
            -> P (HsBind 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
 checkValDef lhs opt_sig grhss
   = do { mb_fun <- isFunLhs lhs
        ; case mb_fun of

@@ -603,12 +696,16 @@ checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
   | otherwise
   = do ps <- checkPatterns pats
        let match_span = combineSrcSpans lhs_loc rhs_span
   | otherwise
   = do ps <- checkPatterns pats
        let match_span = combineSrcSpans lhs_loc rhs_span

-           matches    = mkMatchGroup [L match_span (Match ps opt_sig grhss)]
-       return (FunBind { fun_id = fun, fun_infix = is_infix, fun_matches = matches,
-                         fun_co_fn = idCoercion, bind_fvs = placeHolderNames })
+       return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])

        -- The span of the match covers the entire equation.  
        -- That isn't quite right, but it'll do for now.
 
        -- The span of the match covers the entire equation.  
        -- That isn't quite right, but it'll do for now.
 

+makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
+-- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
+makeFunBind fn is_infix ms 
+  = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
+             fun_co_fn = idCoercion, bind_fvs = placeHolderNames }
+

 checkPatBind lhs (L _ grhss)
   = do { lhs <- checkPattern lhs
        ; return (PatBind lhs grhss placeHolderType placeHolderNames) }
 checkPatBind lhs (L _ grhss)
   = do { lhs <- checkPattern lhs
        ; return (PatBind lhs grhss placeHolderType placeHolderNames) }

@@ -623,30 +720,22 @@ checkValSig (L l (HsVar v)) ty
 checkValSig (L l other)     ty
   = parseError l "Invalid type signature"
 
 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.
 
 
 -- A variable binding is parsed as a FunBind.
 

@@ -672,15 +761,29 @@ isFunLhs e = go e []
        | not (isRdrDataCon f)   = return (Just (L loc f, False, es))
    go (L _ (HsApp f e)) es      = go f (e:es)
    go (L _ (HsPar e))   es@(_:_) = go e es
        | not (isRdrDataCon f)   = return (Just (L loc f, False, es))
    go (L _ (HsApp f e)) es      = go f (e:es)
    go (L _ (HsPar e))   es@(_:_) = go e es

+
+       -- For infix function defns, there should be only one infix *function*
+       -- (though there may be infix *datacons* involved too).  So we don't
+       -- need fixity info to figure out which function is being defined.
+       --      a `K1` b `op` c `K2` d
+       -- must parse as
+       --      (a `K1` b) `op` (c `K2` d)
+       -- The renamer checks later that the precedences would yield such a parse.
+       -- 
+       -- There is a complication to deal with bang patterns.
+       --
+       -- ToDo: what about this?
+       --              x + 1 `op` y = ...
+

    go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
        | Just (e',es') <- splitBang e
        = do { bang_on <- extension bangPatEnabled
             ; if bang_on then go e' (es' ++ es)
               else return (Just (L loc' op, True, (l:r:es))) }
                -- No bangs; behave just like the next case
    go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
        | Just (e',es') <- splitBang e
        = do { bang_on <- extension bangPatEnabled
             ; if bang_on then go e' (es' ++ es)
               else return (Just (L loc' op, True, (l:r:es))) }
                -- No bangs; behave just like the next case

-       | not (isRdrDataCon op) 
+       | not (isRdrDataCon op)         -- We have found the function!

        = return (Just (L loc' op, True, (l:r:es)))
        = return (Just (L loc' op, True, (l:r:es)))

-       | otherwise
+       | otherwise                     -- Infix data con; keep going

        = do { mb_l <- go l es
             ; case mb_l of
                 Just (op', True, j : k : es')
        = do { mb_l <- go l es
             ; case mb_l of
                 Just (op', True, j : k : es')

@@ -734,10 +837,10 @@ mkImport :: CallConv
         -> P (HsDecl RdrName)
 mkImport (CCall  cconv) safety (entity, v, ty) = do
   importSpec <- parseCImport entity cconv safety v
         -> 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
 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'
 
 -- parse the entity string of a foreign import declaration for the `ccall' or
 -- `stdcall' calling convention'

@@ -838,7 +941,7 @@ mkExport :: CallConv
          -> (Located FastString, Located RdrName, LHsType RdrName) 
         -> P (HsDecl RdrName)
 mkExport (CCall  cconv) (L loc entity, v, ty) = return $ 
          -> (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
   where
     entity' | nullFS entity = mkExtName (unLoc v)
            | otherwise     = entity