Commit 759739c6 authored by simonpj's avatar simonpj
Browse files

[project @ 2004-12-02 17:18:15 by simonpj]

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.
parent 3ed515ed
......@@ -18,7 +18,7 @@ Haskell).
module Unique (
Unique, Uniquable(..), hasKey,
pprUnique,
pprUnique,
mkUnique, -- Used in UniqSupply
mkUniqueGrimily, -- Used in UniqSupply only!
......@@ -202,7 +202,7 @@ We do sometimes make strings with @Uniques@ in them:
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
......@@ -235,19 +235,18 @@ The ``62-its'' are \tr{[0-9a-zA-Z]}. We don't handle negative Ints.
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}
%************************************************************************
......
......@@ -15,27 +15,24 @@ import Language.Haskell.TH.Syntax as TH
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
......@@ -371,7 +368,6 @@ cvtPanic herald thing
-- some useful things
truePat = nlConPat (getRdrName trueDataCon) []
falsePat = nlConPat (getRdrName falseDataCon) []
overloadedLit :: Lit -> Bool
-- True for literals that Haskell treats as overloaded
......@@ -406,17 +402,21 @@ tconName = thRdrName OccName.tcName
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
......
......@@ -10,7 +10,7 @@ module IfaceEnv (
tcIfaceLclId, tcIfaceTyVar,
-- Name-cache stuff
allocateGlobalBinder, initNameCache
allocateGlobalBinder, initNameCache,
) where
#include "HsVersions.h"
......@@ -23,10 +23,11 @@ import TyCon ( TyCon, tyConName )
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 )
......
......@@ -251,9 +251,9 @@ mkIface :: HscEnv
-> 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,
......@@ -774,8 +774,8 @@ mkIfaceExports exports
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}
......
......@@ -265,7 +265,7 @@ data DynFlag
| Opt_AllowOverlappingInstances
| Opt_AllowUndecidableInstances
| Opt_AllowIncoherentInstances
| Opt_NoMonomorphismRestriction
| Opt_MonomorphismRestriction
| Opt_GlasgowExts
| Opt_FFI
| Opt_PArr -- syntactic support for parallel arrays
......@@ -273,7 +273,7 @@ data DynFlag
| Opt_TH
| Opt_ImplicitParams
| Opt_Generics
| Opt_NoImplicitPrelude
| Opt_ImplicitPrelude
-- optimisation opts
| Opt_Strictness
......@@ -391,6 +391,8 @@ defaultDynFlags = DynFlags {
pkgState = error "pkgState",
flags = [
Opt_ImplicitPrelude,
Opt_MonomorphismRestriction,
Opt_Generics,
-- Generating the helper-functions for
-- generics is now on by default
......
......@@ -437,11 +437,6 @@ dynamic_flags = [
, ( "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)) )
......@@ -470,6 +465,8 @@ fFlags = [
( "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 ),
......
......@@ -46,7 +46,7 @@ import HsTypes ( replaceTyVarName )
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 )
......@@ -73,19 +73,16 @@ import FastString ( FastString )
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)
......@@ -493,8 +490,8 @@ checks the type of the user thing against the type of the standard thing.
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 ->
......@@ -505,8 +502,8 @@ lookupSyntaxName std_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 ->
......
......@@ -75,9 +75,9 @@ rnImports imports
-- 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
......@@ -101,10 +101,10 @@ rnImports imports
-- 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]
......@@ -251,18 +251,29 @@ exportsToAvails :: [IfaceExport] -> TcRnIf gbl lcl NameSet
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,
......@@ -309,7 +320,7 @@ importsFromLocalDecls group
-- 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
......@@ -335,8 +346,8 @@ importsFromLocalDecls group
-- 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 $
......
......@@ -11,7 +11,7 @@ module TcBinds ( tcBindsAndThen, tcTopBinds, tcMonoBinds, tcSpecSigs ) where
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,
......@@ -720,8 +720,8 @@ find which tyvars are constrained.
\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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment