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

import           Fay.Compiler.Prelude
import qualified Language.Haskell.Names.GlobalSymbolTable as Global
import qualified Language.Haskell.Names.LocalSymbolTable  as Local
import           Language.Haskell.Names.Open.Base
import           Language.Haskell.Names.Open.Instances    ()
import           Language.Haskell.Names.RecordWildcards
import           Language.Haskell.Names.Types

import           Data.Lens.Light
import           Data.Proxy
import           Language.Haskell.Exts
import           Data.Typeable ( eqT, (:~:)(Refl) )

annotate
  :: forall a l .
     (Resolvable (a (Scoped l)), Functor a, Typeable l)
  => Scope -> a l -> a (Scoped l)
annotate :: Scope -> a l -> a (Scoped l)
annotate 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 (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 :: 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 :: Scope -> a -> a
go Scope
sc a
a
    | NameContext
ReferenceV <- Lens Scope NameContext -> Scope -> NameContext
forall a b. Lens a b -> a -> b
getL Lens Scope NameContext
nameCtx Scope
sc
    , 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
lookupValue ((Scoped l -> l) -> QName (Scoped l) -> QName l
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 (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ a
QName (Scoped l)
a
    | NameContext
ReferenceT <- Lens Scope NameContext -> Scope -> NameContext
forall a b. Lens a b -> a -> b
getL Lens Scope NameContext
nameCtx Scope
sc
    , 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
lookupType ((Scoped l -> l) -> QName (Scoped l) -> QName l
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 (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ a
QName (Scoped l)
a
    | NameContext
BindingV <- Lens Scope NameContext -> Scope -> NameContext
forall a b. Lens a b -> a -> b
getL Lens Scope NameContext
nameCtx Scope
sc
    , 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
      = NameInfo l -> l -> Scoped l
forall l. NameInfo l -> l -> Scoped l
Scoped NameInfo l
forall l. NameInfo l
ValueBinder (Scoped l -> l
forall l. Scoped l -> l
sLoc (Scoped l -> l)
-> (Name (Scoped l) -> Scoped l) -> Name (Scoped l) -> l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name (Scoped l) -> Scoped l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann (Name (Scoped l) -> l) -> Name (Scoped l) -> l
forall a b. (a -> b) -> a -> b
$ a
Name (Scoped l)
a) Scoped l -> Name (Scoped l) -> Name (Scoped l)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ a
Name (Scoped l)
a
    | NameContext
BindingT <- Lens Scope NameContext -> Scope -> NameContext
forall a b. Lens a b -> a -> b
getL Lens Scope NameContext
nameCtx Scope
sc
    , 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
      = NameInfo l -> l -> Scoped l
forall l. NameInfo l -> l -> Scoped l
Scoped NameInfo l
forall l. NameInfo l
TypeBinder (Scoped l -> l
forall l. Scoped l -> l
sLoc (Scoped l -> l)
-> (Name (Scoped l) -> Scoped l) -> Name (Scoped l) -> l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name (Scoped l) -> Scoped l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann (Name (Scoped l) -> l) -> Name (Scoped l) -> l
forall a b. (a -> b) -> a -> b
$ a
Name (Scoped l)
a) Scoped l -> Name (Scoped l) -> Name (Scoped l)
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
          FieldPun l n -> Scoped l -> QName (Scoped l) -> FieldUpdate (Scoped l)
forall l. l -> QName l -> FieldUpdate l
FieldPun Scoped l
l (QName l -> Scope -> Scoped l
forall l. QName l -> Scope -> Scoped l
lookupValue (Scoped l -> l
forall l. Scoped l -> l
sLoc (Scoped l -> l) -> QName (Scoped l) -> QName l
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName (Scoped l)
n) Scope
sc Scoped l -> QName (Scoped l) -> QName (Scoped l)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ QName (Scoped l)
n)
          FieldWildcard l ->
            let
              namesUnres :: WcNames
namesUnres = Scope
sc Scope -> Lens Scope WcNames -> WcNames
forall b c. b -> Lens b c -> c
^. Lens Scope WcNames
wcNames
              resolve :: Name () -> NameInfo l
resolve Name ()
n =
                let Scoped NameInfo l
info l
_ = QName l -> Scope -> Scoped l
forall l. QName l -> Scope -> Scoped l
lookupValue (Scoped l -> l
forall l. Scoped l -> l
sLoc Scoped l
l l -> QName () -> QName l
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ () -> Name () -> QName ()
forall l. l -> Name l -> QName l
UnQual () Name ()
n) Scope
sc
                in NameInfo l
info
              namesRes :: [(OrigName, NameInfo l)]
namesRes =
                (WcField -> (OrigName, NameInfo l))
-> WcNames -> [(OrigName, NameInfo l)]
forall a b. (a -> b) -> [a] -> [b]
map
                  (\WcField
f -> (WcField -> OrigName
wcFieldOrigName WcField
f, Name () -> NameInfo l
resolve (Name () -> NameInfo l) -> Name () -> NameInfo l
forall a b. (a -> b) -> a -> b
$ WcField -> Name ()
wcFieldName WcField
f))
                  WcNames
namesUnres
            in Scoped l -> FieldUpdate (Scoped l)
forall l. l -> FieldUpdate l
FieldWildcard (Scoped l -> FieldUpdate (Scoped l))
-> Scoped l -> FieldUpdate (Scoped l)
forall a b. (a -> b) -> a -> b
$ NameInfo l -> l -> Scoped l
forall l. NameInfo l -> l -> Scoped l
Scoped ([(OrigName, NameInfo l)] -> NameInfo l
forall l. [(OrigName, NameInfo l)] -> NameInfo l
RecExpWildcard [(OrigName, NameInfo l)]
namesRes) (Scoped l -> l
forall l. Scoped l -> l
sLoc Scoped l
l)
          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 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
    , PFieldWildcard l <- a
a
      = Scoped l -> PatField (Scoped l)
forall l. l -> PatField l
PFieldWildcard (Scoped l -> PatField (Scoped l))
-> Scoped l -> PatField (Scoped l)
forall a b. (a -> b) -> a -> b
$
          NameInfo l -> l -> Scoped l
forall l. NameInfo l -> l -> Scoped l
Scoped
            ([OrigName] -> NameInfo l
forall l. [OrigName] -> NameInfo l
RecPatWildcard ([OrigName] -> NameInfo l) -> [OrigName] -> NameInfo l
forall a b. (a -> b) -> a -> b
$ (WcField -> OrigName) -> WcNames -> [OrigName]
forall a b. (a -> b) -> [a] -> [b]
map WcField -> OrigName
wcFieldOrigName (WcNames -> [OrigName]) -> WcNames -> [OrigName]
forall a b. (a -> b) -> a -> b
$ Scope
sc Scope -> Lens Scope WcNames -> WcNames
forall b c. b -> Lens b c -> c
^. Lens Scope WcNames
wcNames)
            (Scoped l -> l
forall l. Scoped l -> l
sLoc Scoped l
l)
    | 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 forall a. Resolvable a => Scope -> a -> a
go Scope
sc a
a

lookupValue :: QName l -> Scope -> Scoped l
lookupValue :: QName l -> Scope -> Scoped l
lookupValue QName l
qn Scope
sc = NameInfo l -> l -> Scoped l
forall l. NameInfo l -> l -> Scoped l
Scoped NameInfo l
nameInfo (QName l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann QName l
qn)
  where
    nameInfo :: NameInfo l
nameInfo =
      case QName l -> Table -> Either (Error l) SrcLoc
forall l. QName l -> Table -> Either (Error l) SrcLoc
Local.lookupValue QName l
qn (Table -> Either (Error l) SrcLoc)
-> Table -> Either (Error l) SrcLoc
forall a b. (a -> b) -> a -> b
$ Lens Scope Table -> Scope -> Table
forall a b. Lens a b -> a -> b
getL Lens Scope Table
lTable Scope
sc of
        Right SrcLoc
r -> SrcLoc -> NameInfo l
forall l. SrcLoc -> NameInfo l
LocalValue SrcLoc
r
        Either (Error l) SrcLoc
_ ->
          case QName l -> Table -> Result l (SymValueInfo OrigName)
forall l. QName l -> Table -> Result l (SymValueInfo OrigName)
Global.lookupValue QName l
qn (Table -> Result l (SymValueInfo OrigName))
-> Table -> Result l (SymValueInfo OrigName)
forall a b. (a -> b) -> a -> b
$ Lens Scope Table -> Scope -> Table
forall a b. Lens a b -> a -> b
getL Lens Scope Table
gTable Scope
sc of
            Global.Result SymValueInfo OrigName
r -> SymValueInfo OrigName -> NameInfo l
forall l. SymValueInfo OrigName -> NameInfo l
GlobalValue SymValueInfo OrigName
r
            Global.Error Error l
e -> Error l -> NameInfo l
forall l. Error l -> NameInfo l
ScopeError Error l
e
            Result l (SymValueInfo OrigName)
Global.Special -> NameInfo l
forall l. NameInfo l
None

lookupType :: QName l -> Scope -> Scoped l
lookupType :: QName l -> Scope -> Scoped l
lookupType QName l
qn Scope
sc = NameInfo l -> l -> Scoped l
forall l. NameInfo l -> l -> Scoped l
Scoped NameInfo l
nameInfo (QName l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann QName l
qn)
  where
    nameInfo :: NameInfo l
nameInfo =
      case QName l -> Table -> Result l (SymTypeInfo OrigName)
forall l. QName l -> Table -> Result l (SymTypeInfo OrigName)
Global.lookupType QName l
qn (Table -> Result l (SymTypeInfo OrigName))
-> Table -> Result l (SymTypeInfo OrigName)
forall a b. (a -> b) -> a -> b
$ Lens Scope Table -> Scope -> Table
forall a b. Lens a b -> a -> b
getL Lens Scope Table
gTable Scope
sc of
        Global.Result SymTypeInfo OrigName
r -> SymTypeInfo OrigName -> NameInfo l
forall l. SymTypeInfo OrigName -> NameInfo l
GlobalType SymTypeInfo OrigName
r
        Global.Error Error l
e -> Error l -> NameInfo l
forall l. Error l -> NameInfo l
ScopeError Error l
e
        Result l (SymTypeInfo OrigName)
Global.Special -> NameInfo l
forall l. NameInfo l
None