module Language.Haskell.Names.Open.Base where
import qualified Language.Haskell.Names.GlobalSymbolTable as Global
import qualified Language.Haskell.Names.LocalSymbolTable as Local
import Language.Haskell.Names.SyntaxUtils
import Language.Haskell.Exts.Annotated
import Control.Applicative
import Control.Monad.Identity
import Data.List
import Data.Lens.Common
import Data.Lens.Template
import Data.Generics.Traversable
import Data.Typeable
import GHC.Exts (Constraint)
data NameContext
= BindingT
| BindingV
| ReferenceT
| ReferenceV
| Other
data Scope = Scope
{ _gTable :: Global.Table
, _lTable :: Local.Table
, _nameCtx :: NameContext
}
makeLens ''Scope
initialScope :: Global.Table -> Scope
initialScope tbl = Scope tbl Local.empty Other
newtype Alg w = Alg
{ runAlg :: forall d . Resolvable d => d -> Scope -> w d }
alg :: (?alg :: Alg w, Resolvable d) => d -> Scope -> w d
alg = runAlg ?alg
data ConstraintProxy (p :: * -> Constraint) = ConstraintProxy
defaultRtraverse
:: (GTraversable Resolvable a, Applicative f, ?alg :: Alg f)
=> a -> Scope -> f a
defaultRtraverse a sc =
let ?c = ConstraintProxy :: ConstraintProxy Resolvable
in gtraverse (\a -> alg a sc) a
class Typeable a => Resolvable a where
rtraverse
:: (Applicative f, ?alg :: Alg f)
=> a -> Scope -> f a
instance (Typeable a, GTraversable Resolvable a) => Resolvable a where
rtraverse = defaultRtraverse
rmap
:: Resolvable a
=> (forall b. Resolvable b => Scope -> b -> b)
-> Scope -> a -> a
rmap f sc =
let ?alg = Alg $ \a sc -> Identity (f sc a)
in runIdentity . flip rtraverse sc
intro :: (SrcInfo l, GetBound a l) => a -> Scope -> Scope
intro node =
modL lTable $
\tbl -> foldl' (flip Local.addValue) tbl $ getBound node
setNameCtx :: NameContext -> Scope -> Scope
setNameCtx ctx = setL nameCtx ctx
binderV :: Scope -> Scope
binderV = setNameCtx BindingV
binderT :: Scope -> Scope
binderT = setNameCtx BindingT
exprV :: Scope -> Scope
exprV = setNameCtx ReferenceV
exprT :: Scope -> Scope
exprT = setNameCtx ReferenceT