module Language.Haskell.Tools.AST.SemaInfoTypes
(
NoSemanticInfo, ScopeInfo, NameInfo, CNameInfo, ModuleInfo, ImportInfo, ImplicitFieldInfo
, Scope, UsageSpec(..)
, exprScopedLocals, nameScopedLocals, nameIsDefined, nameInfo, ambiguousName, nameLocation
, implicitName, cnameScopedLocals, cnameIsDefined, cnameInfo, cnameFixity
, defModuleName, defDynFlags, defIsBootModule, implicitNames, importedModule, availableNames
, importedNames, implicitFieldBindings, importedOrphanInsts, importedFamInsts, prelOrphanInsts
, prelFamInsts
, mkNoSemanticInfo, mkScopeInfo, mkNameInfo, mkAmbiguousNameInfo, mkImplicitNameInfo, mkCNameInfo
, mkModuleInfo, mkImportInfo, mkImplicitFieldInfo
, PName(..), pName, pNameParent
) where
import BasicTypes as GHC
import DynFlags as GHC
import FamInstEnv as GHC
import Id as GHC
import InstEnv as GHC
import Module as GHC
import Name as GHC
import Outputable as GHC
import RdrName as GHC
import SrcLoc as GHC
import Data.Data as Data
import Data.List
import Control.Reference
type Scope = [[(Name, Maybe [UsageSpec], Maybe Name)]]
data UsageSpec = UsageSpec { usageQualified :: Bool
, usageQualifier :: String
, usageAs :: String
}
deriving (Eq, Data)
instance Outputable UsageSpec where
ppr (UsageSpec q useQ asQ)
= GHC.text $ (if q then "qualified " else "") ++ "as "
++ (if useQ == asQ || q then asQ else asQ ++ " or " ++ useQ)
pprPrec _ (UsageSpec q useQ asQ)
= GHC.text $ (if q then "qualified " else "") ++ "as "
++ (if useQ == asQ || q then asQ else asQ ++ " or " ++ useQ)
data NoSemanticInfo = NoSemanticInfo
deriving (Eq, Data)
mkNoSemanticInfo :: NoSemanticInfo
mkNoSemanticInfo = NoSemanticInfo
data ScopeInfo = ScopeInfo { _exprScopedLocals :: Scope
}
deriving (Eq, Data)
mkScopeInfo :: Scope -> ScopeInfo
mkScopeInfo = ScopeInfo
data NameInfo n = NameInfo { _nameScopedLocals :: Scope
, _nameIsDefined :: Bool
, _nameInfo :: n
}
| AmbiguousNameInfo { _nameScopedLocals :: Scope
, _nameIsDefined :: Bool
, _ambiguousName :: RdrName
, _nameLocation :: SrcSpan
}
| ImplicitNameInfo { _nameScopedLocals :: Scope
, _nameIsDefined :: Bool
, _implicitName :: String
, _nameLocation :: SrcSpan
}
deriving (Eq, Data)
mkNameInfo :: Scope -> Bool -> n -> NameInfo n
mkNameInfo = NameInfo
mkAmbiguousNameInfo :: Scope -> Bool -> RdrName -> SrcSpan -> NameInfo n
mkAmbiguousNameInfo = AmbiguousNameInfo
mkImplicitNameInfo :: Scope -> Bool -> String -> SrcSpan -> NameInfo n
mkImplicitNameInfo = ImplicitNameInfo
data CNameInfo = CNameInfo { _cnameScopedLocals :: Scope
, _cnameIsDefined :: Bool
, _cnameInfo :: Id
, _cnameFixity :: Maybe GHC.Fixity
}
deriving (Eq, Data)
mkCNameInfo :: Scope -> Bool -> Id -> Maybe GHC.Fixity -> CNameInfo
mkCNameInfo = CNameInfo
data PName n
= PName { _pName :: n
, _pNameParent :: Maybe n
}
deriving Data
data ModuleInfo n = ModuleInfo { _defModuleName :: GHC.Module
, _defDynFlags :: DynFlags
, _defIsBootModule :: Bool
, _implicitNames :: [PName n]
, _prelOrphanInsts :: [ClsInst]
, _prelFamInsts :: [FamInst]
}
deriving Data
instance Data DynFlags where
gunfold _ _ _ = error "Cannot construct dyn flags"
toConstr _ = dynFlagsCon
dataTypeOf _ = dynFlagsType
dynFlagsType = mkDataType "DynFlags.DynFlags" [dynFlagsCon]
dynFlagsCon = mkConstr dynFlagsType "DynFlags" [] Data.Prefix
mkModuleInfo :: GHC.Module -> DynFlags -> Bool -> [PName n] -> [ClsInst] -> [FamInst] -> ModuleInfo n
mkModuleInfo mod dfs boot !imported !orphan !family = ModuleInfo mod dfs boot imported orphan family
data ImportInfo n = ImportInfo { _importedModule :: GHC.Module
, _availableNames :: [n]
, _importedNames :: [PName n]
, _importedOrphanInsts :: [ClsInst]
, _importedFamInsts :: [FamInst]
}
deriving Data
deriving instance Data FamInst
deriving instance Data FamFlavor
mkImportInfo :: GHC.Module -> [n] -> [PName n] -> [ClsInst] -> [FamInst] -> ImportInfo n
mkImportInfo mod !names !imported !orphan !family = ImportInfo mod names imported orphan family
data ImplicitFieldInfo = ImplicitFieldInfo { _implicitFieldBindings :: [(Name, Name)]
}
deriving (Eq, Data)
mkImplicitFieldInfo :: [(Name, Name)] -> ImplicitFieldInfo
mkImplicitFieldInfo = ImplicitFieldInfo
instance Show ScopeInfo where
show (ScopeInfo locals) = "(ScopeInfo " ++ showSDocUnsafe (ppr locals) ++ ")"
instance Outputable n => Show (NameInfo n) where
show (NameInfo locals defined nameInfo)
= "(NameInfo " ++ showSDocUnsafe (ppr locals) ++ " " ++ show defined ++ " "
++ showSDocUnsafe (ppr nameInfo) ++ ")"
show (AmbiguousNameInfo locals defined nameInfo span)
= "(AmbiguousNameInfo " ++ showSDocUnsafe (ppr locals) ++ " " ++ show defined ++ " "
++ showSDocUnsafe (ppr nameInfo) ++ " " ++ show span ++ ")"
show (ImplicitNameInfo locals defined nameInfo span)
= "(ImplicitNameInfo " ++ showSDocUnsafe (ppr locals) ++ " " ++ show defined ++ " "
++ showSDocUnsafe (ppr nameInfo) ++ " " ++ show span ++ ")"
instance Show CNameInfo where
show (CNameInfo locals defined nameInfo fixity)
= "(CNameInfo " ++ showSDocUnsafe (ppr locals) ++ " " ++ show defined ++ " "
++ showSDocUnsafe (ppr nameInfo) ++ showSDocUnsafe (ppr fixity) ++ ")"
instance Outputable n => Show (PName n) where
show (PName n (Just parent))
= showSDocUnsafe (ppr n) ++ "[in " ++ showSDocUnsafe (ppr parent) ++ "]"
show (PName n Nothing) = showSDocUnsafe (ppr n)
instance Outputable n => Show (ModuleInfo n) where
show (ModuleInfo mod _ isboot imp clsInsts famInsts)
= "(ModuleInfo " ++ showSDocUnsafe (ppr mod) ++ " " ++ show isboot ++ " " ++ show imp ++ " "
++ showSDocUnsafe (ppr clsInsts) ++ " " ++ showSDocUnsafe (ppr famInsts) ++ ")"
instance Outputable n => Show (ImportInfo n) where
show (ImportInfo mod avail imported clsInsts famInsts)
= "(ImportInfo " ++ showSDocUnsafe (ppr mod) ++ " " ++ showSDocUnsafe (ppr avail) ++ " "
++ show imported ++ " " ++ showSDocUnsafe (ppr clsInsts) ++ " "
++ showSDocUnsafe (ppr famInsts) ++ ")"
instance Show ImplicitFieldInfo where
show (ImplicitFieldInfo bnds)
= "(ImplicitFieldInfo [" ++ concat (intersperse "," (map showImplicitFld bnds)) ++ "])"
where showImplicitFld (from, to) = showSDocUnsafe (ppr from) ++ "->" ++ showSDocUnsafe (ppr to)
instance Show NoSemanticInfo where
show NoSemanticInfo = "NoSemanticInfo"
makeReferences ''PName
makeReferences ''NoSemanticInfo
makeReferences ''ScopeInfo
makeReferences ''NameInfo
makeReferences ''CNameInfo
makeReferences ''ModuleInfo
makeReferences ''ImportInfo
makeReferences ''ImplicitFieldInfo
instance Functor NameInfo where
fmap f = nameInfo .- f
instance Functor PName where
fmap f (PName n p) = PName (f n) (fmap f p)
instance Functor ModuleInfo where
fmap f = implicitNames .- fmap (fmap f)
instance Functor ImportInfo where
fmap f (ImportInfo mod avail imps clsInsts famInsts)
= ImportInfo mod (fmap f avail) (fmap (fmap f) imps) clsInsts famInsts
instance Foldable NameInfo where
foldMap f si = maybe mempty f (si ^? nameInfo)
instance Foldable ModuleInfo where
foldMap f si = foldMap (foldMap f) (si ^. implicitNames)
instance Foldable ImportInfo where
foldMap f si = foldMap f (((si ^. availableNames)
++ (si ^? importedNames & traversal & (pName &+& pNameParent & just) )))
instance Foldable PName where
foldMap f (PName n p) = f n `mappend` foldMap f p
instance Traversable PName where
traverse f (PName n p) = PName <$> f n <*> traverse f p
instance Traversable NameInfo where
traverse f (NameInfo locals defined nameInfo) = NameInfo locals defined <$> f nameInfo
traverse _ (AmbiguousNameInfo locals defined nameInfo span)
= pure $ AmbiguousNameInfo locals defined nameInfo span
traverse _ (ImplicitNameInfo locals defined nameInfo span)
= pure $ ImplicitNameInfo locals defined nameInfo span
instance Traversable ModuleInfo where
traverse f (ModuleInfo mod dfs isboot imp clsInsts famInsts)
= ModuleInfo mod dfs isboot <$> traverse (traverse f) imp <*> pure clsInsts <*> pure famInsts
instance Traversable ImportInfo where
traverse f (ImportInfo mod avail imps clsInsts famInsts)
= ImportInfo mod <$> traverse f avail <*> traverse (traverse f) imps <*> pure clsInsts
<*> pure famInsts