Commit e660f4bf authored by Matthew Pickering's avatar Matthew Pickering

Rework renaming of children in export lists.

The target of this patch is exports such as:

```
module Foo ( T(A, B, C) ) where
```

Essentially this patch makes sure that we use the correct lookup functions in order
to lookup the names in parent-children export lists. This change
highlighted the complexity of this small part of GHC which accounts for
the scale.

This change was motivated by wanting to
remove the `PatternSynonym` constructor from `Parent`. As with all these
things, it quickly spiraled out of control into a much larger refactor.

Reviewers: simonpj, goldfire, bgamari, austin

Subscribers: adamgundry, thomie

Differential Revision: https://phabricator.haskell.org/D2179

GHC Trac Issues: #11970
parent 46b78e60
......@@ -5,9 +5,7 @@
module Avail (
Avails,
AvailInfo(..),
IsPatSyn(..),
avail,
patSynAvail,
availsToNameSet,
availsToNameSetWithSelectors,
availsToNameEnv,
......@@ -32,7 +30,7 @@ import Data.Function
-- The AvailInfo type
-- | Records what things are "available", i.e. in scope
data AvailInfo = Avail IsPatSyn Name -- ^ An ordinary identifier in scope
data AvailInfo = Avail Name -- ^ An ordinary identifier in scope
| AvailTC Name
[Name]
[FieldLabel]
......@@ -53,8 +51,6 @@ data AvailInfo = Avail IsPatSyn Name -- ^ An ordinary identifier in scope
-- Equality used when deciding if the
-- interface has changed
data IsPatSyn = NotPatSyn | IsPatSyn deriving Eq
-- | A collection of 'AvailInfo' - several things that are \"available\"
type Avails = [AvailInfo]
......@@ -108,7 +104,7 @@ modules.
-- | Compare lexicographically
stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering
stableAvailCmp (Avail _ n1) (Avail _ n2) = n1 `stableNameCmp` n2
stableAvailCmp (Avail n1) (Avail n2) = n1 `stableNameCmp` n2
stableAvailCmp (Avail {}) (AvailTC {}) = LT
stableAvailCmp (AvailTC n ns nfs) (AvailTC m ms mfs) =
(n `stableNameCmp` m) `thenCmp`
......@@ -116,11 +112,8 @@ stableAvailCmp (AvailTC n ns nfs) (AvailTC m ms mfs) =
(cmpList (stableNameCmp `on` flSelector) nfs mfs)
stableAvailCmp (AvailTC {}) (Avail {}) = GT
patSynAvail :: Name -> AvailInfo
patSynAvail n = Avail IsPatSyn n
avail :: Name -> AvailInfo
avail n = Avail NotPatSyn n
avail n = Avail n
-- -----------------------------------------------------------------------------
-- Operations on AvailInfo
......@@ -141,22 +134,22 @@ availsToNameEnv avails = foldr add emptyNameEnv avails
-- | Just the main name made available, i.e. not the available pieces
-- of type or class brought into scope by the 'GenAvailInfo'
availName :: AvailInfo -> Name
availName (Avail _ n) = n
availName (Avail n) = n
availName (AvailTC n _ _) = n
-- | All names made available by the availability information (excluding overloaded selectors)
availNames :: AvailInfo -> [Name]
availNames (Avail _ n) = [n]
availNames (Avail n) = [n]
availNames (AvailTC _ ns fs) = ns ++ [ flSelector f | f <- fs, not (flIsOverloaded f) ]
-- | All names made available by the availability information (including overloaded selectors)
availNamesWithSelectors :: AvailInfo -> [Name]
availNamesWithSelectors (Avail _ n) = [n]
availNamesWithSelectors (Avail n) = [n]
availNamesWithSelectors (AvailTC _ ns fs) = ns ++ map flSelector fs
-- | Names for non-fields made available by the availability information
availNonFldNames :: AvailInfo -> [Name]
availNonFldNames (Avail _ n) = [n]
availNonFldNames (Avail n) = [n]
availNonFldNames (AvailTC _ ns _) = ns
-- | Fields made available by the availability information
......@@ -171,17 +164,16 @@ instance Outputable AvailInfo where
ppr = pprAvail
pprAvail :: AvailInfo -> SDoc
pprAvail (Avail _ n)
pprAvail (Avail n)
= ppr n
pprAvail (AvailTC n ns fs)
= ppr n <> braces (sep [ fsep (punctuate comma (map ppr ns)) <> semi
, fsep (punctuate comma (map (ppr . flLabel) fs))])
instance Binary AvailInfo where
put_ bh (Avail b aa) = do
put_ bh (Avail aa) = do
putByte bh 0
put_ bh aa
put_ bh b
put_ bh (AvailTC ab ac ad) = do
putByte bh 1
put_ bh ab
......@@ -191,18 +183,8 @@ instance Binary AvailInfo where
h <- getByte bh
case h of
0 -> do aa <- get bh
b <- get bh
return (Avail b aa)
return (Avail aa)
_ -> do ab <- get bh
ac <- get bh
ad <- get bh
return (AvailTC ab ac ad)
instance Binary IsPatSyn where
put_ bh IsPatSyn = putByte bh 0
put_ bh NotPatSyn = putByte bh 1
get bh = do
h <- getByte bh
case h of
0 -> return IsPatSyn
_ -> return NotPatSyn
......@@ -463,15 +463,13 @@ data Parent = NoParent
| ParentIs { par_is :: Name }
| FldParent { par_is :: Name, par_lbl :: Maybe FieldLabelString }
-- ^ See Note [Parents for record fields]
| PatternSynonym
deriving (Eq, Data)
deriving (Eq, Data, Typeable)
instance Outputable Parent where
ppr NoParent = empty
ppr (ParentIs n) = text "parent:" <> ppr n
ppr (FldParent n f) = text "fldparent:"
<> ppr n <> colon <> ppr f
ppr (PatternSynonym) = text "pattern synonym"
plusParent :: Parent -> Parent -> Parent
-- See Note [Combining parents]
......@@ -479,7 +477,6 @@ plusParent p1@(ParentIs _) p2 = hasParent p1 p2
plusParent p1@(FldParent _ _) p2 = hasParent p1 p2
plusParent p1 p2@(ParentIs _) = hasParent p2 p1
plusParent p1 p2@(FldParent _ _) = hasParent p2 p1
plusParent PatternSynonym PatternSynonym = PatternSynonym
plusParent _ _ = NoParent
hasParent :: Parent -> Parent -> Parent
......@@ -530,19 +527,12 @@ Note [Parents]
class C Class operations
Associated type constructors
The `PatternSynonym` constructor is so called as pattern synonyms can be
bundled with any type constructor (during renaming). In other words, they can
have any parent.
~~~~~~~~~~~~~~~~~~~~~~~~~
Constructor Meaning
~~~~~~~~~~~~~~~~~~~~~~~~
NoParent Can not be bundled with a type constructor.
ParentIs n Can be bundled with the type constructor corresponding to
n.
PatternSynonym Can be bundled with any type constructor. It is so called
because only pattern synonyms can be bundled with any type
constructor.
FldParent See Note [Parents for record fields]
......@@ -573,6 +563,16 @@ Note that the OccName used when adding a GRE to the environment
(greOccName) now depends on the parent field: for FldParent it is the
field label, if present, rather than the selector name.
~~
Record pattern synonym selectors are treated differently. Their parent
information is `NoParent` in the module in which they are defined. This is because
a pattern synonym `P` has no parent constructor either.
However, if `f` is bundled with a type constructor `T` then whenever `f` is
imported the parent will use the `Parent` constructor so the parent of `f` is
now `T`.
Note [Combining parents]
~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -683,15 +683,13 @@ greSrcSpan gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss } )
| otherwise = pprPanic "greSrcSpan" (ppr gre)
mkParent :: Name -> AvailInfo -> Parent
mkParent _ (Avail NotPatSyn _) = NoParent
mkParent _ (Avail IsPatSyn _) = PatternSynonym
mkParent _ (Avail _) = NoParent
mkParent n (AvailTC m _ _) | n == m = NoParent
| otherwise = ParentIs m
availFromGRE :: GlobalRdrElt -> AvailInfo
availFromGRE (GRE { gre_name = me, gre_par = parent })
= case parent of
PatternSynonym -> patSynAvail me
ParentIs p -> AvailTC p [me] []
NoParent | isTyConName me -> AvailTC me [me] []
| otherwise -> avail me
......
......@@ -429,6 +429,7 @@ Library
TcPatSyn
TcRnDriver
TcBackpack
TcRnExports
TcRnMonad
TcRnTypes
TcRules
......
......@@ -1017,7 +1017,7 @@ When printing export lists, we print like this:
-}
pprExport :: IfaceExport -> SDoc
pprExport (Avail _ n) = ppr n
pprExport (Avail n) = ppr n
pprExport (AvailTC _ [] []) = Outputable.empty
pprExport (AvailTC n ns0 fs)
= case ns0 of
......
......@@ -910,7 +910,7 @@ mkIfaceExports exports
= sortBy stableAvailCmp (map sort_subs exports)
where
sort_subs :: AvailInfo -> AvailInfo
sort_subs (Avail b n) = Avail b n
sort_subs (Avail n) = Avail n
sort_subs (AvailTC n [] fs) = AvailTC n [] (sort_flds fs)
sort_subs (AvailTC n (m:ms) fs)
| n==m = AvailTC n (m:sortBy stableNameCmp ms) (sort_flds fs)
......
......@@ -1954,7 +1954,7 @@ tyThingAvailInfo (ATyCon t)
dcs = tyConDataCons t
flds = tyConFieldLabels t
tyThingAvailInfo (AConLike (PatSynCon p))
= map patSynAvail ((getName p) : map flSelector (patSynFieldLabels p))
= map avail ((getName p) : map flSelector (patSynFieldLabels p))
tyThingAvailInfo t
= [avail (getName t)]
......
......@@ -14,7 +14,7 @@ module RnEnv (
lookupLocalOccThLvl_maybe,
lookupTypeOccRn, lookupKindOccRn,
lookupGlobalOccRn, lookupGlobalOccRn_maybe,
lookupOccRn_overloaded, lookupGlobalOccRn_overloaded,
lookupOccRn_overloaded, lookupGlobalOccRn_overloaded, lookupExactOcc,
reportUnboundName, unknownNameSuggestions,
addNameClashErrRn,
......@@ -1058,7 +1058,6 @@ lookupImpDeprec iface gre
ParentIs p -> mi_warn_fn iface (nameOccName p)
FldParent { par_is = p } -> mi_warn_fn iface (nameOccName p)
NoParent -> Nothing
PatternSynonym -> Nothing
{-
Note [Used names with interface not loaded]
......@@ -2094,7 +2093,6 @@ warnUnusedTopBinds gres
let isBoot = tcg_src env == HsBootFile
let noParent gre = case gre_par gre of
NoParent -> True
PatternSynonym -> True
_ -> False
-- Don't warn about unused bindings with parents in
-- .hs-boot files, as you are sometimes required to give
......
......@@ -121,7 +121,7 @@ rnExpr (HsVar (L l v))
Just (Right fs@(_:_:_)) -> return (HsRecFld (Ambiguous (L l v)
PlaceHolder)
, mkFVs (map selectorFieldOcc fs));
Just (Right []) -> error "runExpr/HsVar" } }
Just (Right []) -> panic "runExpr/HsVar" } }
rnExpr (HsIPVar v)
= return (HsIPVar v, emptyFVs)
......
This diff is collapsed.
......@@ -2086,7 +2086,7 @@ extendPatSynEnv val_decls local_fix_env thing = do {
names_with_fls <- new_ps val_decls
; let pat_syn_bndrs = concat [ name: map flSelector fields
| (name, fields) <- names_with_fls ]
; let avails = map patSynAvail pat_syn_bndrs
; let avails = map avail pat_syn_bndrs
; (gbl_env, lcl_env) <- extendGlobalRdrEnvRn avails local_fix_env
; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls
......
......@@ -66,6 +66,7 @@ import RdrName
import TcHsSyn
import TcExpr
import TcRnMonad
import TcRnExports
import TcEvidence
import PprTyThing( pprTyThing )
import MkIface( tyThingToIfaceDecl )
......@@ -95,7 +96,6 @@ import RnEnv
import RnSource
import ErrUtils
import Id
import IdInfo
import VarEnv
import Module
import UniqDFM
......@@ -110,7 +110,6 @@ import ListSetOps
import Outputable
import ConLike
import DataCon
import PatSyn
import Type
import Class
import BasicTypes hiding( SuccessFlag(..) )
......@@ -249,8 +248,7 @@ tcRnModuleTcRnM hsc_env hsc_src
-- Process the export list
traceRn (text "rn4a: before exports");
(rn_exports, tcg_env) <- rnExports explicit_mod_hdr export_ies tcg_env ;
tcExports rn_exports ;
tcg_env <- tcRnExports explicit_mod_hdr export_ies tcg_env ;
traceRn (text "rn4b: after exports") ;
-- Check that main is exported (must be after rnExports)
......@@ -2289,140 +2287,6 @@ loadUnqualIfaces hsc_env ictxt
, unQualOK gre ] -- In scope unqualified
doc = text "Need interface for module whose export(s) are in scope unqualified"
{-
******************************************************************************
** Typechecking module exports
The renamer makes sure that only the correct pieces of a type or class can be
bundled with the type or class in the export list.
When it comes to pattern synonyms, in the renamer we have no way to check that
whether a pattern synonym should be allowed to be bundled or not so we allow
them to be bundled with any type or class. Here we then check that
1) Pattern synonyms are only bundled with types which are able to
have data constructors. Datatypes, newtypes and data families.
2) Are the correct type, for example if P is a synonym
then if we export Foo(P) then P should be an instance of Foo.
******************************************************************************
-}
tcExports :: Maybe [LIE Name]
-> TcM ()
tcExports Nothing = return ()
tcExports (Just ies) = checkNoErrs $ mapM_ tc_export ies
tc_export :: LIE Name -> TcM ()
tc_export ie@(L _ (IEThingWith name _ names sels)) =
addExportErrCtxt ie
$ tc_export_with (unLoc name) (map unLoc names
++ map (flSelector . unLoc) sels)
tc_export _ = return ()
addExportErrCtxt :: LIE Name -> TcM a -> TcM a
addExportErrCtxt (L l ie) = setSrcSpan l . addErrCtxt exportCtxt
where
exportCtxt = text "In the export:" <+> ppr ie
-- Note: [Types of TyCon]
--
-- This check appears to be overlly complicated, Richard asked why it
-- is not simply just `isAlgTyCon`. The answer for this is that
-- a classTyCon is also an `AlgTyCon` which we explicitly want to disallow.
-- (It is either a newtype or data depending on the number of methods)
--
--
-- Note: [Typing Pattern Synonym Exports]
-- It proved quite a challenge to precisely specify which pattern synonyms
-- should be allowed to be bundled with which type constructors.
-- In the end it was decided to be quite liberal in what we allow. Below is
-- how Simon described the implementation.
--
-- "Personally I think we should Keep It Simple. All this talk of
-- satisfiability makes me shiver. I suggest this: allow T( P ) in all
-- situations except where `P`'s type is ''visibly incompatible'' with
-- `T`.
--
-- What does "visibly incompatible" mean? `P` is visibly incompatible
-- with
-- `T` if
-- * `P`'s type is of form `... -> S t1 t2`
-- * `S` is a data/newtype constructor distinct from `T`
--
-- Nothing harmful happens if we allow `P` to be exported with
-- a type it can't possibly be useful for, but specifying a tighter
-- relationship is very awkward as you have discovered."
--
-- Note that this allows *any* pattern synonym to be bundled with any
-- datatype type constructor. For example, the following pattern `P` can be
-- bundled with any type.
--
-- ```
-- pattern P :: (A ~ f) => f
-- ```
--
-- So we provide basic type checking in order to help the user out, most
-- pattern synonyms are defined with definite type constructors, but don't
-- actually prevent a library author completely confusing their users if
-- they want to.
exportErrCtxt :: Outputable o => String -> o -> SDoc
exportErrCtxt herald exp =
text "In the" <+> text (herald ++ ":") <+> ppr exp
tc_export_with :: Name -- ^ Type constructor
-> [Name] -- ^ A mixture of data constructors, pattern syonyms
-- , class methods and record selectors.
-> TcM ()
tc_export_with n ns = do
ty_con <- tcLookupTyCon n
things <- mapM tcLookupGlobal ns
let psErr = exportErrCtxt "pattern synonym"
selErr = exportErrCtxt "pattern synonym record selector"
ps = [(psErr p,p) | AConLike (PatSynCon p) <- things]
sels = [(selErr i,p) | AnId i <- things
, isId i
, RecSelId {sel_tycon = RecSelPatSyn p} <- [idDetails i]]
pat_syns = ps ++ sels
-- See note [Types of TyCon]
checkTc ( null pat_syns || isTyConWithSrcDataCons ty_con) assocClassErr
let actual_res_ty =
mkTyConApp ty_con (mkTyVarTys (tyConTyVars ty_con))
mapM_ (tc_one_export_with actual_res_ty ty_con ) pat_syns
where
assocClassErr :: SDoc
assocClassErr =
text "Pattern synonyms can be bundled only with datatypes."
tc_one_export_with :: TcTauType -- ^ TyCon type
-> TyCon -- ^ Parent TyCon
-> (SDoc, PatSyn) -- ^ Corresponding bundled PatSyn
-- and pretty printed origin
-> TcM ()
tc_one_export_with actual_res_ty ty_con (errCtxt, pat_syn)
= addErrCtxt errCtxt $
let (_, _, _, _, _, res_ty) = patSynSig pat_syn
mtycon = tcSplitTyConApp_maybe res_ty
typeMismatchError :: SDoc
typeMismatchError =
text "Pattern synonyms can only be bundled with matching type constructors"
$$ text "Couldn't match expected type of"
<+> quotes (ppr actual_res_ty)
<+> text "with actual type of"
<+> quotes (ppr res_ty)
in case mtycon of
Nothing -> return ()
Just (p_ty_con, _) ->
-- See note [Typing Pattern Synonym Exports]
unless (p_ty_con == ty_con)
(addErrTc typeMismatchError)
{-
......
This diff is collapsed.
......@@ -66,7 +66,7 @@ module TcRnMonad(
-- * Shared error message stuff: renamer and typechecker
mkLongErrAt, mkErrDocAt, addLongErrAt, reportErrors, reportError,
reportWarning, recoverM, mapAndRecoverM, mapAndReportM,
reportWarning, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM,
tryTc,
askNoErrs, discardErrs,
tryTcErrs, tryTcLIE_,
......@@ -950,15 +950,20 @@ recoverM recover thing
-----------------------
mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
-- Drop elements of the input that fail, so the result
-- | Drop elements of the input that fail, so the result
-- list can be shorter than the argument list
mapAndRecoverM _ [] = return []
mapAndRecoverM f (x:xs) = do { mb_r <- try_m (f x)
; rs <- mapAndRecoverM f xs
; return (case mb_r of
Left _ -> rs
Right r -> r:rs) }
mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
mapAndRecoverM f = fmap reverse . foldAndRecoverM (\xs x -> (:xs) <$> f x ) []
-- | The accumulator is not updated if the action fails
foldAndRecoverM :: (b -> a -> TcRn b) -> b -> [a] -> TcRn b
foldAndRecoverM _ acc [] = return acc
foldAndRecoverM f acc (x:xs) =
do { mb_r <- try_m (f acc x)
; case mb_r of
Left _ -> foldAndRecoverM f acc xs
Right acc' -> foldAndRecoverM f acc' xs }
-- | Succeeds if applying the argument to all members of the lists succeeds,
-- but nevertheless runs it on all arguments, to collect all errors.
......
......@@ -178,7 +178,7 @@ module TcType (
toTcTypeBag, -- :: Bag EvVar -> Bag EvVar
pprKind, pprParendKind, pprSigmaType,
pprType, pprParendType, pprTypeApp, pprTyThingCategory,
pprType, pprParendType, pprTypeApp, pprTyThingCategory, tyThingCategory,
pprTheta, pprThetaArrowTy, pprClassPred,
pprTvBndr, pprTvBndrs,
......
......@@ -22,7 +22,7 @@ Note [The Type-related module hierarchy]
{-# LANGUAGE ImplicitParams #-}
module TyCoRep (
TyThing(..), pprTyThingCategory, pprShortTyThing,
TyThing(..), tyThingCategory, pprTyThingCategory, pprShortTyThing,
-- * Types
Type(..),
......@@ -216,13 +216,16 @@ pprShortTyThing thing
= pprTyThingCategory thing <+> quotes (ppr (getName thing))
pprTyThingCategory :: TyThing -> SDoc
pprTyThingCategory (ATyCon tc)
| isClassTyCon tc = text "Class"
| otherwise = text "Type constructor"
pprTyThingCategory (ACoAxiom _) = text "Coercion axiom"
pprTyThingCategory (AnId _) = text "Identifier"
pprTyThingCategory (AConLike (RealDataCon _)) = text "Data constructor"
pprTyThingCategory (AConLike (PatSynCon _)) = text "Pattern synonym"
pprTyThingCategory = text . capitalise . tyThingCategory
tyThingCategory :: TyThing -> String
tyThingCategory (ATyCon tc)
| isClassTyCon tc = "class"
| otherwise = "type constructor"
tyThingCategory (ACoAxiom _) = "coercion axiom"
tyThingCategory (AnId _) = "identifier"
tyThingCategory (AConLike (RealDataCon _)) = "data constructor"
tyThingCategory (AConLike (PatSynCon _)) = "pattern synonym"
{- **********************************************************************
......
......@@ -56,7 +56,7 @@ module Util (
-- * List operations controlled by another list
takeList, dropList, splitAtList, split,
dropTail,
dropTail, capitalise,
-- * For loop
nTimes,
......@@ -147,7 +147,7 @@ import System.IO.Error as IO ( isDoesNotExistError )
import System.Directory ( doesDirectoryExist, getModificationTime )
import System.FilePath
import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit )
import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit, toUpper)
import Data.Int
import Data.Ratio ( (%) )
import Data.Ord ( comparing )
......@@ -720,6 +720,12 @@ split c s = case rest of
_:rest -> chunk : split c rest
where (chunk, rest) = break (==c) s
-- | Convert a word to title case by capitalising the first letter
capitalise :: String -> String
capitalise [] = []
capitalise (c:cs) = toUpper c : cs
{-
************************************************************************
* *
......
{-# LANGUAGE PatternSynonyms #-}
module Foo ( A(x, x) ) where
data A = A Int
pattern Pattern{x} = A x
MultiExport.hs:2:14: warning: [-Wduplicate-exports (in -Wdefault)]
‘x’ is exported by ‘A(x, x)’ and ‘A(x, x)’
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PatternSynonyms #-}
module T11970(B(recSel), Foo((--.->)), C(C,P,x,Q, B, recSel)) where
pattern D = Nothing
newtype B = B { recSel :: Int }
class Foo a where
type (--.->) a
newtype C = C Int
pattern P x = C x
pattern Q{x} = C x
T11970.hs:6:40: error:
• The type constructor ‘C’ is not the parent of the data constructor ‘B’.
Data constructors can only be exported with their parent type constructor.