content: {-# OPTIONS -fno-warn-name-shadowing #-}
  module Language.Haskell.Names.ScopeUtils
    ( computeSymbolTable
    , noScope
    , none
    , resolveCNames
    , scopeError
    , sv_parent
    ) where
  
  import           Fay.Compiler.Prelude
  import qualified Language.Haskell.Names.GlobalSymbolTable as Global
  import           Language.Haskell.Names.SyntaxUtils
  import           Language.Haskell.Names.Types
  
  import           Data.Lens.Light
  import qualified Data.Set                                 as Set
  import           Language.Haskell.Exts
  
  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
  
  sv_parent :: SymValueInfo n -> Maybe n
  sv_parent (SymSelector { sv_typeName = n }) = Just n
  sv_parent (SymConstructor { sv_typeName = n }) = Just n
  sv_parent (SymMethod { sv_className = n }) = Just n
  sv_parent _ = Nothing
  
  computeSymbolTable
    :: Bool
      -- ^ If 'True' (\"qualified\"), then only the qualified names are
      -- inserted.
      --
      -- If 'False', then both qualified and unqualified names are insterted.
    -> ModuleName l
    -> Symbols
    -> Global.Table
  computeSymbolTable qual (ModuleName _ mod) syms =
    Global.fromLists $
      if qual
        then renamed
        else renamed <> unqualified
    where
      vs = Set.toList $ syms^.valSyms
      ts = Set.toList $ syms^.tySyms
      renamed = renameSyms mod
      unqualified = renameSyms ""
      renameSyms mod = (map (rename mod) vs, map (rename mod) ts)
      rename :: HasOrigName i => ModuleNameS -> i OrigName -> (GName, i OrigName)
      rename m v = ((origGName . origName $ v) { gModule = m }, v)
  
  resolveCName
    :: Symbols
    -> OrigName
    -> (CName l -> Error l) -- ^ error for "not found" condition
    -> CName l
    -> (CName (Scoped l), Symbols)
  resolveCName syms parent notFound cn =
    let
      vs =
        [ info
        | info <- Set.toList $ syms^.valSyms
        , let name = gName . origGName $ sv_origName info
        , nameToString (unCName cn) == name
        , Just p <- return $ sv_parent info
        , p == parent
        ]
    in
      case vs of
        [] -> (scopeError (notFound cn) cn, mempty)
        [i] -> (Scoped (GlobalValue i) <$> cn, mkVal i)
        _ -> (scopeError (EInternal "resolveCName") cn, mempty)
  
  resolveCNames
    :: Symbols
    -> OrigName
    -> (CName l -> Error l) -- ^ error for "not found" condition
    -> [CName l]
    -> ([CName (Scoped l)], Symbols)
  resolveCNames syms orig notFound =
    second mconcat . unzip . map (resolveCName syms orig notFound)
  