summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorIan Lynagh <igloo@earth.li>2011-04-27 00:33:28 +0100
committerIan Lynagh <igloo@earth.li>2011-04-27 00:33:28 +0100
commit7bb9684495e6724d6325719e76926cd35535f3af (patch)
treeb1b34a68bf125ac9bc6e6c3b566b9386685ed82b
parent78d8681a39e2bd4a8e35b921a37cd77f4c94c8e2 (diff)
parent6490ea6da6c0e86c3ef2c18ee2ad39e1716a7dcd (diff)
downloadhaskell-7bb9684495e6724d6325719e76926cd35535f3af.tar.gz
Merge branch 'master' of http://darcs.haskell.org/ghc
-rw-r--r--compiler/basicTypes/NameSet.lhs5
-rw-r--r--compiler/hsSyn/HsDecls.lhs30
-rw-r--r--compiler/hsSyn/HsImpExp.lhs11
-rw-r--r--compiler/iface/MkIface.lhs34
-rw-r--r--compiler/main/DriverMkDepend.hs2
-rw-r--r--compiler/main/DriverPipeline.hs4
-rw-r--r--compiler/main/GhcMake.hs9
-rw-r--r--compiler/main/HscMain.lhs11
-rw-r--r--compiler/main/HscTypes.lhs2
-rw-r--r--compiler/parser/Lexer.x42
-rw-r--r--compiler/prelude/PrelRules.lhs2
-rw-r--r--compiler/rename/RnSource.lhs2
-rw-r--r--compiler/typecheck/TcForeign.lhs153
-rw-r--r--compiler/typecheck/TcRnTypes.lhs2
14 files changed, 144 insertions, 165 deletions
diff --git a/compiler/basicTypes/NameSet.lhs b/compiler/basicTypes/NameSet.lhs
index a20d8abb01..bef9e928fd 100644
--- a/compiler/basicTypes/NameSet.lhs
+++ b/compiler/basicTypes/NameSet.lhs
@@ -181,7 +181,7 @@ duDefs dus = foldr get emptyNameSet dus
get (Just d1, _u1) d2 = d1 `unionNameSets` d2
allUses :: DefUses -> Uses
--- ^ Just like 'allUses', but 'Defs' are not eliminated from the 'Uses' returned
+-- ^ Just like 'duUses', but 'Defs' are not eliminated from the 'Uses' returned
allUses dus = foldr get emptyNameSet dus
where
get (_d1, u1) u2 = u1 `unionNameSets` u2
@@ -189,8 +189,7 @@ allUses dus = foldr get emptyNameSet dus
duUses :: DefUses -> Uses
-- ^ Collect all 'Uses', regardless of whether the group is itself used,
-- but remove 'Defs' on the way
-duUses dus
- = foldr get emptyNameSet dus
+duUses dus = foldr get emptyNameSet dus
where
get (Nothing, rhs_uses) uses = rhs_uses `unionNameSets` uses
get (Just defs, rhs_uses) uses = (rhs_uses `unionNameSets` uses)
diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index 345ec32ef3..53d2949aab 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -3,15 +3,7 @@
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-
-
\begin{code}
-{-# OPTIONS -fno-warn-incomplete-patterns #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
{-# LANGUAGE DeriveDataTypeable #-}
-- | Abstract syntax of global declarations.
@@ -630,15 +622,15 @@ instance OutputableBndr name
(ppr new_or_data <+>
(if isJust typats then ptext (sLit "instance") else empty) <+>
pp_decl_head (unLoc context) ltycon tyvars typats <+>
- ppr_sig mb_sig)
+ ppr_sigx mb_sig)
(pp_condecls condecls)
derivings
where
- ppr_sig Nothing = empty
- ppr_sig (Just kind) = dcolon <+> pprKind kind
+ ppr_sigx Nothing = empty
+ ppr_sigx (Just kind) = dcolon <+> pprKind kind
ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars,
- tcdFDs = fds,
+ tcdFDs = fds,
tcdSigs = sigs, tcdMeths = methods, tcdATs = ats})
| null sigs && null ats -- No "where" part
= top_matter
@@ -773,14 +765,14 @@ instance (OutputableBndr name) => Outputable (ConDecl name) where
ppr = pprConDecl
pprConDecl :: OutputableBndr name => ConDecl name -> SDoc
-pprConDecl (ConDecl { con_name =con, con_explicit = expl, con_qvars = tvs
+pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
, con_cxt = cxt, con_details = details
, con_res = ResTyH98, con_doc = doc })
- = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details con details]
+ = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details details]
where
- ppr_details con (InfixCon t1 t2) = hsep [ppr t1, pprHsInfix con, ppr t2]
- ppr_details con (PrefixCon tys) = hsep (pprHsVar con : map ppr tys)
- ppr_details con (RecCon fields) = ppr con <+> pprConDeclFields fields
+ ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprHsInfix con, ppr t2]
+ ppr_details (PrefixCon tys) = hsep (pprHsVar con : map ppr tys)
+ ppr_details (RecCon fields) = ppr con <+> pprConDeclFields fields
pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
, con_cxt = cxt, con_details = PrefixCon arg_tys
@@ -802,7 +794,7 @@ pprConDecl (ConDecl {con_name = con, con_details = InfixCon {}, con_res = ResTyG
%************************************************************************
%* *
-\subsection[InstDecl]{An instance declaration
+\subsection[InstDecl]{An instance declaration}
%* *
%************************************************************************
@@ -835,7 +827,7 @@ instDeclATs inst_decls = [at | L _ (InstDecl _ _ _ ats) <- inst_decls, at <- ats
%************************************************************************
%* *
-\subsection[DerivDecl]{A stand-alone instance deriving declaration
+\subsection[DerivDecl]{A stand-alone instance deriving declaration}
%* *
%************************************************************************
diff --git a/compiler/hsSyn/HsImpExp.lhs b/compiler/hsSyn/HsImpExp.lhs
index dd24aedb2b..501599993c 100644
--- a/compiler/hsSyn/HsImpExp.lhs
+++ b/compiler/hsSyn/HsImpExp.lhs
@@ -6,12 +6,6 @@
HsImpExp: Abstract syntax: imports, exports, interfaces
\begin{code}
-{-# OPTIONS -fno-warn-incomplete-patterns #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
{-# LANGUAGE DeriveDataTypeable #-}
module HsImpExp where
@@ -103,6 +97,7 @@ ieName (IEVar n) = n
ieName (IEThingAbs n) = n
ieName (IEThingWith n _) = n
ieName (IEThingAll n) = n
+ieName _ = panic "ieName failed pattern match!"
ieNames :: IE a -> [a]
ieNames (IEVar n ) = [n]
@@ -122,8 +117,8 @@ instance (Outputable name) => Outputable (IE name) where
ppr (IEThingAll thing) = hcat [ppr thing, text "(..)"]
ppr (IEThingWith thing withs)
= ppr thing <> parens (fsep (punctuate comma (map pprHsVar withs)))
- ppr (IEModuleContents mod)
- = ptext (sLit "module") <+> ppr mod
+ ppr (IEModuleContents mod')
+ = ptext (sLit "module") <+> ppr mod'
ppr (IEGroup n _) = text ("<IEGroup: " ++ (show n) ++ ">")
ppr (IEDoc doc) = ppr doc
ppr (IEDocNamed string) = text ("<IEDocNamed: " ++ string ++ ">")
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index b940cb15a7..c3270062c2 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -900,8 +900,8 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names
finsts_mod = mi_finsts iface
hash_env = mi_hash_fn iface
mod_hash = mi_mod_hash iface
- export_hash | depend_on_exports mod = Just (mi_exp_hash iface)
- | otherwise = Nothing
+ export_hash | depend_on_exports = Just (mi_exp_hash iface)
+ | otherwise = Nothing
used_occs = lookupModuleEnv ent_map mod `orElse` []
@@ -918,21 +918,21 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names
Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names)
Just r -> r
- depend_on_exports mod =
- case lookupModuleEnv direct_imports mod of
- Just _ -> True
- -- Even if we used 'import M ()', we have to register a
- -- usage on the export list because we are sensitive to
- -- changes in orphan instances/rules.
- Nothing -> False
- -- In GHC 6.8.x the above line read "True", and in
- -- fact it recorded a dependency on *all* the
- -- modules underneath in the dependency tree. This
- -- happens to make orphans work right, but is too
- -- expensive: it'll read too many interface files.
- -- The 'isNothing maybe_iface' check above saved us
- -- from generating many of these usages (at least in
- -- one-shot mode), but that's even more bogus!
+ depend_on_exports = is_direct_import
+ {- True
+ Even if we used 'import M ()', we have to register a
+ usage on the export list because we are sensitive to
+ changes in orphan instances/rules.
+ False
+ In GHC 6.8.x we always returned true, and in
+ fact it recorded a dependency on *all* the
+ modules underneath in the dependency tree. This
+ happens to make orphans work right, but is too
+ expensive: it'll read too many interface files.
+ The 'isNothing maybe_iface' check above saved us
+ from generating many of these usages (at least in
+ one-shot mode), but that's even more bogus!
+ -}
\end{code}
\begin{code}
diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs
index e430c6e269..1694aba9b8 100644
--- a/compiler/main/DriverMkDepend.hs
+++ b/compiler/main/DriverMkDepend.hs
@@ -16,7 +16,6 @@ module DriverMkDepend (
#include "HsVersions.h"
import qualified GHC
--- import GHC ( ModSummary(..), GhcMonad )
import GhcMonad
import HsSyn ( ImportDecl(..) )
import DynFlags
@@ -35,7 +34,6 @@ import FastString
import Exception
import ErrUtils
--- import MonadUtils ( liftIO )
import System.Directory
import System.FilePath
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index c23f674763..f92a4110b9 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -779,9 +779,9 @@ runPhase (Cpp sf) input_fn dflags0
src_opts <- io $ getOptionsFromFile dflags0 output_fn
(dflags2, unhandled_flags, warns)
<- io $ parseDynamicNoPackageFlags dflags0 src_opts
+ io $ checkProcessArgsResult unhandled_flags
unless (dopt Opt_Pp dflags2) $ io $ handleFlagWarnings dflags2 warns
-- the HsPp pass below will emit warnings
- io $ checkProcessArgsResult unhandled_flags
setDynFlags dflags2
@@ -814,8 +814,8 @@ runPhase (HsPp sf) input_fn dflags
(dflags1, unhandled_flags, warns)
<- io $ parseDynamicNoPackageFlags dflags src_opts
setDynFlags dflags1
- io $ handleFlagWarnings dflags1 warns
io $ checkProcessArgsResult unhandled_flags
+ io $ handleFlagWarnings dflags1 warns
return (Hsc sf, output_fn)
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index 0d4143560f..ab658942ac 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -1405,17 +1405,14 @@ preprocessFile hsc_env src_fn mb_phase Nothing
preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
= do
let dflags = hsc_dflags hsc_env
- -- case we bypass the preprocessing stage?
- let
- local_opts = getOptions dflags buf src_fn
- --
+ let local_opts = getOptions dflags buf src_fn
+
(dflags', leftovers, warns)
<- parseDynamicNoPackageFlags dflags local_opts
checkProcessArgsResult leftovers
handleFlagWarnings dflags' warns
- let
- needs_preprocessing
+ let needs_preprocessing
| Just (Unlit _) <- mb_phase = True
| Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True
-- note: local_opts is only required if there's no Unlit phase
diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs
index 70ddd6adb8..36e53a83f9 100644
--- a/compiler/main/HscMain.lhs
+++ b/compiler/main/HscMain.lhs
@@ -1132,12 +1132,11 @@ hscTcExpr -- Typecheck an expression (but don't run it)
hscTcExpr hsc_env expr = runHsc hsc_env $ do
maybe_stmt <- hscParseStmt expr
case maybe_stmt of
- Just (L _ (ExprStmt expr _ _)) ->
- ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr
- _ ->
- liftIO $ throwIO $ mkSrcErr $ unitBag $
- mkPlainErrMsg noSrcSpan
- (text "not an expression:" <+> quotes (text expr))
+ Just (L _ (ExprStmt expr _ _)) ->
+ ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr
+ _ ->
+ liftIO $ throwIO $ mkSrcErr $ unitBag $ mkPlainErrMsg noSrcSpan
+ (text "not an expression:" <+> quotes (text expr))
-- | Find the kind of a type
hscKcType
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index e59c2239a7..11f1a8bd8a 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -717,7 +717,7 @@ type ImportedMods = ModuleEnv [(ModuleName, Bool, SrcSpan)]
-- | A ModGuts is carried through the compiler, accumulating stuff as it goes
-- There is only one ModGuts at any time, the one for the module
-- being compiled right now. Once it is compiled, a 'ModIface' and
--- 'ModDetails' are extracted and the ModGuts is dicarded.
+-- 'ModDetails' are extracted and the ModGuts is discarded.
data ModGuts
= ModGuts {
mg_module :: !Module, -- ^ Module being compiled
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 5c41d7238d..a2d2276901 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -1856,7 +1856,7 @@ pragState dynflags buf loc = (mkPState dynflags buf loc) {
mkPState :: DynFlags -> StringBuffer -> SrcLoc -> PState
mkPState flags buf loc =
PState {
- buffer = buf,
+ buffer = buf,
dflags = flags,
messages = emptyMessages,
last_loc = mkSrcSpan loc loc,
@@ -1873,34 +1873,34 @@ mkPState flags buf loc =
alr_justClosedExplicitLetBlock = False
}
where
- bitmap = genericsBit `setBitIf` xopt Opt_Generics flags
- .|. ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags
- .|. parrBit `setBitIf` xopt Opt_ParallelArrays flags
- .|. arrowsBit `setBitIf` xopt Opt_Arrows flags
- .|. thBit `setBitIf` xopt Opt_TemplateHaskell flags
- .|. qqBit `setBitIf` xopt Opt_QuasiQuotes flags
- .|. ipBit `setBitIf` xopt Opt_ImplicitParams flags
- .|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags
- .|. bangPatBit `setBitIf` xopt Opt_BangPatterns flags
- .|. tyFamBit `setBitIf` xopt Opt_TypeFamilies flags
- .|. haddockBit `setBitIf` dopt Opt_Haddock flags
- .|. magicHashBit `setBitIf` xopt Opt_MagicHash flags
- .|. kindSigsBit `setBitIf` xopt Opt_KindSignatures flags
- .|. recursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags
- .|. recBit `setBitIf` xopt Opt_DoRec flags
- .|. recBit `setBitIf` xopt Opt_Arrows flags
- .|. unicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags
- .|. unboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags
+ bitmap = genericsBit `setBitIf` xopt Opt_Generics flags
+ .|. ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags
+ .|. parrBit `setBitIf` xopt Opt_ParallelArrays flags
+ .|. arrowsBit `setBitIf` xopt Opt_Arrows flags
+ .|. thBit `setBitIf` xopt Opt_TemplateHaskell flags
+ .|. qqBit `setBitIf` xopt Opt_QuasiQuotes flags
+ .|. ipBit `setBitIf` xopt Opt_ImplicitParams flags
+ .|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags
+ .|. bangPatBit `setBitIf` xopt Opt_BangPatterns flags
+ .|. tyFamBit `setBitIf` xopt Opt_TypeFamilies flags
+ .|. haddockBit `setBitIf` dopt Opt_Haddock flags
+ .|. magicHashBit `setBitIf` xopt Opt_MagicHash flags
+ .|. kindSigsBit `setBitIf` xopt Opt_KindSignatures flags
+ .|. recursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags
+ .|. recBit `setBitIf` xopt Opt_DoRec flags
+ .|. recBit `setBitIf` xopt Opt_Arrows flags
+ .|. unicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags
+ .|. unboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags
.|. datatypeContextsBit `setBitIf` xopt Opt_DatatypeContexts flags
.|. transformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags
.|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags
.|. alternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags
- .|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags
+ .|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags
.|. nondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags
--
setBitIf :: Int -> Bool -> Int
b `setBitIf` cond | cond = bit b
- | otherwise = 0
+ | otherwise = 0
addWarning :: DynFlag -> SrcSpan -> SDoc -> P ()
addWarning option srcspan warning
diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs
index b37556be12..8f2d21f364 100644
--- a/compiler/prelude/PrelRules.lhs
+++ b/compiler/prelude/PrelRules.lhs
@@ -54,7 +54,7 @@ Well, of course you'd need a lot of rules if you did it
like that, so we use a BuiltinRule instead, so that we
can match in any two literal values. So the rule is really
more like
- (Lit 4) +# (Lit y) = Lit (x+#y)
+ (Lit x) +# (Lit y) = Lit (x+#y)
where the (+#) on the rhs is done at compile time
That is why these rules are built in here. Other rules
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 725baeb04f..18c2dfd7ae 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -1252,4 +1252,4 @@ 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} \ No newline at end of file
+\end{code}
diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs
index 73fd449d32..8f53d6e7b8 100644
--- a/compiler/typecheck/TcForeign.lhs
+++ b/compiler/typecheck/TcForeign.lhs
@@ -12,11 +12,11 @@ is restricted to what the outside world understands (read C), and this
module checks to see if a foreign declaration has got a legal type.
\begin{code}
-module TcForeign
- (
- tcForeignImports
+module TcForeign
+ (
+ tcForeignImports
, tcForeignExports
- ) where
+ ) where
#include "HsVersions.h"
@@ -43,18 +43,18 @@ import FastString
-- Defines a binding
isForeignImport :: LForeignDecl name -> Bool
isForeignImport (L _ (ForeignImport _ _ _)) = True
-isForeignImport _ = False
+isForeignImport _ = False
-- Exports a binding
isForeignExport :: LForeignDecl name -> Bool
isForeignExport (L _ (ForeignExport _ _ _)) = True
-isForeignExport _ = False
+isForeignExport _ = False
\end{code}
%************************************************************************
-%* *
+%* *
\subsection{Imports}
-%* *
+%* *
%************************************************************************
\begin{code}
@@ -64,22 +64,22 @@ tcForeignImports decls
tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl)
- = addErrCtxt (foreignDeclCtxt fo) $
- do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
- ; let
- -- Drop the foralls before inspecting the
- -- structure of the foreign type.
- (_, t_ty) = tcSplitForAllTys sig_ty
- (arg_tys, res_ty) = tcSplitFunTys t_ty
- id = mkLocalId nm sig_ty
- -- Use a LocalId to obey the invariant that locally-defined
- -- things are LocalIds. However, it does not need zonking,
- -- (so TcHsSyn.zonkForeignExports ignores it).
-
- ; imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl
- -- Can't use sig_ty here because sig_ty :: Type and
- -- we need HsType Id hence the undefined
- ; return (id, ForeignImport (L loc id) undefined imp_decl') }
+ = addErrCtxt (foreignDeclCtxt fo) $
+ do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
+ ; let
+ -- Drop the foralls before inspecting the
+ -- structure of the foreign type.
+ (_, t_ty) = tcSplitForAllTys sig_ty
+ (arg_tys, res_ty) = tcSplitFunTys t_ty
+ id = mkLocalId nm sig_ty
+ -- Use a LocalId to obey the invariant that locally-defined
+ -- things are LocalIds. However, it does not need zonking,
+ -- (so TcHsSyn.zonkForeignExports ignores it).
+
+ ; imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl
+ -- Can't use sig_ty here because sig_ty :: Type and
+ -- we need HsType Id hence the undefined
+ ; return (id, ForeignImport (L loc id) undefined imp_decl') }
tcFImport d = pprPanic "tcFImport" (ppr d)
\end{code}
@@ -93,15 +93,15 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ (CLabel _))
do { checkCg checkCOrAsmOrLlvmOrInterp
; checkSafety safety
; check (isFFILabelTy res_ty) (illegalForeignTyErr empty sig_ty)
- ; return idecl } -- NB check res_ty not sig_ty!
- -- In case sig_ty is (forall a. ForeignPtr a)
+ ; return idecl } -- NB check res_ty not sig_ty!
+ -- In case sig_ty is (forall a. ForeignPtr a)
tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ CWrapper) = do
- -- Foreign wrapper (former f.e.d.)
- -- The type must be of the form ft -> IO (FunPtr ft), where ft is a
- -- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well
- -- as ft -> IO Addr is accepted, too. The use of the latter two forms
- -- is DEPRECATED, though.
+ -- Foreign wrapper (former f.e.d.)
+ -- The type must be of the form ft -> IO (FunPtr ft), where ft is a
+ -- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well
+ -- as ft -> IO Addr is accepted, too. The use of the latter two forms
+ -- is DEPRECATED, though.
checkCg checkCOrAsmOrLlvmOrInterp
checkCConv cconv
checkSafety safety
@@ -174,14 +174,14 @@ checkMissingAmpersand dflags arg_tys res_ty
\end{code}
%************************************************************************
-%* *
+%* *
\subsection{Exports}
-%* *
+%* *
%************************************************************************
\begin{code}
-tcForeignExports :: [LForeignDecl Name]
- -> TcM (LHsBinds TcId, [LForeignDecl TcId])
+tcForeignExports :: [LForeignDecl Name]
+ -> TcM (LHsBinds TcId, [LForeignDecl TcId])
tcForeignExports decls
= foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls)
where
@@ -190,25 +190,25 @@ tcForeignExports decls
return (b `consBag` binds, f:fs)
tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
-tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
- addErrCtxt (foreignDeclCtxt fo) $ do
+tcFExport fo@(ForeignExport (L loc nm) hs_ty spec)
+ = addErrCtxt (foreignDeclCtxt fo) $ do
- sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
- rhs <- tcPolyExpr (nlHsVar nm) sig_ty
+ sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
+ rhs <- tcPolyExpr (nlHsVar nm) sig_ty
- tcCheckFEType sig_ty spec
+ tcCheckFEType sig_ty spec
- -- we're exporting a function, but at a type possibly more
- -- constrained than its declared/inferred type. Hence the need
- -- to create a local binding which will call the exported function
- -- at a particular type (and, maybe, overloading).
+ -- we're exporting a function, but at a type possibly more
+ -- constrained than its declared/inferred type. Hence the need
+ -- to create a local binding which will call the exported function
+ -- at a particular type (and, maybe, overloading).
- -- We need to give a name to the new top-level binding that
- -- is *stable* (i.e. the compiler won't change it later),
- -- because this name will be referred to by the C code stub.
- id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc
- return (mkVarBind id rhs, ForeignExport (L loc id) undefined spec)
+ -- We need to give a name to the new top-level binding that
+ -- is *stable* (i.e. the compiler won't change it later),
+ -- because this name will be referred to by the C code stub.
+ id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc
+ return (mkVarBind id rhs, ForeignExport (L loc id) undefined spec)
tcFExport d = pprPanic "tcFExport" (ppr d)
\end{code}
@@ -232,9 +232,9 @@ tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do
%************************************************************************
-%* *
+%* *
\subsection{Miscellaneous}
-%* *
+%* *
%************************************************************************
\begin{code}
@@ -246,7 +246,7 @@ checkForeignArgs pred tys
go ty = check (pred ty) (illegalForeignTyErr argument ty)
------------ Checking result types for foreign calls ----------------------
--- Check that the type has the form
+-- Check that the type has the form
-- (IO t) or (t) , and that t satisfies the given predicate.
--
checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
@@ -256,14 +256,14 @@ nonIOok = True
mustBeIO = False
checkForeignRes non_io_result_ok pred_res_ty ty
- -- (IO t) is ok, and so is any newtype wrapping thereof
+ -- (IO t) is ok, and so is any newtype wrapping thereof
| Just (_, res_ty, _) <- tcSplitIOType_maybe ty,
pred_res_ty res_ty
= return ()
-
+
| otherwise
- = check (non_io_result_ok && pred_res_ty ty)
- (illegalForeignTyErr result ty)
+ = check (non_io_result_ok && pred_res_ty ty)
+ (illegalForeignTyErr result ty)
\end{code}
\begin{code}
@@ -272,7 +272,7 @@ checkCOrAsmOrLlvm HscC = Nothing
checkCOrAsmOrLlvm HscAsm = Nothing
checkCOrAsmOrLlvm HscLlvm = Nothing
checkCOrAsmOrLlvm _
- = Just (text "requires via-C, llvm (-fllvm) or native code generation (-fvia-C)")
+ = Just (text "requires via-C, llvm (-fllvm) or native code generation (-fvia-C)")
checkCOrAsmOrLlvmOrInterp :: HscTarget -> Maybe SDoc
checkCOrAsmOrLlvmOrInterp HscC = Nothing
@@ -280,7 +280,7 @@ checkCOrAsmOrLlvmOrInterp HscAsm = Nothing
checkCOrAsmOrLlvmOrInterp HscLlvm = Nothing
checkCOrAsmOrLlvmOrInterp HscInterpreted = Nothing
checkCOrAsmOrLlvmOrInterp _
- = Just (text "requires interpreted, C, Llvm or native code generation")
+ = Just (text "requires interpreted, C, Llvm or native code generation")
checkCOrAsmOrLlvmOrDotNetOrInterp :: HscTarget -> Maybe SDoc
checkCOrAsmOrLlvmOrDotNetOrInterp HscC = Nothing
@@ -288,33 +288,33 @@ checkCOrAsmOrLlvmOrDotNetOrInterp HscAsm = Nothing
checkCOrAsmOrLlvmOrDotNetOrInterp HscLlvm = Nothing
checkCOrAsmOrLlvmOrDotNetOrInterp HscInterpreted = Nothing
checkCOrAsmOrLlvmOrDotNetOrInterp _
- = Just (text "requires interpreted, C, Llvm or native code generation")
+ = Just (text "requires interpreted, C, Llvm or native code generation")
checkCg :: (HscTarget -> Maybe SDoc) -> TcM ()
checkCg check = do
- dflags <- getDOpts
- let target = hscTarget dflags
- case target of
- HscNothing -> return ()
- _ ->
- case check target of
- Nothing -> return ()
- Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
+ dflags <- getDOpts
+ let target = hscTarget dflags
+ case target of
+ HscNothing -> return ()
+ _ ->
+ case check target of
+ Nothing -> return ()
+ Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
\end{code}
-
+
Calling conventions
\begin{code}
checkCConv :: CCallConv -> TcM ()
-checkCConv CCallConv = return ()
+checkCConv CCallConv = return ()
#if i386_TARGET_ARCH
-checkCConv StdCallConv = return ()
+checkCConv StdCallConv = return ()
#else
-- This is a warning, not an error. see #3336
-checkCConv StdCallConv = addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform,"$$ text "treating as ccall")
+checkCConv StdCallConv = addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall")
#endif
checkCConv PrimCallConv = addErrTc (text "The `prim' calling convention can only be used with `foreign import'")
-checkCConv CmmCallConv = panic "checkCConv CmmCallConv"
+checkCConv CmmCallConv = panic "checkCConv CmmCallConv"
\end{code}
Deprecated "threadsafe" calls
@@ -329,12 +329,12 @@ Warnings
\begin{code}
check :: Bool -> Message -> TcM ()
-check True _ = return ()
+check True _ = return ()
check _ the_err = addErrTc the_err
illegalForeignTyErr :: SDoc -> Type -> SDoc
illegalForeignTyErr arg_or_res ty
- = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res,
+ = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res,
ptext (sLit "type in foreign declaration:")])
2 (hsep [ppr ty])
@@ -344,12 +344,11 @@ argument = text "argument"
result = text "result"
badCName :: CLabelString -> Message
-badCName target
- = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")]
+badCName target
+ = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")]
foreignDeclCtxt :: ForeignDecl Name -> SDoc
foreignDeclCtxt fo
= hang (ptext (sLit "When checking declaration:"))
2 (ppr fo)
\end{code}
-
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index 8858c136db..fc827298a3 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -639,7 +639,7 @@ plusImportAvails
(ImportAvails { imp_mods = mods2,
imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2,
imp_orphs = orphs2, imp_finsts = finsts2 })
- = ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2,
+ = ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2,
imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2,
imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2,
imp_orphs = orphs1 `unionLists` orphs2,