{-# LANGUAGE CPP #-}
module Smuggler2.Imports (getMinimalImports) where
import Avail ( AvailInfo(..) )
import BasicTypes ( StringLiteral(sl_fs) )
import FieldLabel ( FieldLbl(flIsOverloaded, flLabel, flSelector) )
import GHC
( GhcRn,
IE(IEThingAbs, IEThingAll, IEThingWith, IEVar),
IEWildcard(NoIEWildcard),
IEWrappedName(IEName, IEPattern, IEType),
ImportDecl(ImportDecl, ideclHiding, ideclName, ideclPkgQual,
ideclSource),
LIEWrappedName,
LImportDecl )
import HscTypes
import LoadIface ( loadSrcInterface )
import Name ( HasOccName(..), isDataOcc, isTcOcc )
import Outputable ( Outputable(ppr), text, (<+>) )
#if MIN_VERSION_GLASGOW_HASKELL(8,8,0,0)
import RdrName ( gresToAvailInfo )
#endif
import RnNames ( ImportDeclUsage )
import SrcLoc ( GenLocated(L), Located, noLoc )
import TcRnMonad ( RnM )
import Language.Haskell.GHC.ExactPrint.Types ( noExt )
getMinimalImports :: [ImportDeclUsage] -> RnM [LImportDecl GhcRn]
getMinimalImports :: [ImportDeclUsage] -> RnM [LImportDecl GhcRn]
getMinimalImports = (ImportDeclUsage
-> IOEnv (Env TcGblEnv TcLclEnv) (LImportDecl GhcRn))
-> [ImportDeclUsage] -> RnM [LImportDecl GhcRn]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ImportDeclUsage
-> IOEnv (Env TcGblEnv TcLclEnv) (LImportDecl GhcRn)
forall (t :: * -> *) a.
Foldable t =>
(LImportDecl GhcRn, [GlobalRdrElt], t a)
-> IOEnv (Env TcGblEnv TcLclEnv) (LImportDecl GhcRn)
mk_minimal
where
mk_minimal :: (LImportDecl GhcRn, [GlobalRdrElt], t a)
-> IOEnv (Env TcGblEnv TcLclEnv) (LImportDecl GhcRn)
mk_minimal (L SrcSpan
l ImportDecl GhcRn
decl, [GlobalRdrElt]
used_gres, t a
unused)
| t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
unused
, Just (Bool
False, Located [LIE GhcRn]
_) <- ImportDecl GhcRn -> Maybe (Bool, Located [LIE GhcRn])
forall pass. ImportDecl pass -> Maybe (Bool, Located [LIE pass])
ideclHiding ImportDecl GhcRn
decl
= LImportDecl GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (LImportDecl GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> ImportDecl GhcRn -> LImportDecl GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
l ImportDecl GhcRn
decl)
| Bool
otherwise
= do { let ImportDecl { ideclName :: forall pass. ImportDecl pass -> Located ModuleName
ideclName = L SrcSpan
_ ModuleName
mod_name
, ideclSource :: forall pass. ImportDecl pass -> Bool
ideclSource = Bool
is_boot
, ideclPkgQual :: forall pass. ImportDecl pass -> Maybe StringLiteral
ideclPkgQual = Maybe StringLiteral
mb_pkg } = ImportDecl GhcRn
decl
; ModIface
iface <- SDoc -> ModuleName -> Bool -> Maybe FastString -> RnM ModIface
loadSrcInterface SDoc
doc ModuleName
mod_name Bool
is_boot ((StringLiteral -> FastString)
-> Maybe StringLiteral -> Maybe FastString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StringLiteral -> FastString
sl_fs Maybe StringLiteral
mb_pkg)
#if MIN_VERSION_GLASGOW_HASKELL(8,8,0,0)
; let used_avails :: [AvailInfo]
used_avails = [GlobalRdrElt] -> [AvailInfo]
gresToAvailInfo [GlobalRdrElt]
used_gres
lies :: [LIE GhcRn]
lies = (IE GhcRn -> LIE GhcRn) -> [IE GhcRn] -> [LIE GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map (SrcSpan -> IE GhcRn -> LIE GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
l) ((AvailInfo -> [IE GhcRn]) -> [AvailInfo] -> [IE GhcRn]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ModIface -> AvailInfo -> [IE GhcRn]
to_ie ModIface
iface) [AvailInfo]
used_avails)
#else
; let lies = map (L l) (concatMap (to_ie iface) used_gres)
#endif
; LImportDecl GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (LImportDecl GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> ImportDecl GhcRn -> LImportDecl GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (ImportDecl GhcRn
decl { ideclHiding :: Maybe (Bool, Located [LIE GhcRn])
ideclHiding = (Bool, Located [LIE GhcRn]) -> Maybe (Bool, Located [LIE GhcRn])
forall a. a -> Maybe a
Just (Bool
False, SrcSpan -> [LIE GhcRn] -> Located [LIE GhcRn]
forall l e. l -> e -> GenLocated l e
L SrcSpan
l [LIE GhcRn]
lies) })) }
where
doc :: SDoc
doc = String -> SDoc
text String
"Compute minimal imports for" SDoc -> SDoc -> SDoc
<+> ImportDecl GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr ImportDecl GhcRn
decl
to_ie :: ModIface -> AvailInfo -> [IE GhcRn]
to_ie :: ModIface -> AvailInfo -> [IE GhcRn]
to_ie ModIface
_ (Avail Name
n)
= [XIEVar GhcRn -> LIEWrappedName (IdP GhcRn) -> IE GhcRn
forall pass. XIEVar pass -> LIEWrappedName (IdP pass) -> IE pass
IEVar NoExtField
XIEVar GhcRn
noExt (Located Name -> LIEWrappedName Name
forall name. HasOccName name => Located name -> LIEWrappedName name
to_ie_post_rn_var (Located Name -> LIEWrappedName Name)
-> Located Name -> LIEWrappedName Name
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located Name)
Name
n)]
to_ie ModIface
_ (AvailTC Name
n [Name
m] [])
| Name
nName -> Name -> Bool
forall a. Eq a => a -> a -> Bool
==Name
m = [XIEThingAbs GhcRn -> LIEWrappedName (IdP GhcRn) -> IE GhcRn
forall pass.
XIEThingAbs pass -> LIEWrappedName (IdP pass) -> IE pass
IEThingAbs NoExtField
XIEThingAbs GhcRn
noExt (Located Name -> LIEWrappedName Name
forall name. Located name -> LIEWrappedName name
to_ie_post_rn_name (Located Name -> LIEWrappedName Name)
-> Located Name -> LIEWrappedName Name
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located Name)
Name
n)]
to_ie ModIface
iface (AvailTC Name
n [Name]
ns [FieldLabel]
fs)
= case [([Name]
xs,[FieldLabel]
gs) | AvailTC Name
x [Name]
xs [FieldLabel]
gs <- ModIface -> [AvailInfo]
forall (phase :: ModIfacePhase). ModIface_ phase -> [AvailInfo]
mi_exports ModIface
iface
, Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n
, Name
x Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
xs
] of
[([Name], [FieldLabel])
xs] | ([Name], [FieldLabel]) -> Bool
all_used ([Name], [FieldLabel])
xs -> [XIEThingAll GhcRn -> LIEWrappedName (IdP GhcRn) -> IE GhcRn
forall pass.
XIEThingAll pass -> LIEWrappedName (IdP pass) -> IE pass
IEThingAll NoExtField
XIEThingAll GhcRn
noExt (Located Name -> LIEWrappedName Name
forall name. Located name -> LIEWrappedName name
to_ie_post_rn_name (Located Name -> LIEWrappedName Name)
-> Located Name -> LIEWrappedName Name
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located Name)
Name
n)]
| OccName -> Bool
isTcOcc (Name -> OccName
forall name. HasOccName name => name -> OccName
occName Name
n) ->
[XIEThingWith GhcRn
-> LIEWrappedName (IdP GhcRn)
-> IEWildcard
-> [LIEWrappedName (IdP GhcRn)]
-> [Located (FieldLbl (IdP GhcRn))]
-> IE GhcRn
forall pass.
XIEThingWith pass
-> LIEWrappedName (IdP pass)
-> IEWildcard
-> [LIEWrappedName (IdP pass)]
-> [Located (FieldLbl (IdP pass))]
-> IE pass
IEThingWith NoExtField
XIEThingWith GhcRn
noExt (Located Name -> LIEWrappedName Name
forall name. Located name -> LIEWrappedName name
to_ie_post_rn_name (Located Name -> LIEWrappedName Name)
-> Located Name -> LIEWrappedName Name
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located Name)
Name
n) IEWildcard
NoIEWildcard
((Name -> LIEWrappedName Name) -> [Name] -> [LIEWrappedName Name]
forall a b. (a -> b) -> [a] -> [b]
map (Located Name -> LIEWrappedName Name
forall name. HasOccName name => Located name -> LIEWrappedName name
to_ie_post_rn_varn (Located Name -> LIEWrappedName Name)
-> (Name -> Located Name) -> Name -> LIEWrappedName Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Located Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc) ((Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
n) [Name]
ns))
((FieldLabel -> Located FieldLabel)
-> [FieldLabel] -> [Located FieldLabel]
forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> Located FieldLabel
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc [FieldLabel]
fs)]
| Bool
otherwise ->
[XIEThingWith GhcRn
-> LIEWrappedName (IdP GhcRn)
-> IEWildcard
-> [LIEWrappedName (IdP GhcRn)]
-> [Located (FieldLbl (IdP GhcRn))]
-> IE GhcRn
forall pass.
XIEThingWith pass
-> LIEWrappedName (IdP pass)
-> IEWildcard
-> [LIEWrappedName (IdP pass)]
-> [Located (FieldLbl (IdP pass))]
-> IE pass
IEThingWith NoExtField
XIEThingWith GhcRn
noExt (Located Name -> LIEWrappedName Name
forall name. Located name -> LIEWrappedName name
to_ie_post_rn_name (Located Name -> LIEWrappedName Name)
-> Located Name -> LIEWrappedName Name
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located Name)
Name
n) IEWildcard
NoIEWildcard
((Name -> LIEWrappedName Name) -> [Name] -> [LIEWrappedName Name]
forall a b. (a -> b) -> [a] -> [b]
map (Located Name -> LIEWrappedName Name
forall name. HasOccName name => Located name -> LIEWrappedName name
to_ie_post_rn_cname (Located Name -> LIEWrappedName Name)
-> (Name -> Located Name) -> Name -> LIEWrappedName Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Located Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc) ((Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
n) [Name]
ns))
((FieldLabel -> Located FieldLabel)
-> [FieldLabel] -> [Located FieldLabel]
forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> Located FieldLabel
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc [FieldLabel]
fs)]
[([Name], [FieldLabel])]
_other | [FieldLabel] -> Bool
forall a. [FieldLbl a] -> Bool
all_non_overloaded [FieldLabel]
fs
-> (Name -> IE GhcRn) -> [Name] -> [IE GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map (XIEVar GhcRn -> LIEWrappedName (IdP GhcRn) -> IE GhcRn
forall pass. XIEVar pass -> LIEWrappedName (IdP pass) -> IE pass
IEVar NoExtField
XIEVar GhcRn
noExt (LIEWrappedName Name -> IE GhcRn)
-> (Name -> LIEWrappedName Name) -> Name -> IE GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located Name -> LIEWrappedName Name
forall name. Located name -> LIEWrappedName name
to_ie_post_rn_name (Located Name -> LIEWrappedName Name)
-> (Name -> Located Name) -> Name -> LIEWrappedName Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Located Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc) ([Name] -> [IE GhcRn]) -> [Name] -> [IE GhcRn]
forall a b. (a -> b) -> a -> b
$ [Name]
ns
[Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ (FieldLabel -> Name) -> [FieldLabel] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> Name
forall a. FieldLbl a -> a
flSelector [FieldLabel]
fs
| Bool
otherwise ->
[XIEThingWith GhcRn
-> LIEWrappedName (IdP GhcRn)
-> IEWildcard
-> [LIEWrappedName (IdP GhcRn)]
-> [Located (FieldLbl (IdP GhcRn))]
-> IE GhcRn
forall pass.
XIEThingWith pass
-> LIEWrappedName (IdP pass)
-> IEWildcard
-> [LIEWrappedName (IdP pass)]
-> [Located (FieldLbl (IdP pass))]
-> IE pass
IEThingWith NoExtField
XIEThingWith GhcRn
noExt (Located Name -> LIEWrappedName Name
forall name. Located name -> LIEWrappedName name
to_ie_post_rn_name (Located Name -> LIEWrappedName Name)
-> Located Name -> LIEWrappedName Name
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located Name)
Name
n) IEWildcard
NoIEWildcard
((Name -> LIEWrappedName Name) -> [Name] -> [LIEWrappedName Name]
forall a b. (a -> b) -> [a] -> [b]
map (Located Name -> LIEWrappedName Name
forall name. HasOccName name => Located name -> LIEWrappedName name
to_ie_post_rn_cname (Located Name -> LIEWrappedName Name)
-> (Name -> Located Name) -> Name -> LIEWrappedName Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Located Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc) ((Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
n) [Name]
ns))
((FieldLabel -> Located FieldLabel)
-> [FieldLabel] -> [Located FieldLabel]
forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> Located FieldLabel
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc [FieldLabel]
fs)]
where
fld_lbls :: [FastString]
fld_lbls = (FieldLabel -> FastString) -> [FieldLabel] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> FastString
forall a. FieldLbl a -> FastString
flLabel [FieldLabel]
fs
all_used :: ([Name], [FieldLabel]) -> Bool
all_used ([Name]
avail_occs, [FieldLabel]
avail_flds)
= (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
ns) [Name]
avail_occs
Bool -> Bool -> Bool
&& (FieldLabel -> Bool) -> [FieldLabel] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((FastString -> [FastString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FastString]
fld_lbls) (FastString -> Bool)
-> (FieldLabel -> FastString) -> FieldLabel -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldLabel -> FastString
forall a. FieldLbl a -> FastString
flLabel) [FieldLabel]
avail_flds
all_non_overloaded :: [FieldLbl a] -> Bool
all_non_overloaded = Bool -> Bool
not (Bool -> Bool) -> ([FieldLbl a] -> Bool) -> [FieldLbl a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldLbl a -> Bool) -> [FieldLbl a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any FieldLbl a -> Bool
forall a. FieldLbl a -> Bool
flIsOverloaded
to_ie_post_rn_name :: Located name -> LIEWrappedName name
to_ie_post_rn_name :: Located name -> LIEWrappedName name
to_ie_post_rn_name (L SrcSpan
l name
n) = SrcSpan -> IEWrappedName name -> LIEWrappedName name
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (Located name -> IEWrappedName name
forall name. Located name -> IEWrappedName name
IEName (SrcSpan -> name -> Located name
forall l e. l -> e -> GenLocated l e
L SrcSpan
l name
n))
to_ie_post_rn_var :: (HasOccName name) => Located name -> LIEWrappedName name
to_ie_post_rn_var :: Located name -> LIEWrappedName name
to_ie_post_rn_var (L SrcSpan
l name
n)
| OccName -> Bool
isDataOcc (OccName -> Bool) -> OccName -> Bool
forall a b. (a -> b) -> a -> b
$ name -> OccName
forall name. HasOccName name => name -> OccName
occName name
n = SrcSpan -> IEWrappedName name -> LIEWrappedName name
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (Located name -> IEWrappedName name
forall name. Located name -> IEWrappedName name
IEPattern (SrcSpan -> name -> Located name
forall l e. l -> e -> GenLocated l e
L SrcSpan
l name
n))
| Bool
otherwise = SrcSpan -> IEWrappedName name -> LIEWrappedName name
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (Located name -> IEWrappedName name
forall name. Located name -> IEWrappedName name
IEName (SrcSpan -> name -> Located name
forall l e. l -> e -> GenLocated l e
L SrcSpan
l name
n))
to_ie_post_rn_varn :: (HasOccName name) => Located name -> LIEWrappedName name
to_ie_post_rn_varn :: Located name -> LIEWrappedName name
to_ie_post_rn_varn (L SrcSpan
l name
n)
| OccName -> Bool
isTcOcc (OccName -> Bool) -> OccName -> Bool
forall a b. (a -> b) -> a -> b
$ name -> OccName
forall name. HasOccName name => name -> OccName
occName name
n = SrcSpan -> IEWrappedName name -> LIEWrappedName name
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (Located name -> IEWrappedName name
forall name. Located name -> IEWrappedName name
IEType (SrcSpan -> name -> Located name
forall l e. l -> e -> GenLocated l e
L SrcSpan
l name
n))
| Bool
otherwise = SrcSpan -> IEWrappedName name -> LIEWrappedName name
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (Located name -> IEWrappedName name
forall name. Located name -> IEWrappedName name
IEName (SrcSpan -> name -> Located name
forall l e. l -> e -> GenLocated l e
L SrcSpan
l name
n))
to_ie_post_rn_cname :: (HasOccName name) => Located name -> LIEWrappedName name
to_ie_post_rn_cname :: Located name -> LIEWrappedName name
to_ie_post_rn_cname (L SrcSpan
l name
n)
| OccName -> Bool
isTcOcc (OccName -> Bool) -> OccName -> Bool
forall a b. (a -> b) -> a -> b
$ name -> OccName
forall name. HasOccName name => name -> OccName
occName name
n = SrcSpan -> IEWrappedName name -> LIEWrappedName name
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (Located name -> IEWrappedName name
forall name. Located name -> IEWrappedName name
IEType (SrcSpan -> name -> Located name
forall l e. l -> e -> GenLocated l e
L SrcSpan
l name
n))
| Bool
otherwise = SrcSpan -> IEWrappedName name -> LIEWrappedName name
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (Located name -> IEWrappedName name
forall name. Located name -> IEWrappedName name
IEName (SrcSpan -> name -> Located name
forall l e. l -> e -> GenLocated l e
L SrcSpan
l name
n))