module Language.Haskell.Names.Annotated
( Scoped(..)
, NameInfo(..)
, annotate
) where
import Language.Haskell.Names.Types
import Language.Haskell.Names.Open.Base
import Language.Haskell.Names.Open.Instances ()
import qualified Language.Haskell.Names.GlobalSymbolTable as Global
import qualified Language.Haskell.Names.LocalSymbolTable as Local
import Language.Haskell.Exts.Annotated
import Data.Proxy
import Data.Lens.Common
import Data.Typeable
import Control.Applicative
import Type.Eq
annotate
:: forall a l .
(Resolvable (a (Scoped l)), Functor a, Typeable l)
=> Scope -> a l -> a (Scoped l)
annotate sc = annotateRec (Proxy :: Proxy l) sc . fmap (Scoped None)
annotateRec
:: forall a l .
(Typeable l, Resolvable a)
=> Proxy l -> Scope -> a -> a
annotateRec _ sc a = go sc a where
go :: forall a . Resolvable a => Scope -> a -> a
go sc a
| ReferenceV <- getL nameCtx sc
, Just (Eq :: QName (Scoped l) :~: a) <- dynamicEq
= lookupValue (fmap sLoc a) sc <$ a
| ReferenceT <- getL nameCtx sc
, Just (Eq :: QName (Scoped l) :~: a) <- dynamicEq
= lookupType (fmap sLoc a) sc <$ a
| BindingV <- getL nameCtx sc
, Just (Eq :: Name (Scoped l) :~: a) <- dynamicEq
= Scoped ValueBinder (sLoc . ann $ a) <$ a
| BindingT <- getL nameCtx sc
, Just (Eq :: Name (Scoped l) :~: a) <- dynamicEq
= Scoped TypeBinder (sLoc . ann $ a) <$ a
| otherwise
= rmap go sc a
lookupValue :: QName l -> Scope -> Scoped l
lookupValue qn sc = Scoped nameInfo (ann qn)
where
nameInfo =
case Local.lookupValue qn $ getL lTable sc of
Right r -> LocalValue r
_ ->
case Global.lookupValue qn $ getL gTable sc of
Global.Result r -> GlobalValue r
Global.Error e -> ScopeError e
Global.Special -> None
lookupType :: QName l -> Scope -> Scoped l
lookupType qn sc = Scoped nameInfo (ann qn)
where
nameInfo =
case Global.lookupType qn $ getL gTable sc of
Global.Result r -> GlobalType r
Global.Error e -> ScopeError e
Global.Special -> None