Sorry for the fact that there are overlapping three commits in here...
1. Make -fno-monomorphism-restriction
and -fno-implicit-prelude reversible, like other flags
2. Fix a wibble in the new ImportAvails story, in RnNames.mkExportAvails
3. Fix a Template Haskell bug that meant that top-level names created
with newName were not made properly unique.
module Unique (
Unique, Uniquable(..), hasKey,
- pprUnique,
+ pprUnique,
mkUnique, -- Used in UniqSupply
mkUniqueGrimily, -- Used in UniqSupply only!
pprUnique :: Unique -> SDoc
pprUnique uniq
= case unpkUnique uniq of
- (tag, u) -> finish_ppr tag u (iToBase62 u)
+ (tag, u) -> finish_ppr tag u (text (iToBase62 u))
#ifdef UNUSED
pprUnique10 :: Unique -> SDoc
Code stolen from Lennart.
\begin{code}
-iToBase62 :: Int -> SDoc
-
-iToBase62 n@(I# n#)
- = ASSERT(n >= 0)
- if n# <# 62# then
- case (indexCharOffAddr# chars62# n#) of { c ->
- char (C# c) }
- else
- case (quotRem n 62) of { (q, I# r#) ->
- case (indexCharOffAddr# chars62# r#) of { c ->
- (<>) (iToBase62 q) (char (C# c)) }}
+iToBase62 :: Int -> String
+iToBase62 n@(I# n#)
+ = ASSERT(n >= 0) go n# ""
where
- chars62# = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"#
+ go n# cs | n# <# 62#
+ = case (indexCharOffAddr# chars62# n#) of { c# -> C# c# : cs }
+ | otherwise
+ = case (quotRem (I# n#) 62) of { (I# q#, I# r#) ->
+ case (indexCharOffAddr# chars62# r#) of { c# ->
+ go q# (C# c# : cs) }}
+
+ chars62# = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"#
\end{code}
%************************************************************************
import HsSyn as Hs
import qualified Class (FunDep)
-import RdrName ( RdrName, mkRdrUnqual, mkRdrQual, mkOrig, nameRdrName, getRdrName )
+import RdrName ( RdrName, mkRdrUnqual, mkRdrQual, mkOrig, getRdrName )
import Module ( Module, mkModule )
-import RdrHsSyn ( mkHsIntegral, mkHsFractional, mkClassDecl, mkTyData )
-import Name ( mkInternalName )
+import RdrHsSyn ( mkClassDecl, mkTyData )
import qualified OccName
-import SrcLoc ( SrcLoc, generatedSrcLoc, noLoc, unLoc, Located(..),
- noSrcSpan, SrcSpan, srcLocSpan, noSrcLoc )
+import SrcLoc ( generatedSrcLoc, noLoc, unLoc, Located(..),
+ SrcSpan, srcLocSpan )
import Type ( Type )
-import TysWiredIn ( unitTyCon, tupleTyCon, trueDataCon, falseDataCon )
+import TysWiredIn ( unitTyCon, tupleTyCon, trueDataCon )
import BasicTypes( Boxity(..), RecFlag(Recursive) )
import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..),
CExportSpec(..))
-import HsDecls ( CImportSpec(..), ForeignImport(..), ForeignExport(..),
- ForeignDecl(..) )
-import FastString( FastString, mkFastString, nilFS )
-import Char ( ord, isAscii, isAlphaNum, isAlpha )
+import Char ( isAscii, isAlphaNum, isAlpha )
import List ( partition )
-import Unique ( Unique, mkUniqueGrimily )
+import Unique ( mkUniqueGrimily )
import ErrUtils (Message)
-import GLAEXTS ( Int#, Int(..) )
+import GLAEXTS ( Int(..) )
import Bag ( emptyBag, consBag )
+import FastString
import Outputable
-- some useful things
truePat = nlConPat (getRdrName trueDataCon) []
-falsePat = nlConPat (getRdrName falseDataCon) []
overloadedLit :: Lit -> Bool
-- True for literals that Haskell treats as overloaded
thRdrName :: OccName.NameSpace -> TH.Name -> RdrName
-- This turns a Name into a RdrName
--- The last case is slightly interesting. It constructs a
--- unique name from the unique in the TH thingy, so that the renamer
--- won't mess about. I hope. (Another possiblity would be to generate
--- "x_77" etc, but that could conceivably clash.)
-thRdrName ns (TH.Name occ (TH.NameG ns' mod)) = mkOrig (mk_mod mod) (mk_occ ns occ)
-thRdrName ns (TH.Name occ TH.NameS) = mkDynName ns occ
-thRdrName ns (TH.Name occ (TH.NameU uniq)) = nameRdrName (mkInternalName (mk_uniq uniq) (mk_occ ns occ) noSrcLoc)
-
-mk_uniq :: Int# -> Unique
-mk_uniq u = mkUniqueGrimily (I# u)
+thRdrName ns (TH.Name occ (TH.NameG ns' mod)) = mkOrig (mk_mod mod) (mk_occ ns occ)
+thRdrName ns (TH.Name occ TH.NameS) = mkDynName ns occ
+thRdrName ns (TH.Name occ (TH.NameU uniq))
+ = mkRdrUnqual (OccName.mkOccName ns uniq_str)
+ where
+ uniq_str = TH.occString occ ++ '[' : shows (mkUniqueGrimily (I# uniq)) "]"
+ -- The idea here is to make a name that
+ -- a) the user could not possibly write, and
+ -- b) cannot clash with another NameU
+ -- Previously I generated an Exact RdrName with mkInternalName.
+ -- This works fine for local binders, but does not work at all for
+ -- top-level binders, which must have External Names, since they are
+ -- rapidly baked into data constructors and the like. Baling out
+ -- and generating an unqualified RdrName here is the simple solution
-- The packing and unpacking is rather turgid :-(
mk_occ :: OccName.NameSpace -> TH.OccName -> OccName.OccName
tcIfaceLclId, tcIfaceTyVar,
-- Name-cache stuff
- allocateGlobalBinder, initNameCache
+ allocateGlobalBinder, initNameCache,
) where
#include "HsVersions.h"
import DataCon ( dataConWorkId, dataConName )
import Var ( TyVar, Id, varName )
import Name ( Name, nameUnique, nameModule,
- nameOccName, nameSrcLoc,
+ nameOccName, nameSrcLoc,
getOccName, nameParent_maybe,
isWiredInName, mkIPName,
mkExternalName, mkInternalName )
+
import OccName ( OccName, isTupleOcc_maybe, tcName, dataName,
lookupOccEnv, unitOccEnv, extendOccEnv, extendOccEnvList )
import PrelNames ( gHC_PRIM, pREL_TUP )
-> Maybe ModIface -- The old interface, if we have it
-> ModGuts -- The compiled, tidied module
-> IO ModIface -- The new one, complete with decls and versions
--- mkFinalIface
--- a) completes the interface
--- b) writes it out to a file if necessary
+-- mkIface
+-- a) Builds the ModIface
+-- b) Writes it out to a file if necessary
mkIface hsc_env location maybe_old_iface
guts@ModGuts{ mg_module = this_mod,
avail_fs = occNameFS (availName avail)
add_avail avail_fm _ = addToFM_C add_item avail_fm avail_fs avail
- add_item (AvailTC p occs) _ = AvailTC p (insert occ occs)
- add_item (Avail n) _ = pprPanic "MkIface.addAvail" (ppr n <+> ppr name)
+ add_item (AvailTC p occs) _ = AvailTC p (List.insert occ occs)
+ add_item (Avail n) _ = pprPanic "MkIface.addAvail" (ppr n <+> ppr name)
\end{code}
| Opt_AllowOverlappingInstances
| Opt_AllowUndecidableInstances
| Opt_AllowIncoherentInstances
- | Opt_NoMonomorphismRestriction
+ | Opt_MonomorphismRestriction
| Opt_GlasgowExts
| Opt_FFI
| Opt_PArr -- syntactic support for parallel arrays
| Opt_TH
| Opt_ImplicitParams
| Opt_Generics
- | Opt_NoImplicitPrelude
+ | Opt_ImplicitPrelude
-- optimisation opts
| Opt_Strictness
pkgState = error "pkgState",
flags = [
+ Opt_ImplicitPrelude,
+ Opt_MonomorphismRestriction,
Opt_Generics,
-- Generating the helper-functions for
-- generics is now on by default
, ( "fglasgow-exts", NoArg (mapM_ setDynFlag glasgowExtsFlags) )
, ( "fno-glasgow-exts", NoArg (mapM_ unSetDynFlag glasgowExtsFlags) )
- -- "active negatives"
- , ( "fno-implicit-prelude", NoArg (setDynFlag Opt_NoImplicitPrelude) )
- , ( "fno-monomorphism-restriction",
- NoArg (setDynFlag Opt_NoMonomorphismRestriction) )
-
-- the rest of the -f* and -fno-* flags
, ( "fno-", PrefixPred (\f -> isFFlag f) (\f -> unSetDynFlag (getFFlag f)) )
, ( "f", PrefixPred (\f -> isFFlag f) (\f -> setDynFlag (getFFlag f)) )
( "arrows", Opt_Arrows ), -- arrow syntax
( "parr", Opt_PArr ),
( "th", Opt_TH ),
+ ( "implicit-prelude", Opt_ImplicitPrelude ),
+ ( "monomorphism-restriction", Opt_MonomorphismRestriction ),
( "implicit-params", Opt_ImplicitParams ),
( "allow-overlapping-instances", Opt_AllowOverlappingInstances ),
( "allow-undecidable-instances", Opt_AllowUndecidableInstances ),
import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity )
import TcRnMonad
import Name ( Name, nameIsLocalOrFrom, mkInternalName, isInternalName,
- nameSrcLoc, nameOccName, nameModule, nameParent )
+ nameSrcLoc, nameOccName, nameModule, nameParent, isExternalName )
import NameSet
import OccName ( tcName, isDataOcc, occNameFlavour, reportIfUnused )
import Module ( Module )
newTopSrcBinder :: Module -> Maybe Name -> Located RdrName -> RnM Name
newTopSrcBinder this_mod mb_parent (L loc rdr_name)
| Just name <- isExact_maybe rdr_name
- -- This is here to catch
+ = -- This is here to catch
-- (a) Exact-name binders created by Template Haskell
-- (b) The PrelBase defn of (say) [] and similar, for which
-- the parser reads the special syntax and returns an Exact RdrName
- --
- -- We are at a binding site for the name, so check first that it
+ -- We are at a binding site for the name, so check first that it
-- the current module is the correct one; otherwise GHC can get
- -- very confused indeed. This test rejects code like
- -- data T = (,) Int Int
- -- unless we are in GHC.Tup
- = do checkErr (isInternalName name || this_mod == nameModule name)
- (badOrigBinding rdr_name)
- returnM name
+ -- very confused indeed.
+ ASSERT2( isExternalName name, ppr name )
+ ASSERT2( this_mod == nameModule name, ppr name )
+ returnM name
| isOrig rdr_name
= do checkErr (rdr_mod == this_mod || rdr_mod == rOOT_MAIN)
lookupSyntaxName :: Name -- The standard name
-> RnM (Name, FreeVars) -- Possibly a non-standard name
lookupSyntaxName std_name
- = doptM Opt_NoImplicitPrelude `thenM` \ no_prelude ->
- if not no_prelude then normal_case
+ = doptM Opt_ImplicitPrelude `thenM` \ implicit_prelude ->
+ if implicit_prelude then normal_case
else
-- Get the similarly named thing from the local environment
lookupOccRn (mkRdrUnqual (nameOccName std_name)) `thenM` \ usr_name ->
lookupSyntaxNames :: [Name] -- Standard names
-> RnM (ReboundNames Name, FreeVars) -- See comments with HsExpr.ReboundNames
lookupSyntaxNames std_names
- = doptM Opt_NoImplicitPrelude `thenM` \ no_prelude ->
- if not no_prelude then normal_case
+ = doptM Opt_ImplicitPrelude `thenM` \ implicit_prelude ->
+ if implicit_prelude then normal_case
else
-- Get the similarly named thing from the local environment
mappM (lookupOccRn . mkRdrUnqual . nameOccName) std_names `thenM` \ usr_names ->
-- Do the non {- SOURCE -} ones first, so that we get a helpful
-- warning for {- SOURCE -} ones that are unnecessary
this_mod <- getModule
- ; opt_no_prelude <- doptM Opt_NoImplicitPrelude
+ ; implicit_prelude <- doptM Opt_ImplicitPrelude
; let
- all_imports = mk_prel_imports this_mod opt_no_prelude ++ imports
+ all_imports = mk_prel_imports this_mod implicit_prelude ++ imports
(source, ordinary) = partition is_source_import all_imports
is_source_import (L _ (ImportDecl _ is_boot _ _ _)) = is_boot
-- NB: opt_NoImplicitPrelude is slightly different to import Prelude ();
-- because the former doesn't even look at Prelude.hi for instance
-- declarations, whereas the latter does.
- mk_prel_imports this_mod no_prelude
+ mk_prel_imports this_mod implicit_prelude
| this_mod == pRELUDE
|| explicit_prelude_import
- || no_prelude
+ || not implicit_prelude
= []
| otherwise = [preludeImportDecl]
exportsToAvails exports
= foldlM do_one emptyNameSet exports
where
- do_one acc (mod, exports) = foldlM (do_avail mod) acc exports
- do_avail mod acc (Avail n) = do { n' <- lookupOrig mod n;
- ; return (addOneToNameSet acc n') }
- do_avail mod acc (AvailTC n ns) = do { n' <- lookupOrig mod n
- ; ns' <- mappM (lookup_sub n') ns
- ; return (addListToNameSet acc (n':ns')) }
+ do_one acc (mod, exports) = foldlM (do_avail mod) acc exports
+ do_avail mod acc (Avail n) = do { n' <- lookupOrig mod n;
+ ; return (addOneToNameSet acc n') }
+ do_avail mod acc (AvailTC p_occ occs)
+ = do { p_name <- lookupOrig mod p_occ
+ ; ns <- mappM (lookup_sub p_name) occs
+ ; return (addListToNameSet acc ns) }
+ -- Remember that 'occs' is all the exported things, including
+ -- the parent. It's possible to export just class ops without
+ -- the class, via C( op ). If the class was exported too we'd
+ -- have C( C, op )
where
- lookup_sub parent occ = newGlobalBinder mod occ (Just parent) noSrcLoc
- -- Hack alert! Notice the newGlobalBinder. It ensures that the subordinate
- -- names record their parent; and that in turn ensures that the GlobalRdrEnv
- -- has the correct parent for all the names in its range.
- -- For imported things, we only suck in the binding site later, if ever.
+ lookup_sub parent occ
+ = newGlobalBinder mod occ mb_parent noSrcLoc
+ where
+ mb_parent | occ == p_occ = Nothing
+ | otherwise = Just parent
+
+ -- The use of newGlobalBinder here (rather than lookupOrig)
+ -- ensures that the subordinate names record their parent;
+ -- and that in turn ensures that the GlobalRdrEnv
+ -- has the correct parent for all the names in its range.
+ -- For imported things, we only suck in the binding site later, if ever.
-- Reason for all this:
-- Suppose module M exports type A.T, and constructor A.MkT
-- Then, we know that A.MkT is a subordinate name of A.T,
-- printer returns False. It seems awkward to fix, unfortunately.
mappM_ addDupDeclErr dups `thenM_`
- doptM Opt_NoImplicitPrelude `thenM` \ implicit_prelude ->
+ doptM Opt_ImplicitPrelude `thenM` \ implicit_prelude ->
let
prov = LocalDef this_mod
gbl_env = mkGlobalRdrEnv gres
-- Sigh. It doesn't matter because it only affects the Data.Tuple really.
-- The important thing is to trim down the exports.
filtered_names
- | implicit_prelude = filter (not . isBuiltInSyntax) all_names
- | otherwise = all_names
+ | implicit_prelude = all_names
+ | otherwise = filter (not . isBuiltInSyntax) all_names
imports = emptyImportAvails {
imp_env = unitModuleEnv this_mod $
import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
import {-# SOURCE #-} TcExpr ( tcCheckSigma, tcCheckRho )
-import CmdLineOpts ( DynFlag(Opt_NoMonomorphismRestriction) )
+import CmdLineOpts ( DynFlag(Opt_MonomorphismRestriction) )
import HsSyn ( HsExpr(..), HsBind(..), LHsBinds, Sig(..),
LSig, Match(..), HsBindGroup(..), IPBind(..),
LPat, GRHSs, MatchGroup(..), emptyLHsBinds, isEmptyLHsBinds,
\begin{code}
isUnRestrictedGroup :: LHsBinds Name -> [TcSigInfo] -> TcM Bool
isUnRestrictedGroup binds sigs
- = do { no_MR <- doptM Opt_NoMonomorphismRestriction
- ; return (no_MR || all_unrestricted) }
+ = do { mono_restriction <- doptM Opt_MonomorphismRestriction
+ ; return (not mono_restriction || all_unrestricted) }
where
all_unrestricted = all (unrestricted . unLoc) (bagToList binds)
tysig_names = map (idName . sig_id) sigs
projects / ghc-hetmet.git / commitdiff