{-# 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

-- * Information about names

-- | Domains that have semantic information for names
type HasNameInfo dom = (Domain dom, HasNameInfo' (SemanticInfo dom UQualifiedName))

-- | Infos that may have a name that can be extracted
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

-- | Domains that have semantic information for literals
type HasLiteralInfo dom = (Domain dom, HasLiteralInfo' (SemanticInfo dom ULiteral))

-- | Info of types
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)

-- * Information about typed names

type HasIdInfo dom = (Domain dom, HasIdInfo' (SemanticInfo dom UQualifiedName))

-- | Infos that may have a typed name that can be extracted
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

-- * Fixity information

type HasFixityInfo dom = (Domain dom, HasFixityInfo' (SemanticInfo dom UQualifiedName))

-- | Infos that may have a fixity information
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)

-- * Scope information

type HasScopeInfo dom = (Domain dom, HasScopeInfo' (SemanticInfo dom UQualifiedName), HasScopeInfo' (SemanticInfo dom UExpr))

-- | Infos that contain the names that are available in theirs scope
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)

-- * Information about names being defined

type HasDefiningInfo dom = (Domain dom, HasDefiningInfo' (SemanticInfo dom UQualifiedName))

-- | Infos that store if they were used to define a name
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)

-- * Information about source info in sema

class HasSourceInfoInSema' si where
  semanticsSourceInfo :: si -> Maybe SrcSpan

instance HasSourceInfoInSema' (NameInfo n) where
  semanticsSourceInfo = (^? nameLocation)

-- * Information about modules

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)

-- * Information about imports

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)

-- * Information about implicitly bounded fields

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)

-- * AST elements with no information

type HasNoSemanticInfo dom si = SemanticInfo dom si ~ NoSemanticInfo