-- This module uses the open recursion interface
-- ("Language.Haskell.Names.Open") to annotate the AST with binding
-- information.
{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, ImplicitParams,
    UndecidableInstances, ScopedTypeVariables,
    TypeOperators, GADTs #-}
module Language.Haskell.Names.Annotated
  ( Scoped(..)
  , NameInfo(..)
  , annotateDecl
  ) where


import Language.Haskell.Names.Types
import Language.Haskell.Names.RecordWildcards
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.Names.SyntaxUtils (
  dropAnn, setAnn, nameQualification, qNameToName)
import Language.Haskell.Exts
import Data.Proxy
import Data.Lens.Light
import Data.Typeable (
  Typeable, (:~:)(Refl), eqT)


annotateDecl
  :: forall a l .
     (Resolvable (a (Scoped l)), Functor a, Typeable l)
  => Scope -> a l -> a (Scoped l)
annotateDecl :: forall (a :: * -> *) l.
(Resolvable (a (Scoped l)), Functor a, Typeable l) =>
Scope -> a l -> a (Scoped l)
annotateDecl Scope
sc = Proxy l -> Scope -> a (Scoped l) -> a (Scoped l)
forall a l.
(Typeable l, Resolvable a) =>
Proxy l -> Scope -> a -> a
annotateRec (Proxy l
forall {k} (t :: k). Proxy t
Proxy :: Proxy l) Scope
sc (a (Scoped l) -> a (Scoped l))
-> (a l -> a (Scoped l)) -> a l -> a (Scoped l)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (l -> Scoped l) -> a l -> a (Scoped l)
forall a b. (a -> b) -> a a -> a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (NameInfo l -> l -> Scoped l
forall l. NameInfo l -> l -> Scoped l
Scoped NameInfo l
forall l. NameInfo l
None)

annotateRec
  :: forall a l .
     (Typeable l, Resolvable a)
  => Proxy l -> Scope -> a -> a
annotateRec :: forall a l.
(Typeable l, Resolvable a) =>
Proxy l -> Scope -> a -> a
annotateRec Proxy l
_ Scope
sc a
a = Scope -> a -> a
forall a. Resolvable a => Scope -> a -> a
go Scope
sc a
a where
  go :: forall a . Resolvable a => Scope -> a -> a
  go :: forall a. Resolvable a => Scope -> a -> a
go Scope
sc a
a
    | Just (QName (Scoped l) :~: a
Refl :: QName (Scoped l) :~: a) <- Maybe (QName (Scoped l) :~: a)
forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT
      = QName l -> Scope -> Scoped l
forall l. QName l -> Scope -> Scoped l
lookupQName ((Scoped l -> l) -> QName (Scoped l) -> QName l
forall a b. (a -> b) -> QName a -> QName b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Scoped l -> l
forall l. Scoped l -> l
sLoc a
QName (Scoped l)
a) Scope
sc Scoped l -> QName (Scoped l) -> QName (Scoped l)
forall a b. a -> QName b -> QName a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ a
QName (Scoped l)
a
    | Just (Name (Scoped l) :~: a
Refl :: Name (Scoped l) :~: a) <- Maybe (Name (Scoped l) :~: a)
forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT
      = Name l -> Scope -> Scoped l
forall l. Name l -> Scope -> Scoped l
lookupName ((Scoped l -> l) -> Name (Scoped l) -> Name l
forall a b. (a -> b) -> Name a -> Name b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Scoped l -> l
forall l. Scoped l -> l
sLoc a
Name (Scoped l)
a) Scope
sc Scoped l -> Name (Scoped l) -> Name (Scoped l)
forall a b. a -> Name b -> Name a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ a
Name (Scoped l)
a
    | Just (FieldUpdate (Scoped l) :~: a
Refl :: FieldUpdate (Scoped l) :~: a) <- Maybe (FieldUpdate (Scoped l) :~: a)
forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT
      = case a
a of
          FieldWildcard Scoped l
l ->
            Scoped l -> FieldUpdate (Scoped l)
forall l. l -> FieldUpdate l
FieldWildcard (NameInfo l -> l -> Scoped l
forall l. NameInfo l -> l -> Scoped l
Scoped ([(Symbol, NameInfo l)] -> NameInfo l
forall l. [(Symbol, NameInfo l)] -> NameInfo l
RecExpWildcard [(Symbol, NameInfo l)]
namesRes) (Scoped l -> l
forall l. Scoped l -> l
sLoc Scoped l
l)) where
              namesRes :: [(Symbol, NameInfo l)]
namesRes = do
                WcField
f <- Scope
sc Scope -> Lens Scope [WcField] -> [WcField]
forall b c. b -> Lens b c -> c
^. Lens Scope [WcField]
wcNames
                let localQName :: QName l
localQName = Maybe (ModuleName ()) -> Name l -> QName l
forall l. Maybe (ModuleName ()) -> Name l -> QName l
qualifyName Maybe (ModuleName ())
forall a. Maybe a
Nothing (l -> Name () -> Name l
forall (a :: * -> *) l' l. Functor a => l' -> a l -> a l'
setAnn (Scoped l -> l
forall l. Scoped l -> l
sLoc Scoped l
l) (WcField -> Name ()
wcFieldName WcField
f))
                    symbol :: Symbol
symbol = WcField -> Symbol
wcFieldSymbol WcField
f
                Scoped NameInfo l
info l
_ <- Scoped l -> [Scoped l]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (QName l -> Scope -> Scoped l
forall l. QName l -> Scope -> Scoped l
lookupQName QName l
localQName Scope
sc)
                (Symbol, NameInfo l) -> [(Symbol, NameInfo l)]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Symbol
symbol, NameInfo l
info)
          a
_ -> (forall a. Resolvable a => Scope -> a -> a) -> Scope -> a -> a
forall a.
Resolvable a =>
(forall a. Resolvable a => Scope -> a -> a) -> Scope -> a -> a
rmap Scope -> b -> b
forall a. Resolvable a => Scope -> a -> a
go Scope
sc a
a
    | Just (PatField (Scoped l) :~: a
Refl :: PatField (Scoped l) :~: a) <- Maybe (PatField (Scoped l) :~: a)
forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT
      = case a
a of
          PFieldWildcard Scoped l
l ->
            Scoped l -> PatField (Scoped l)
forall l. l -> PatField l
PFieldWildcard (NameInfo l -> l -> Scoped l
forall l. NameInfo l -> l -> Scoped l
Scoped ([Symbol] -> NameInfo l
forall l. [Symbol] -> NameInfo l
RecPatWildcard [Symbol]
namesRes) (Scoped l -> l
forall l. Scoped l -> l
sLoc Scoped l
l)) where
              namesRes :: [Symbol]
namesRes = do
                WcField
f <- Scope
sc Scope -> Lens Scope [WcField] -> [WcField]
forall b c. b -> Lens b c -> c
^. Lens Scope [WcField]
wcNames
                let symbol :: Symbol
symbol = WcField -> Symbol
wcFieldSymbol WcField
f
                Symbol -> [Symbol]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return Symbol
symbol
          a
_ -> (forall a. Resolvable a => Scope -> a -> a) -> Scope -> a -> a
forall a.
Resolvable a =>
(forall a. Resolvable a => Scope -> a -> a) -> Scope -> a -> a
rmap Scope -> b -> b
forall a. Resolvable a => Scope -> a -> a
go Scope
sc a
a
    | Bool
otherwise
      = (forall a. Resolvable a => Scope -> a -> a) -> Scope -> a -> a
forall a.
Resolvable a =>
(forall a. Resolvable a => Scope -> a -> a) -> Scope -> a -> a
rmap Scope -> b -> b
forall a. Resolvable a => Scope -> a -> a
go Scope
sc a
a


lookupQName :: QName l -> Scope -> Scoped l
lookupQName :: forall l. QName l -> Scope -> Scoped l
lookupQName (Special l
l SpecialCon l
_) Scope
_ = NameInfo l -> l -> Scoped l
forall l. NameInfo l -> l -> Scoped l
Scoped NameInfo l
forall l. NameInfo l
None l
l
lookupQName QName l
qname Scope
scope = NameInfo l -> l -> Scoped l
forall l. NameInfo l -> l -> Scoped l
Scoped NameInfo l
nameInfo (QName l -> l
forall l. QName l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann QName l
qname) where

  nameInfo :: NameInfo l
nameInfo = case Lens Scope (Maybe PatSynMode) -> Scope -> Maybe PatSynMode
forall a b. Lens a b -> a -> b
getL Lens Scope (Maybe PatSynMode)
patSynMode Scope
scope of

    Maybe PatSynMode
Nothing -> case Lens Scope NameContext -> Scope -> NameContext
forall a b. Lens a b -> a -> b
getL Lens Scope NameContext
nameCtx Scope
scope of

      NameContext
ReferenceV -> case QName l -> Table -> Either (Error l) SrcLoc
forall l. QName l -> Table -> Either (Error l) SrcLoc
Local.lookupValue QName l
qname (Lens Scope Table -> Scope -> Table
forall a b. Lens a b -> a -> b
getL Lens Scope Table
lTable Scope
scope) of
        Right SrcLoc
srcloc -> SrcLoc -> NameInfo l
forall l. SrcLoc -> NameInfo l
LocalValue SrcLoc
srcloc
        Either (Error l) SrcLoc
_ ->
          [Symbol] -> NameInfo l
checkUniqueness (QName l -> Table -> [Symbol]
forall l. QName l -> Table -> [Symbol]
Global.lookupValue QName l
qname Table
globalTable)

      NameContext
ReferenceT ->
        [Symbol] -> NameInfo l
checkUniqueness (QName l -> Table -> [Symbol]
forall l. QName l -> Table -> [Symbol]
Global.lookupType QName l
qname Table
globalTable)

      NameContext
ReferenceUT ->
        [Symbol] -> NameInfo l
checkUniqueness (QName l -> Table -> [Symbol]
forall l. QName l -> Table -> [Symbol]
Global.lookupMethodOrAssociate QName l
qname' Table
globalTable) where
          qname' :: QName l
qname' = case QName l
qname of
            UnQual l
_ Name l
name -> Maybe (ModuleName ()) -> Name l -> QName l
forall l. Maybe (ModuleName ()) -> Name l -> QName l
qualifyName Maybe (ModuleName ())
maybeQualification Name l
name where
              maybeQualification :: Maybe (ModuleName ())
maybeQualification = Maybe (ModuleName ())
-> (QName () -> Maybe (ModuleName ()))
-> Maybe (QName ())
-> Maybe (ModuleName ())
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe (ModuleName ())
forall a. Maybe a
Nothing QName () -> Maybe (ModuleName ())
forall l. QName l -> Maybe (ModuleName ())
nameQualification (Lens Scope (Maybe (QName ())) -> Scope -> Maybe (QName ())
forall a b. Lens a b -> a -> b
getL Lens Scope (Maybe (QName ()))
instClassName Scope
scope)
            QName l
_ -> QName l
qname

      NameContext
ReferenceRS ->
        [Symbol] -> NameInfo l
checkUniqueness (QName l -> Table -> [Symbol]
forall l. QName l -> Table -> [Symbol]
Global.lookupSelector QName l
qname Table
globalTable)

      NameContext
_ -> NameInfo l
forall l. NameInfo l
None

    Just PatSynMode
PatSynLeftHandSide -> case Lens Scope NameContext -> Scope -> NameContext
forall a b. Lens a b -> a -> b
getL Lens Scope NameContext
nameCtx Scope
scope of

      NameContext
ReferenceV -> NameInfo l
forall l. NameInfo l
ValueBinder

      NameContext
ReferenceRS -> NameInfo l
forall l. NameInfo l
ValueBinder

      NameContext
_ -> NameInfo l
forall l. NameInfo l
None

    Just PatSynMode
PatSynRightHandSide -> case Lens Scope NameContext -> Scope -> NameContext
forall a b. Lens a b -> a -> b
getL Lens Scope NameContext
nameCtx Scope
scope of

      NameContext
ReferenceV -> case QName l -> Table -> Either (Error l) SrcLoc
forall l. QName l -> Table -> Either (Error l) SrcLoc
Local.lookupValue QName l
qname (Lens Scope Table -> Scope -> Table
forall a b. Lens a b -> a -> b
getL Lens Scope Table
lTable Scope
scope) of
        Right SrcLoc
srcloc -> SrcLoc -> NameInfo l
forall l. SrcLoc -> NameInfo l
LocalValue SrcLoc
srcloc
        Either (Error l) SrcLoc
_ -> [Symbol] -> NameInfo l
checkUniqueness (QName l -> Table -> [Symbol]
forall l. QName l -> Table -> [Symbol]
Global.lookupValue QName l
qname Table
globalTable)
      NameContext
ReferenceRS ->
        [Symbol] -> NameInfo l
checkUniqueness (QName l -> Table -> [Symbol]
forall l. QName l -> Table -> [Symbol]
Global.lookupSelector QName l
qname Table
globalTable)

      NameContext
_ -> NameInfo l
forall l. NameInfo l
None


  globalTable :: Table
globalTable = Lens Scope Table -> Scope -> Table
forall a b. Lens a b -> a -> b
getL Lens Scope Table
gTable Scope
scope

  checkUniqueness :: [Symbol] -> NameInfo l
checkUniqueness [Symbol]
symbols = case [Symbol]
symbols of
    [] -> Error l -> NameInfo l
forall l. Error l -> NameInfo l
ScopeError (QName l -> Error l
forall l. QName l -> Error l
ENotInScope QName l
qname)
    [Symbol
symbol] -> Symbol -> QName () -> NameInfo l
forall l. Symbol -> QName () -> NameInfo l
GlobalSymbol Symbol
symbol (QName l -> QName ()
forall (a :: * -> *) l. Functor a => a l -> a ()
dropAnn QName l
qname)
    [Symbol]
_ -> Error l -> NameInfo l
forall l. Error l -> NameInfo l
ScopeError (QName l -> [Symbol] -> Error l
forall l. QName l -> [Symbol] -> Error l
EAmbiguous QName l
qname [Symbol]
symbols)


lookupName :: Name l -> Scope -> Scoped l
lookupName :: forall l. Name l -> Scope -> Scoped l
lookupName Name l
name Scope
scope = NameInfo l -> l -> Scoped l
forall l. NameInfo l -> l -> Scoped l
Scoped NameInfo l
nameInfo (Name l -> l
forall l. Name l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Name l
name) where

  nameInfo :: NameInfo l
nameInfo = case Lens Scope (Maybe PatSynMode) -> Scope -> Maybe PatSynMode
forall a b. Lens a b -> a -> b
getL Lens Scope (Maybe PatSynMode)
patSynMode Scope
scope of

    Maybe PatSynMode
Nothing -> case Lens Scope NameContext -> Scope -> NameContext
forall a b. Lens a b -> a -> b
getL Lens Scope NameContext
nameCtx Scope
scope of

      NameContext
ReferenceUV ->
        Maybe (QName ()) -> QName l -> [Symbol] -> NameInfo l
forall l. Maybe (QName ()) -> QName l -> [Symbol] -> NameInfo l
disambiguateMethod Maybe (QName ())
maybeClassName QName l
qname (QName l -> Table -> [Symbol]
forall l. QName l -> Table -> [Symbol]
Global.lookupMethodOrAssociate QName l
qname Table
globalTable) where
          qname :: QName l
qname = Maybe (ModuleName ()) -> Name l -> QName l
forall l. Maybe (ModuleName ()) -> Name l -> QName l
qualifyName Maybe (ModuleName ())
maybeQualification Name l
name
          maybeQualification :: Maybe (ModuleName ())
maybeQualification = Maybe (ModuleName ())
-> (QName () -> Maybe (ModuleName ()))
-> Maybe (QName ())
-> Maybe (ModuleName ())
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe (ModuleName ())
forall a. Maybe a
Nothing QName () -> Maybe (ModuleName ())
forall l. QName l -> Maybe (ModuleName ())
nameQualification Maybe (QName ())
maybeClassName
          maybeClassName :: Maybe (QName ())
maybeClassName = Lens Scope (Maybe (QName ())) -> Scope -> Maybe (QName ())
forall a b. Lens a b -> a -> b
getL Lens Scope (Maybe (QName ()))
instClassName Scope
scope

      NameContext
SignatureV ->
        QName l -> [Symbol] -> NameInfo l
forall l. QName l -> [Symbol] -> NameInfo l
checkUniqueness QName l
qname (QName l -> Table -> [Symbol]
forall l. QName l -> Table -> [Symbol]
Global.lookupValue QName l
qname Table
globalTable) where
          qname :: QName l
qname = Maybe (ModuleName ()) -> Name l -> QName l
forall l. Maybe (ModuleName ()) -> Name l -> QName l
qualifyName (ModuleName () -> Maybe (ModuleName ())
forall a. a -> Maybe a
Just (Lens Scope (ModuleName ()) -> Scope -> ModuleName ()
forall a b. Lens a b -> a -> b
getL Lens Scope (ModuleName ())
moduName Scope
scope)) Name l
name

      NameContext
BindingV -> NameInfo l
forall l. NameInfo l
ValueBinder

      NameContext
BindingT -> NameInfo l
forall l. NameInfo l
TypeBinder

      NameContext
_ -> NameInfo l
forall l. NameInfo l
None

    Just PatSynMode
PatSynLeftHandSide -> case Lens Scope NameContext -> Scope -> NameContext
forall a b. Lens a b -> a -> b
getL Lens Scope NameContext
nameCtx Scope
scope of

      NameContext
BindingV -> NameInfo l
forall l. NameInfo l
ValueBinder

      NameContext
_ -> NameInfo l
forall l. NameInfo l
None

    Just PatSynMode
PatSynRightHandSide -> case Lens Scope NameContext -> Scope -> NameContext
forall a b. Lens a b -> a -> b
getL Lens Scope NameContext
nameCtx Scope
scope of

      NameContext
BindingV ->
        case QName l -> Table -> Either (Error l) SrcLoc
forall l. QName l -> Table -> Either (Error l) SrcLoc
Local.lookupValue (Maybe (ModuleName ()) -> Name l -> QName l
forall l. Maybe (ModuleName ()) -> Name l -> QName l
qualifyName Maybe (ModuleName ())
forall a. Maybe a
Nothing Name l
name) (Lens Scope Table -> Scope -> Table
forall a b. Lens a b -> a -> b
getL Lens Scope Table
lTable Scope
scope) of
          Right SrcLoc
srcloc -> SrcLoc -> NameInfo l
forall l. SrcLoc -> NameInfo l
LocalValue SrcLoc
srcloc
          Either (Error l) SrcLoc
_ -> NameInfo l
forall l. NameInfo l
None

      NameContext
_ -> NameInfo l
forall l. NameInfo l
None


  globalTable :: Table
globalTable = Lens Scope Table -> Scope -> Table
forall a b. Lens a b -> a -> b
getL Lens Scope Table
gTable Scope
scope


checkUniqueness :: QName l -> [Symbol] -> NameInfo l
checkUniqueness :: forall l. QName l -> [Symbol] -> NameInfo l
checkUniqueness QName l
qname [Symbol]
symbols = case [Symbol]
symbols of
  [] -> Error l -> NameInfo l
forall l. Error l -> NameInfo l
ScopeError (QName l -> Error l
forall l. QName l -> Error l
ENotInScope QName l
qname)
  [Symbol
symbol] -> Symbol -> QName () -> NameInfo l
forall l. Symbol -> QName () -> NameInfo l
GlobalSymbol Symbol
symbol (QName l -> QName ()
forall (a :: * -> *) l. Functor a => a l -> a ()
dropAnn QName l
qname)
  [Symbol]
_ -> Error l -> NameInfo l
forall l. Error l -> NameInfo l
ScopeError (QName l -> [Symbol] -> Error l
forall l. QName l -> [Symbol] -> Error l
EAmbiguous QName l
qname [Symbol]
symbols)


disambiguateMethod :: Maybe (QName ()) -> QName l -> [Symbol] -> NameInfo l
disambiguateMethod :: forall l. Maybe (QName ()) -> QName l -> [Symbol] -> NameInfo l
disambiguateMethod Maybe (QName ())
Nothing QName l
_ [Symbol]
_ = Error l -> NameInfo l
forall l. Error l -> NameInfo l
ScopeError (String -> Error l
forall l. String -> Error l
EInternal String
"method in instance of unknown class")
disambiguateMethod (Just QName ()
instanceClassName) QName l
qname [Symbol]
symbols = QName l -> [Symbol] -> NameInfo l
forall l. QName l -> [Symbol] -> NameInfo l
checkUniqueness QName l
qname [Symbol]
disambiguatedSymbols where
  disambiguatedSymbols :: [Symbol]
disambiguatedSymbols =
    (Symbol -> Bool) -> [Symbol] -> [Symbol]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Symbol
symbol -> Symbol -> Name ()
className Symbol
symbol Name () -> Name () -> Bool
forall a. Eq a => a -> a -> Bool
== QName () -> Name ()
forall l. QName l -> Name l
qNameToName QName ()
instanceClassName) [Symbol]
symbols

qualifyName :: Maybe (ModuleName ()) -> Name l -> QName l
qualifyName :: forall l. Maybe (ModuleName ()) -> Name l -> QName l
qualifyName Maybe (ModuleName ())
Nothing Name l
n = l -> Name l -> QName l
forall l. l -> Name l -> QName l
UnQual (Name l -> l
forall l. Name l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Name l
n) Name l
n
qualifyName (Just (ModuleName () String
moduleName)) Name l
n =
  l -> ModuleName l -> Name l -> QName l
forall l. l -> ModuleName l -> Name l -> QName l
Qual (Name l -> l
forall l. Name l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Name l
n) ModuleName l
annotatedModuleName Name l
n where
    annotatedModuleName :: ModuleName l
annotatedModuleName = l -> String -> ModuleName l
forall l. l -> String -> ModuleName l
ModuleName (Name l -> l
forall l. Name l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Name l
n) String
moduleName