module HsImpExp where
import GhcPrelude
import Module ( ModuleName )
import HsDoc ( HsDocString )
import OccName ( HasOccName(..), isTcOcc, isSymOcc )
import BasicTypes ( SourceText(..), StringLiteral(..), pprWithSourceText )
import FieldLabel ( FieldLbl(..) )
import Outputable
import FastString
import SrcLoc
import HsExtension
import Data.Data
type LImportDecl pass = Located (ImportDecl pass)
data ImportDecl pass
= ImportDecl {
ideclExt :: XCImportDecl pass,
ideclSourceSrc :: SourceText,
ideclName :: Located ModuleName,
ideclPkgQual :: Maybe StringLiteral,
ideclSource :: Bool,
ideclSafe :: Bool,
ideclQualified :: Bool,
ideclImplicit :: Bool,
ideclAs :: Maybe (Located ModuleName),
ideclHiding :: Maybe (Bool, Located [LIE pass])
}
| XImportDecl (XXImportDecl pass)
type instance XCImportDecl (GhcPass _) = NoExt
type instance XXImportDecl (GhcPass _) = NoExt
simpleImportDecl :: ModuleName -> ImportDecl (GhcPass p)
simpleImportDecl mn = ImportDecl {
ideclExt = noExt,
ideclSourceSrc = NoSourceText,
ideclName = noLoc mn,
ideclPkgQual = Nothing,
ideclSource = False,
ideclSafe = False,
ideclImplicit = False,
ideclQualified = False,
ideclAs = Nothing,
ideclHiding = Nothing
}
instance (p ~ GhcPass pass,OutputableBndrId p)
=> Outputable (ImportDecl p) where
ppr (ImportDecl { ideclSourceSrc = mSrcText, ideclName = mod'
, ideclPkgQual = pkg
, ideclSource = from, ideclSafe = safe
, ideclQualified = qual, ideclImplicit = implicit
, ideclAs = as, ideclHiding = spec })
= hang (hsep [text "import", ppr_imp from, pp_implicit implicit, pp_safe safe,
pp_qual qual, pp_pkg pkg, ppr mod', pp_as as])
4 (pp_spec spec)
where
pp_implicit False = empty
pp_implicit True = ptext (sLit ("(implicit)"))
pp_pkg Nothing = empty
pp_pkg (Just (StringLiteral st p))
= pprWithSourceText st (doubleQuotes (ftext p))
pp_qual False = empty
pp_qual True = text "qualified"
pp_safe False = empty
pp_safe True = text "safe"
pp_as Nothing = empty
pp_as (Just a) = text "as" <+> ppr a
ppr_imp True = case mSrcText of
NoSourceText -> text "{-# SOURCE #-}"
SourceText src -> text src <+> text "#-}"
ppr_imp False = empty
pp_spec Nothing = empty
pp_spec (Just (False, (L _ ies))) = ppr_ies ies
pp_spec (Just (True, (L _ ies))) = text "hiding" <+> ppr_ies ies
ppr_ies [] = text "()"
ppr_ies ies = char '(' <+> interpp'SP ies <+> char ')'
ppr (XImportDecl x) = ppr x
data IEWrappedName name
= IEName (Located name)
| IEPattern (Located name)
| IEType (Located name)
deriving (Eq,Data)
type LIEWrappedName name = Located (IEWrappedName name)
type LIE pass = Located (IE pass)
data IE pass
= IEVar (XIEVar pass) (LIEWrappedName (IdP pass))
| IEThingAbs (XIEThingAbs pass) (LIEWrappedName (IdP pass))
| IEThingAll (XIEThingAll pass) (LIEWrappedName (IdP pass))
| IEThingWith (XIEThingWith pass)
(LIEWrappedName (IdP pass))
IEWildcard
[LIEWrappedName (IdP pass)]
[Located (FieldLbl (IdP pass))]
| IEModuleContents (XIEModuleContents pass) (Located ModuleName)
| IEGroup (XIEGroup pass) Int HsDocString
| IEDoc (XIEDoc pass) HsDocString
| IEDocNamed (XIEDocNamed pass) String
| XIE (XXIE pass)
type instance XIEVar (GhcPass _) = NoExt
type instance XIEThingAbs (GhcPass _) = NoExt
type instance XIEThingAll (GhcPass _) = NoExt
type instance XIEThingWith (GhcPass _) = NoExt
type instance XIEModuleContents (GhcPass _) = NoExt
type instance XIEGroup (GhcPass _) = NoExt
type instance XIEDoc (GhcPass _) = NoExt
type instance XIEDocNamed (GhcPass _) = NoExt
type instance XXIE (GhcPass _) = NoExt
data IEWildcard = NoIEWildcard | IEWildcard Int deriving (Eq, Data)
ieName :: IE pass -> IdP pass
ieName (IEVar _ (L _ n)) = ieWrappedName n
ieName (IEThingAbs _ (L _ n)) = ieWrappedName n
ieName (IEThingWith _ (L _ n) _ _ _) = ieWrappedName n
ieName (IEThingAll _ (L _ n)) = ieWrappedName n
ieName _ = panic "ieName failed pattern match!"
ieNames :: IE pass -> [IdP pass]
ieNames (IEVar _ (L _ n) ) = [ieWrappedName n]
ieNames (IEThingAbs _ (L _ n) ) = [ieWrappedName n]
ieNames (IEThingAll _ (L _ n) ) = [ieWrappedName n]
ieNames (IEThingWith _ (L _ n) _ ns _) = ieWrappedName n
: map (ieWrappedName . unLoc) ns
ieNames (IEModuleContents {}) = []
ieNames (IEGroup {}) = []
ieNames (IEDoc {}) = []
ieNames (IEDocNamed {}) = []
ieNames (XIE {}) = panic "ieNames"
ieWrappedName :: IEWrappedName name -> name
ieWrappedName (IEName (L _ n)) = n
ieWrappedName (IEPattern (L _ n)) = n
ieWrappedName (IEType (L _ n)) = n
ieLWrappedName :: LIEWrappedName name -> Located name
ieLWrappedName (L l n) = L l (ieWrappedName n)
replaceWrappedName :: IEWrappedName name1 -> name2 -> IEWrappedName name2
replaceWrappedName (IEName (L l _)) n = IEName (L l n)
replaceWrappedName (IEPattern (L l _)) n = IEPattern (L l n)
replaceWrappedName (IEType (L l _)) n = IEType (L l n)
replaceLWrappedName :: LIEWrappedName name1 -> name2 -> LIEWrappedName name2
replaceLWrappedName (L l n) n' = L l (replaceWrappedName n n')
instance (p ~ GhcPass pass,OutputableBndrId p) => Outputable (IE p) where
ppr (IEVar _ var) = ppr (unLoc var)
ppr (IEThingAbs _ thing) = ppr (unLoc thing)
ppr (IEThingAll _ thing) = hcat [ppr (unLoc thing), text "(..)"]
ppr (IEThingWith _ thing wc withs flds)
= ppr (unLoc thing) <> parens (fsep (punctuate comma
(ppWiths ++
map (ppr . flLabel . unLoc) flds)))
where
ppWiths =
case wc of
NoIEWildcard ->
map (ppr . unLoc) withs
IEWildcard pos ->
let (bs, as) = splitAt pos (map (ppr . unLoc) withs)
in bs ++ [text ".."] ++ as
ppr (IEModuleContents _ mod')
= text "module" <+> ppr mod'
ppr (IEGroup _ n _) = text ("<IEGroup: " ++ show n ++ ">")
ppr (IEDoc _ doc) = ppr doc
ppr (IEDocNamed _ string) = text ("<IEDocNamed: " ++ string ++ ">")
ppr (XIE x) = ppr x
instance (HasOccName name) => HasOccName (IEWrappedName name) where
occName w = occName (ieWrappedName w)
instance (OutputableBndr name) => OutputableBndr (IEWrappedName name) where
pprBndr bs w = pprBndr bs (ieWrappedName w)
pprPrefixOcc w = pprPrefixOcc (ieWrappedName w)
pprInfixOcc w = pprInfixOcc (ieWrappedName w)
instance (OutputableBndr name) => Outputable (IEWrappedName name) where
ppr (IEName n) = pprPrefixOcc (unLoc n)
ppr (IEPattern n) = text "pattern" <+> pprPrefixOcc (unLoc n)
ppr (IEType n) = text "type" <+> pprPrefixOcc (unLoc n)
pprImpExp :: (HasOccName name, OutputableBndr name) => name -> SDoc
pprImpExp name = type_pref <+> pprPrefixOcc name
where
occ = occName name
type_pref | isTcOcc occ && isSymOcc occ = text "type"
| otherwise = empty