ScopeUtils.hs

module Language.Haskell.Names.ScopeUtils where

import Control.Applicative
import Control.Arrow
import Data.Monoid
import Language.Haskell.Names.Types
import Language.Haskell.Names.SyntaxUtils
import Language.Haskell.Exts
import Language.Haskell.Exts.Annotated.Simplify (sName)
import qualified Language.Haskell.Exts.Annotated as Ann
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 :: (Ann.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 _ = Nothing

computeSymbolTable
  :: Bool
    -- ^ If 'True' (\"qualified\"), then only the qualified names are
    -- inserted.
    --
    -- If 'False', then both qualified and unqualified names are insterted.
  -> 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)

-- | Find a single constructor or method name in a list of symbols
resolveCName
  :: [Symbol]
  -> Name
  -> (Ann.CName l -> Error l) -- ^ error for "not found" condition
  -> Ann.CName l
  -> (Ann.CName (Scoped l), [Symbol])
resolveCName symbols parent notFound cn =
  let
    vs = nub (do
        symbol <- symbols
        guard (Global.isValue symbol)
        let name = symbolName symbol
        guard (sName (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 (sName (unCName cn)))) <$> cn, [symbol])
      _ -> (scopeError (EInternal "resolveCName") cn, [])

-- | Find a list of constructor or method names in a list of symbols.
resolveCNames
  :: [Symbol]
  -> Name
  -> (Ann.CName l -> Error l) -- ^ error for "not found" condition
  -> [Ann.CName l]
  -> ([Ann.CName (Scoped l)], [Symbol])
resolveCNames syms orig notFound =
  second mconcat . unzip . map (resolveCName syms orig notFound)