------------------------------------------------------------------
-- |
-- Module      :  IdlScopedName
-- Copyright   :  (c) Dmitry Golubovsky, 2009
-- License     :  BSD-style
-- 
-- Maintainer  :  golubovsky@gmail.com
-- Stability   :  experimental
-- Portability :  portable
-- 
--
--
-- Operations on IDL scoped names.
------------------------------------------------------------------

module IdlScopedName where

import Data.List
import Data.Maybe
import Data.Either
import qualified Data.Map as M
import Control.Monad.RWS
import Text.ParserCombinators.Parsec.Pos
import Language.WebIDL

import IdlGlobal
import IdlUtil
import IdlFQMonad

-- Test if a scoped name is absolute.

abssn (IDLScopedName absn _) = absn

-- Resolve a scoped name per 3.1 of WebIDL spec. A definition with name exists
-- if it can be looked up in the map of existing definitions by that name. 
-- If a name cannot be resolved, then Nothing is returned.

rsvsnmb :: IDLScopedName -> FQ (Maybe IDLScopedName)

rsvsnmb sn@(IDLScopedName absn scps) = do
  case reverse scps of
    (spc:_) | spc `elem` ["Object", "DOMString"] -> -- these are special internal names: resolve to
      return $ Just $ IDLScopedName False ['@':spc] -- relative scoped names starting with '@'
    [] -> return Nothing                    -- empty name (abnormal situation) does not resolve
                                            -- to a definition.
    _ -> do
      dfd <- gets defdecl
      case absn of                          -- for an absolute name, just check
        True -> do                          -- that a definition exists
          let lk = M.lookup (prtsn sn) dfd
          case lk of
           Just _ -> return (Just sn)
           Nothing -> return Nothing
        False -> do                         -- for each module defined, try to append the name
                                            -- to the module name and lookup, starting with root
           mr <- gets root                  -- root of the scope
           let sc = bldscope mr dfd         -- build the scope w.r.t. inheritance
               lknm = map (++ "::" ++ prtsn sn) sc
               lkfr = fmap (IDLScopedName True . mksn) $ 
                        listToMaybe $ map fst $ filter (isJust . snd) $ 
                        zip lknm (map (flip M.lookup dfd) lknm)
           when (null sc) $ errMsg $ "circular inheritance of " ++ prtsn sn ++ "detected"
           return lkfr

-- Same as above, but if the name does not resolve, return it unchanged.

rsvsn :: IDLScopedName -> FQ IDLScopedName

rsvsn sn = do
  sn' <- rsvsnmb sn
  return $ fromMaybe sn sn'

-- Same as above, but an error message will be generated if not resolved.

rsvsne :: IDLScopedName -> FQ IDLScopedName

rsvsne sn = do
  sn' <- rsvsnmb sn
  case sn' of
    Nothing -> errMsg (prtsn sn ++ "  not declared") >> return sn
    Just sn'' -> return sn''

-- Build a name search scope w.r.t. inheritance. For names declared outside interfaces,
-- the scope is just a sequence of enclosing module names, plus a simple "::". For names
-- declared inside interfaces w/o inheritance, the same plus interface name. For names
-- declared inside interfaces with inheritance, names of parent interfaces are put up front
-- the scope, in order of appearance in the inheritance list, each pulling possibly more
-- names if they have patent interfaces, too. If however a name of an interface is already
-- on the scope, error will be detected as circular inheritance is not permitted.             

bldscope :: [IDLDef] -> M.Map String IDLDef -> [String]

bldscope [] _ = [""]
bldscope r@(m:ms) dm | isInterface m = 
  let isc = inhersc (root2ns r) dm 
  in  if null isc then [] else isc ++ bldscope ms dm
bldscope r@(m:ms) dm = (root2ns r) : bldscope ms dm

--                        r (decls)   w (scope) s (seen)

type IS a = RWS (M.Map String IDLDef) [String] [String] a

inhersc :: String -> M.Map String IDLDef -> [String]

inhersc sn dm = 
  let (a, s, w) = runRWS (ih sn) dm [] 
  in  if a then w else []

ih :: String -> IS Bool

ih s = do
  seen <- get                                     -- get the "seen" list
  case s `elem` seen of                           -- if already seen
    True -> return False                          -- signal circular inheritance
    False -> do
      mbdf <- ask >>= return . M.lookup s         -- look up in the map of definitions
      case mbdf of
        Just (IDLDefInterface _ _ inhr _) -> do   -- if interface
          tell [s]                                -- add its name to the scope
          modify (s :)                            -- add its name to the list of seen names
          mapM_ (ih . prtsn) inhr                 -- process parents left to right
          return True
        _ -> return True                          -- not found or not an interface: do nothing


-- Convert a scoped name into a string.

prtsn :: IDLScopedName -> String

prtsn (IDLScopedName _ []) = ""
prtsn (IDLScopedName True ss) = "::" ++ prtsn (IDLScopedName False ss)
prtsn (IDLScopedName False ss) = intercalate "::" ss

-- Build a scoped name from a string

bldsn :: String -> IDLScopedName

bldsn (':':':':n) = IDLScopedName True (mksn n)
bldsn n = IDLScopedName False (mksn n)

mksn = filter (not . null) . lines . map c2nl where
  c2nl ':' = '\n'
  c2nl z = z

-- Extract the right-most element of the name

unscope :: IDLScopedName -> String

unscope (IDLScopedName _ []) = ""
unscope (IDLScopedName _ [n]) = n
unscope (IDLScopedName a (_:ns)) = unscope (IDLScopedName a ns)