{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE UndecidableInstances #-}
module Language.Haskell.Tools.AST.SemaInfoClasses
(module Language.Haskell.Tools.AST.SemaInfoClasses, getInstances, UsageSpec(..)) where
import GHC
import Id as GHC (Id, idName)
import Control.Reference
import Language.Haskell.Tools.AST.Ann as AST
import Language.Haskell.Tools.AST.Representation.Exprs as AST (UFieldWildcard, UExpr)
import Language.Haskell.Tools.AST.Representation.Modules as AST (UImportDecl, UModule)
import Language.Haskell.Tools.AST.Representation.Names as AST (UName(..), UQualifiedName)
import Language.Haskell.Tools.AST.Representation.Literals as AST (ULiteral)
import Language.Haskell.Tools.AST.SemaInfoTypes as AST
semanticsLitType :: Ann ULiteral IdDom st -> GHC.Type
semanticsLitType lit = lit ^. annotation & semanticInfo & literalType
type HasNameInfo dom = (Domain dom, HasNameInfo' (SemanticInfo dom UQualifiedName))
class HasNameInfo' si where
semanticsName :: si -> Maybe GHC.Name
instance HasNameInfo' (NameInfo GhcRn) where
semanticsName = (^? nameInfo)
instance HasNameInfo' CNameInfo where
semanticsName = fmap idName . (^? cnameInfo)
instance HasNameInfo dom => HasNameInfo' (Ann UQualifiedName dom st) where
semanticsName = semanticsName . (^. annotation&semanticInfo)
instance HasNameInfo dom => HasNameInfo' (Ann UName dom st) where
semanticsName = semanticsName . _simpleName . _element
type HasLiteralInfo dom = (Domain dom, HasLiteralInfo' (SemanticInfo dom ULiteral))
class HasLiteralInfo' si where
semanticsLiteralType :: si -> GHC.Type
instance HasLiteralInfo' LiteralInfo where
semanticsLiteralType = (^. literalType)
instance HasLiteralInfo dom => HasLiteralInfo' (Ann ULiteral dom st) where
semanticsLiteralType = semanticsLiteralType . (^. annotation&semanticInfo)
type HasIdInfo dom = (Domain dom, HasIdInfo' (SemanticInfo dom UQualifiedName))
class HasNameInfo' si => HasIdInfo' si where
semanticsId :: si -> Id
instance HasIdInfo' CNameInfo where
semanticsId = (^. cnameInfo)
instance HasIdInfo dom => HasIdInfo' (Ann UQualifiedName dom st) where
semanticsId = semanticsId . (^. annotation&semanticInfo)
instance HasIdInfo dom => HasIdInfo' (Ann UName dom st) where
semanticsId = semanticsId . _simpleName . _element
type HasFixityInfo dom = (Domain dom, HasFixityInfo' (SemanticInfo dom UQualifiedName))
class HasFixityInfo' si where
semanticsFixity :: si -> Maybe GHC.Fixity
instance HasFixityInfo' CNameInfo where
semanticsFixity = (^. cnameFixity)
instance HasFixityInfo dom => HasFixityInfo' (Ann UQualifiedName dom st) where
semanticsFixity = semanticsFixity . (^. annotation&semanticInfo)
type HasScopeInfo dom = (Domain dom, HasScopeInfo' (SemanticInfo dom UQualifiedName), HasScopeInfo' (SemanticInfo dom UExpr))
class HasScopeInfo' si where
semanticsScope :: si -> Scope
instance HasScopeInfo' (NameInfo n) where
semanticsScope = (^. nameScopedLocals)
instance HasScopeInfo' CNameInfo where
semanticsScope = (^. cnameScopedLocals)
instance HasScopeInfo' ScopeInfo where
semanticsScope = (^. exprScopedLocals)
instance HasScopeInfo dom => HasScopeInfo' (Ann UExpr dom st) where
semanticsScope = semanticsScope . (^. annotation&semanticInfo)
instance HasScopeInfo dom => HasScopeInfo' (Ann UQualifiedName dom st) where
semanticsScope = semanticsScope . (^. annotation&semanticInfo)
type HasDefiningInfo dom = (Domain dom, HasDefiningInfo' (SemanticInfo dom UQualifiedName))
class HasDefiningInfo' si where
semanticsDefining :: si -> Bool
instance HasDefiningInfo' (NameInfo n) where
semanticsDefining = (^. nameIsDefined)
instance HasDefiningInfo' CNameInfo where
semanticsDefining = (^. cnameIsDefined)
instance HasDefiningInfo dom => HasDefiningInfo' (Ann UQualifiedName dom st) where
semanticsDefining = semanticsDefining . (^. annotation&semanticInfo)
class HasSourceInfoInSema' si where
semanticsSourceInfo :: si -> Maybe SrcSpan
instance HasSourceInfoInSema' (NameInfo n) where
semanticsSourceInfo = (^? nameLocation)
type HasModuleInfo dom = (Domain dom, HasModuleInfo' (SemanticInfo dom AST.UModule))
class HasModuleInfo' si where
semanticsModule :: si -> GHC.Module
semanticsDynFlags :: si -> GHC.DynFlags
isBootModule :: si -> Bool
semanticsImplicitImports :: si -> [GHC.Name]
semanticsPrelTransMods :: si -> [Module]
instance HasModuleInfo' (AST.ModuleInfo GhcRn) where
semanticsModule = (^. defModuleName)
semanticsDynFlags = (^. defDynFlags)
isBootModule = (^. defIsBootModule)
semanticsImplicitImports = (^? implicitNames&traversal&pName)
semanticsPrelTransMods = (^. prelTransMods)
instance HasModuleInfo' (AST.ModuleInfo GhcTc) where
semanticsModule = (^. defModuleName)
semanticsDynFlags = (^. defDynFlags)
isBootModule = (^. defIsBootModule)
semanticsImplicitImports = map idName . (^? implicitNames&traversal&pName)
semanticsPrelTransMods = (^. prelTransMods)
instance HasModuleInfo dom => HasModuleInfo' (Ann UModule dom st) where
semanticsModule = semanticsModule . (^. annotation&semanticInfo)
semanticsDynFlags = semanticsDynFlags . (^. annotation&semanticInfo)
isBootModule = isBootModule . (^. annotation&semanticInfo)
semanticsImplicitImports = semanticsImplicitImports . (^. annotation&semanticInfo)
semanticsPrelTransMods = semanticsPrelTransMods . (^. annotation&semanticInfo)
type HasImportInfo dom = (Domain dom, HasImportInfo' (SemanticInfo dom AST.UImportDecl))
class HasImportInfo' si where
semanticsImportedModule :: si -> GHC.Module
semanticsAvailable :: si -> [GHC.Name]
semanticsImported :: si -> [GHC.Name]
semanticsTransMods :: si -> [Module]
instance HasImportInfo' (AST.ImportInfo GhcRn) where
semanticsImportedModule = (^. importedModule)
semanticsAvailable = (^. availableNames)
semanticsImported = (^? importedNames&traversal&pName)
semanticsTransMods = (^. importTransMods)
instance HasImportInfo' (AST.ImportInfo GhcTc) where
semanticsImportedModule = (^. importedModule)
semanticsAvailable = map idName . (^. availableNames)
semanticsImported = map idName . (^? importedNames&traversal&pName)
semanticsTransMods = (^. importTransMods)
instance HasImportInfo dom => HasImportInfo' (Ann UImportDecl dom st) where
semanticsImportedModule = semanticsImportedModule . (^. annotation&semanticInfo)
semanticsAvailable = semanticsAvailable . (^. annotation&semanticInfo)
semanticsImported = semanticsImported . (^. annotation&semanticInfo)
semanticsTransMods = semanticsTransMods . (^. annotation&semanticInfo)
type HasImplicitFieldsInfo dom = (Domain dom, HasImplicitFieldsInfo' (SemanticInfo dom AST.UFieldWildcard))
class HasImplicitFieldsInfo' si where
semanticsImplicitFlds :: si -> [(GHC.Name, GHC.Name)]
instance HasImplicitFieldsInfo' ImplicitFieldInfo where
semanticsImplicitFlds = (^. implicitFieldBindings)
instance HasImplicitFieldsInfo dom => HasImplicitFieldsInfo' (Ann UFieldWildcard dom st) where
semanticsImplicitFlds = semanticsImplicitFlds . (^. annotation&semanticInfo)
type HasNoSemanticInfo dom si = SemanticInfo dom si ~ NoSemanticInfo