module Language.Haskell.Names.ScopeUtils where
import Control.Arrow
import Data.Monoid
import Language.Haskell.Names.Types
import Language.Haskell.Names.SyntaxUtils
import Language.Haskell.Exts
import qualified Language.Haskell.Names.GlobalSymbolTable as Global
import Control.Monad (guard)
import Data.List (nub)
scopeError :: Functor f => Error l -> f l -> f (Scoped l)
scopeError e f = Scoped (ScopeError e) <$> f
none :: l -> Scoped l
none = Scoped None
noScope :: (Annotated a) => a l -> a (Scoped l)
noScope = fmap none
symbolParent :: Symbol -> Maybe (Name ())
symbolParent (Selector { typeName = n }) = Just n
symbolParent (Constructor { typeName = n }) = Just n
symbolParent (Method { className = n }) = Just n
symbolParent (TypeFam { associate = as }) = as
symbolParent (DataFam { associate = as }) = as
symbolParent (PatternConstructor { patternTypeName = mn}) = mn
symbolParent (PatternSelector { patternTypeName = mn}) = mn
symbolParent _ = Nothing
computeSymbolTable
:: Bool
-> ModuleName ()
-> [Symbol]
-> Global.Table
computeSymbolTable qual modulename symbols =
Global.fromList (qualified <> if qual then [] else unqualified) where
qualified = do
symbol <- symbols
return (Qual ()modulename (symbolName symbol),symbol)
unqualified = do
symbol <- symbols
return (UnQual () (symbolName symbol),symbol)
resolveCName
:: [Symbol]
-> Name ()
-> (CName l -> Error l)
-> CName l
-> (CName (Scoped l), [Symbol])
resolveCName symbols parent notFound cn =
let
vs = nub (do
symbol <- symbols
guard (Global.isValue symbol)
let name = symbolName symbol
guard (dropAnn (unCName cn) == name)
Just p <- return $ symbolParent symbol
guard (p == parent)
return symbol)
in
case vs of
[] -> (scopeError (notFound cn) cn, [])
[symbol] -> (Scoped (GlobalSymbol symbol (UnQual () (dropAnn (unCName cn)))) <$> cn, [symbol])
_ -> (scopeError (EInternal "resolveCName") cn, [])
resolveCNames
:: [Symbol]
-> Name ()
-> (CName l -> Error l)
-> [CName l]
-> ([CName (Scoped l)], [Symbol])
resolveCNames syms orig notFound =
second mconcat . unzip . map (resolveCName syms orig notFound)