Commit 96621b1b authored by Matthew Pickering's avatar Matthew Pickering Committed by Ben Gamari

Associate pattern synonyms with types in module exports

This patch implements #10653.

It adds the ability to bundle pattern synonyms with type constructors in
export lists so that users can treat pattern synonyms more like data
constructors.

Updates haddock submodule.

Test Plan: ./validate

Reviewers: goldfire, austin, bgamari

Reviewed By: bgamari

Subscribers: simonpj, gridaphobe, thomie

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

GHC Trac Issues: #10653
parent 3cfe60ae
......@@ -7,6 +7,9 @@
module Avail (
Avails,
AvailInfo(..),
IsPatSyn(..),
avail,
patSynAvail,
availsToNameSet,
availsToNameSetWithSelectors,
availsToNameEnv,
......@@ -31,7 +34,7 @@ import Data.Function
-- The AvailInfo type
-- | Records what things are "available", i.e. in scope
data AvailInfo = Avail Name -- ^ An ordinary identifier in scope
data AvailInfo = Avail IsPatSyn Name -- ^ An ordinary identifier in scope
| AvailTC Name
[Name]
[FieldLabel]
......@@ -52,6 +55,8 @@ data AvailInfo = Avail 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]
......@@ -105,7 +110,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`
......@@ -113,6 +118,12 @@ 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
-- -----------------------------------------------------------------------------
-- Operations on AvailInfo
......@@ -132,22 +143,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
......@@ -155,7 +166,6 @@ availFlds :: AvailInfo -> [FieldLabel]
availFlds (AvailTC _ _ fs) = fs
availFlds _ = []
-- -----------------------------------------------------------------------------
-- Printing
......@@ -163,13 +173,14 @@ instance Outputable AvailInfo where
ppr = pprAvail
pprAvail :: AvailInfo -> SDoc
pprAvail (Avail n) = ppr n
pprAvail (Avail _ n) = ppr n
pprAvail (AvailTC n ns fs) = ppr n <> braces (hsep (punctuate comma (map ppr ns ++ map (ppr . flLabel) fs)))
instance Binary AvailInfo where
put_ bh (Avail aa) = do
put_ bh (Avail b aa) = do
putByte bh 0
put_ bh aa
put_ bh b
put_ bh (AvailTC ab ac ad) = do
putByte bh 1
put_ bh ab
......@@ -179,8 +190,18 @@ instance Binary AvailInfo where
h <- getByte bh
case h of
0 -> do aa <- get bh
return (Avail aa)
b <- get bh
return (Avail b 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
......@@ -428,6 +428,7 @@ data Parent = NoParent
| ParentIs { par_is :: Name }
| FldParent { par_is :: Name, par_lbl :: Maybe FieldLabelString }
-- ^ See Note [Parents for record fields]
| PatternSynonym
deriving (Eq)
instance Outputable Parent where
......@@ -435,6 +436,7 @@ instance Outputable Parent where
ppr (ParentIs n) = ptext (sLit "parent:") <> ppr n
ppr (FldParent n f) = ptext (sLit "fldparent:")
<> ppr n <> colon <> ppr f
ppr (PatternSynonym) = ptext (sLit "pattern synonym")
plusParent :: Parent -> Parent -> Parent
-- See Note [Combining parents]
......@@ -442,7 +444,8 @@ 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 NoParent NoParent = NoParent
plusParent PatternSynonym PatternSynonym = PatternSynonym
plusParent _ _ = NoParent
hasParent :: Parent -> Parent -> Parent
#ifdef DEBUG
......@@ -628,18 +631,20 @@ greSrcSpan gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss } )
| otherwise = pprPanic "greSrcSpan" (ppr gre)
mkParent :: Name -> AvailInfo -> Parent
mkParent _ (Avail _) = NoParent
mkParent _ (Avail NotPatSyn _) = NoParent
mkParent _ (Avail IsPatSyn _) = PatternSynonym
mkParent n (AvailTC m _ _) | n == m = NoParent
| otherwise = ParentIs m
| otherwise = ParentIs m
availFromGRE :: GlobalRdrElt -> AvailInfo
availFromGRE (GRE { gre_name = me, gre_par = parent })
= case parent of
ParentIs p -> AvailTC p [me] []
NoParent | isTyConName me -> AvailTC me [me] []
| otherwise -> Avail me
| otherwise -> avail me
FldParent p Nothing -> AvailTC p [] [FieldLabel (occNameFS $ nameOccName me) False me]
FldParent p (Just lbl) -> AvailTC p [] [FieldLabel lbl True me]
PatternSynonym -> patSynAvail me
emptyGlobalRdrEnv :: GlobalRdrEnv
emptyGlobalRdrEnv = emptyOccEnv
......
......@@ -154,7 +154,10 @@ data IE name
-- For details on above see note [Api annotations] in ApiAnnotation
| IEThingWith (Located name) [Located name] [Located (FieldLbl name)]
| IEThingWith (Located name)
IEWildcard
[Located name]
[Located (FieldLbl name)]
-- ^ Class/Type plus some methods/constructors
-- and record fields; see Note [IEThingWith]
-- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen',
......@@ -173,6 +176,8 @@ data IE name
| IEDocNamed String -- ^ Reference to named doc
deriving (Eq, Data, Typeable)
data IEWildcard = NoIEWildcard | IEWildcard Int deriving (Eq, Data, Typeable)
{-
Note [IEThingWith]
~~~~~~~~~~~~~~~~~~
......@@ -191,12 +196,22 @@ See Note [Representing fields in AvailInfo] in Avail for more details.
-}
ieName :: IE name -> name
ieName (IEVar (L _ n)) = n
ieName (IEThingAbs (L _ n)) = n
ieName (IEThingWith (L _ n) _ _) = n
ieName (IEThingAll (L _ n)) = n
ieName (IEVar (L _ n)) = n
ieName (IEThingAbs (L _ n)) = n
ieName (IEThingWith (L _ n) _ _ _) = n
ieName (IEThingAll (L _ n)) = n
ieName _ = panic "ieName failed pattern match!"
ieNames :: IE a -> [a]
ieNames (IEVar (L _ n) ) = [n]
ieNames (IEThingAbs (L _ n) ) = [n]
ieNames (IEThingAll (L _ n) ) = [n]
ieNames (IEThingWith (L _ n) _ ns _) = n : map unLoc ns
ieNames (IEModuleContents _ ) = []
ieNames (IEGroup _ _ ) = []
ieNames (IEDoc _ ) = []
ieNames (IEDocNamed _ ) = []
pprImpExp :: (HasOccName name, OutputableBndr name) => name -> SDoc
pprImpExp name = type_pref <+> pprPrefixOcc name
where
......@@ -208,12 +223,20 @@ instance (HasOccName name, OutputableBndr name) => Outputable (IE name) where
ppr (IEVar var) = pprPrefixOcc (unLoc var)
ppr (IEThingAbs thing) = pprImpExp (unLoc thing)
ppr (IEThingAll thing) = hcat [pprImpExp (unLoc thing), text "(..)"]
ppr (IEThingWith thing withs flds)
ppr (IEThingWith thing wc withs flds)
= pprImpExp (unLoc thing) <> parens (fsep (punctuate comma
(map pprImpExp (map unLoc withs) ++
map (ppr . flLabel . unLoc) flds)))
ppWiths ++
map (ppr . flLabel . unLoc) flds))
where
ppWiths =
case wc of
NoIEWildcard ->
map (pprImpExp . unLoc) withs
IEWildcard pos ->
let (bs, as) = splitAt pos (map (pprImpExp . unLoc) withs)
in bs ++ [text ".."] ++ as
ppr (IEModuleContents mod')
= ptext (sLit "module") <+> ppr mod'
ppr (IEGroup n _) = text ("<IEGroup: " ++ (show n) ++ ">")
ppr (IEGroup n _) = text ("<IEGroup: " ++ show n ++ ">")
ppr (IEDoc doc) = ppr doc
ppr (IEDocNamed string) = text ("<IEDocNamed: " ++ string ++ ">")
......@@ -908,7 +908,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
(n':ns) | n==n' -> ppr n <> pp_export ns fs
......
......@@ -1080,7 +1080,7 @@ mkIfaceExports exports
= sortBy stableAvailCmp (map sort_subs exports)
where
sort_subs :: AvailInfo -> AvailInfo
sort_subs (Avail n) = Avail n
sort_subs (Avail b n) = Avail b 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)
......
......@@ -1799,7 +1799,7 @@ tyThingAvailInfo (ATyCon t)
dcs = tyConDataCons t
flds = tyConFieldLabels t
tyThingAvailInfo t
= Avail (getName t)
= avail (getName t)
{-
************************************************************************
......
......@@ -33,6 +33,7 @@ import Control.Monad ( unless, liftM )
import GHC.Exts
import Data.Char
import Control.Monad ( mplus )
import Control.Applicative ((<$))
-- compiler/hsSyn
import HsSyn
......@@ -79,6 +80,7 @@ import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilD
-- compiler/utils
import Util ( looksLikePackageName )
import Prelude
}
......@@ -632,9 +634,8 @@ exp_doc :: { OrdList (LIE RdrName) }
-- No longer allow things like [] and (,,,) to be exported
-- They are built in syntax, always available
export :: { OrdList (LIE RdrName) }
: qcname_ext export_subspec {% amsu (sLL $1 $> (mkModuleImpExp $1
(snd $ unLoc $2)))
(fst $ unLoc $2) }
: qcname_ext export_subspec {% mkModuleImpExp $1 (snd $ unLoc $2)
>>= \ie -> amsu (sLL $1 $> ie) (fst $ unLoc $2) }
| 'module' modid {% amsu (sLL $1 $> (IEModuleContents $2))
[mj AnnModule $1] }
| 'pattern' qcon {% amsu (sLL $1 $> (IEVar $2))
......@@ -642,18 +643,34 @@ export :: { OrdList (LIE RdrName) }
export_subspec :: { Located ([AddAnn],ImpExpSubSpec) }
: {- empty -} { sL0 ([],ImpExpAbs) }
| '(' '..' ')' { sLL $1 $> ([mop $1,mcp $3,mj AnnDotdot $2]
, ImpExpAll) }
| '(' ')' { sLL $1 $> ([mop $1,mcp $2],ImpExpList []) }
| '(' qcnames ')' { sLL $1 $> ([mop $1,mcp $3],ImpExpList (reverse $2)) }
qcnames :: { [Located RdrName] } -- A reversed list
: qcnames ',' qcname_ext {% (aa (head $1) (AnnComma, $2)) >>
return ($3 : $1) }
| qcname_ext { [$1] }
qcname_ext :: { Located RdrName } -- Variable or data constructor
-- or tagged type constructor
| '(' qcnames ')' {% mkImpExpSubSpec (reverse (snd $2))
>>= \(as,ie) -> return $ sLL $1 $>
(as ++ [mop $1,mcp $3] ++ fst $2, ie) }
qcnames :: { ([AddAnn], [Located (Maybe RdrName)]) }
: {- empty -} { ([],[]) }
| qcnames1 { $1 }
qcnames1 :: { ([AddAnn], [Located (Maybe RdrName)]) } -- A reversed list
: qcnames1 ',' qcname_ext_w_wildcard {% case (last (snd $1)) of
l@(L _ Nothing) ->
return ([mj AnnComma $2, mj AnnDotdot l]
,($3 : snd $1))
l -> (aa l (AnnComma, $2) >>
return (fst $1, $3 : snd $1)) }
-- Annotations readded in mkImpExpSubSpec
| qcname_ext_w_wildcard { ([],[$1]) }
-- Variable, data constructor or wildcard
-- or tagged type constructor
qcname_ext_w_wildcard :: { Located (Maybe RdrName) }
: qcname_ext { Just `fmap` $1 }
| '..' { Nothing <$ $1 }
qcname_ext :: { Located RdrName }
: qcname { $1 }
| 'type' oqtycon {% amms (mkTypeImpExp (sLL $1 $> (unLoc $2)))
[mj AnnType $1,mj AnnVal $2] }
......@@ -726,7 +743,10 @@ maybeas :: { ([AddAnn],Located (Maybe ModuleName)) }
| {- empty -} { ([],noLoc Nothing) }
maybeimpspec :: { Located (Maybe (Bool, Located [LIE RdrName])) }
: impspec { L (gl $1) (Just (unLoc $1)) }
: impspec {% let (b, ie) = unLoc $1 in
checkImportSpec ie
>>= \checkedIe ->
return (L (gl $1) (Just (b, checkedIe))) }
| {- empty -} { noLoc Nothing }
impspec :: { Located (Bool, Located [LIE RdrName]) }
......
......@@ -56,7 +56,9 @@ module RdrHsSyn (
-- Help with processing exports
ImpExpSubSpec(..),
mkModuleImpExp,
mkTypeImpExp
mkTypeImpExp,
mkImpExpSubSpec,
checkImportSpec
) where
......@@ -87,6 +89,7 @@ import FastString
import Maybes
import Util
import ApiAnnotation
import Data.List
#if __GLASGOW_HASKELL__ < 709
import Control.Applicative ((<$>))
......@@ -1328,16 +1331,31 @@ mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
--------------------------------------------------------------------------------
-- Help with module system imports/exports
data ImpExpSubSpec = ImpExpAbs | ImpExpAll | ImpExpList [Located RdrName]
data ImpExpSubSpec = ImpExpAbs
| ImpExpAll
| ImpExpList [Located RdrName]
| ImpExpAllWith [Located (Maybe RdrName)]
mkModuleImpExp :: Located RdrName -> ImpExpSubSpec -> IE RdrName
mkModuleImpExp :: Located RdrName -> ImpExpSubSpec -> P (IE RdrName)
mkModuleImpExp n@(L l name) subs =
case subs of
ImpExpAbs
| isVarNameSpace (rdrNameSpace name) -> IEVar n
| otherwise -> IEThingAbs (L l name)
ImpExpAll -> IEThingAll (L l name)
ImpExpList xs -> IEThingWith (L l name) xs []
| isVarNameSpace (rdrNameSpace name) -> return $ IEVar n
| otherwise -> return $ IEThingAbs (L l name)
ImpExpAll -> return $ IEThingAll (L l name)
ImpExpList xs ->
return $ IEThingWith (L l name) NoIEWildcard xs []
ImpExpAllWith xs ->
do allowed <- extension patternSynonymsEnabled
if allowed
then
let withs = map unLoc xs
pos = maybe NoIEWildcard IEWildcard
(findIndex isNothing withs)
ies = [L l n | L l (Just n) <- xs]
in return (IEThingWith (L l name) pos ies [])
else parseErrorSDoc l
(text "Illegal export form (use PatternSynonyms to enable)")
mkTypeImpExp :: Located RdrName -- TcCls or Var name space
-> P (Located RdrName)
......@@ -1348,6 +1366,28 @@ mkTypeImpExp name =
else parseErrorSDoc (getLoc name)
(text "Illegal keyword 'type' (use ExplicitNamespaces to enable)")
checkImportSpec :: Located [LIE RdrName] -> P (Located [LIE RdrName])
checkImportSpec ie@(L _ specs) =
case [l | (L l (IEThingWith _ (IEWildcard _) _ _)) <- specs] of
[] -> return ie
(l:_) -> importSpecError l
where
importSpecError l =
parseErrorSDoc l
(text "Illegal import form, this syntax can only be used to bundle"
$+$ text "pattern synonyms with types in module exports.")
-- In the correct order
mkImpExpSubSpec :: [Located (Maybe RdrName)] -> P ([AddAnn], ImpExpSubSpec)
mkImpExpSubSpec [] = return ([], ImpExpList [])
mkImpExpSubSpec [L l Nothing] =
return ([\s -> addAnnotation l AnnDotdot s], ImpExpAll)
mkImpExpSubSpec xs =
if (any (isNothing . unLoc) xs)
then return $ ([], ImpExpAllWith xs)
else return $ ([], ImpExpList ([L l x | L l (Just x) <- xs]))
-----------------------------------------------------------------------------
-- Misc utils
......
......@@ -151,8 +151,8 @@ wired-in Ids.
ghcPrimExports :: [IfaceExport]
ghcPrimExports
= map (Avail . idName) ghcPrimIds ++
map (Avail . idName . primOpId) allThePrimOps ++
= map (avail . idName) ghcPrimIds ++
map (avail . idName . primOpId) allThePrimOps ++
[ AvailTC n [n] []
| tc <- funTyCon : primTyCons, let n = tyConName tc ]
......
......@@ -922,7 +922,7 @@ lookupGreAvailRn rdr_name
Nothing ->
do { traceRn (text "lookupGreRn" <+> ppr rdr_name)
; let name = mkUnboundName rdr_name
; return (name, Avail name) } } }
; return (name, avail name) } } }
{-
*********************************************************
......@@ -1015,6 +1015,7 @@ lookupImpDeprec iface gre
ParentIs p -> mi_warn_fn iface p
FldParent { par_is = p } -> mi_warn_fn iface p
NoParent -> Nothing
PatternSynonym -> Nothing
{-
Note [Used names with interface not loaded]
......@@ -1824,6 +1825,7 @@ 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
......
This diff is collapsed.
......@@ -597,6 +597,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
, case gre_par gre of
ParentIs p -> p /= parent_tc
FldParent { par_is = p } -> p /= parent_tc
PatternSynonym -> True
NoParent -> True ]
where
rdr = mkVarUnqual lbl
......
......@@ -127,7 +127,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls,
let { id_bndrs = collectHsIdBinders new_lhs } ; -- Excludes pattern-synonym binders
-- They are already in scope
traceRn (text "rnSrcDecls" <+> ppr id_bndrs) ;
tc_envs <- extendGlobalRdrEnvRn (map Avail id_bndrs) local_fix_env ;
tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ;
traceRn (text "D2" <+> ppr (tcg_rdr_env (fst tc_envs)));
setEnvs tc_envs $ do {
......@@ -1548,7 +1548,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 Avail pat_syn_bndrs
; let avails = map patSynAvail pat_syn_bndrs
; (gbl_env, lcl_env) <-
extendGlobalRdrEnvRn avails local_fix_env
......
......@@ -487,7 +487,7 @@ renameDeriv is_boot inst_infos bagBinds
; let aux_val_binds = ValBindsIn aux_binds (bagToList aux_sigs)
; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds
; let bndrs = collectHsValBinders rn_aux_lhs
; envs <- extendGlobalRdrEnvRn (map Avail bndrs) emptyFsEnv ;
; envs <- extendGlobalRdrEnvRn (map avail bndrs) emptyFsEnv ;
; setEnvs envs $
do { (rn_aux, dus_aux) <- rnValBindsRHS (TopSigCtxt (mkNameSet bndrs)) rn_aux_lhs
; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
......
<
......@@ -29,7 +29,6 @@ module TcRnDriver (
import {-# SOURCE #-} TcSplice ( runQuasi )
import RnSplice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) )
import IfaceEnv( externaliseName )
import TcType ( isUnitTy, isTauTy )
import TcHsType
import TcMatches
import RnTypes
......@@ -65,6 +64,7 @@ import TcForeign
import TcInstDcls
import TcIface
import TcMType
import TcType
import MkIface
import TcSimplify
import TcTyClsDecls
......@@ -91,6 +91,7 @@ import ListSetOps
import Outputable
import ConLike
import DataCon
import PatSyn
import Type
import Class
import BasicTypes hiding( SuccessFlag(..) )
......@@ -102,6 +103,7 @@ import FastString
import Maybes
import Util
import Bag
import IdInfo
import Control.Monad
......@@ -326,7 +328,8 @@ tcRnModuleTcRnM hsc_env hsc_src
-- Process the export list
traceRn (text "rn4a: before exports");
tcg_env <- rnExports explicit_mod_hdr export_ies tcg_env ;
(rn_exports, tcg_env) <- rnExports explicit_mod_hdr export_ies tcg_env ;
tcExports rn_exports ;
traceRn (text "rn4b: after exports") ;
-- Check that main is exported (must be after rnExports)
......@@ -2024,6 +2027,141 @@ loadUnqualIfaces hsc_env ictxt
, unQualOK gre ] -- In scope unqualified
doc = ptext (sLit "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