    {-# LANGUAGE PatternGuards, DeriveDataTypeable  #-}
    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Language.C.Analysis.DefTable
    -- Copyright   :  (c) 2008 Benedikt Huber
    --                  based on code from c2hs
    --                (c) [1999..2001] Manuel M. T. Chakravarty
    -- License     :  BSD-style
    -- Maintainer  :  benedikt.huber@gmail.com
    -- Stability   :  alpha
    -- Portability :  ghc
    --
    -- This module manages symbols in local and global scopes.
    --
    -- There are four different kind of identifiers: ordinary identifiers (henceforth
    -- simply called `identifier'), tag names (names of struct\/union\/enum types),
    -- labels and structure members.
    -----------------------------------------------------------------------------
    module Language.C.Analysis.DefTable (
        IdentEntry, identOfTyDecl,
        TagEntry, TagFwdDecl(..),
        DefTable(..),
        emptyDefTable,
        globalDefs,
        enterFunctionScope,leaveFunctionScope,enterBlockScope,leaveBlockScope,
        enterMemberDecl,leaveMemberDecl,
        DeclarationStatus(..),declStatusDescr,
        defineTypeDef, defineGlobalIdent, defineScopedIdent, defineScopedIdentWhen,
        declareTag,defineTag,defineLabel,lookupIdent,
        lookupTag,lookupLabel,lookupIdentInner,lookupTagInner,
    )
    where
    import Language.C.Data
    import Language.C.Analysis.NameSpaceMap
    import Language.C.Analysis.SemRep

    import Control.Applicative ((<|>))
    import Data.Map (Map)
    import qualified Data.Map as Map
    import Data.IntMap (IntMap)
    import qualified Data.IntMap as IntMap
    import Data.Generics

    {- Name spaces, scopes and contexts [Scopes]

     In C, there are 4 categories of identifiers:

      * labels
      * tag names (@(struct|union|enum) tag-name@), where /all/ tag names live in one namespace
      * members of structures and unions
      * ordinary identifiers, denoting objects, functions, typeDefs and enumeration constants

     There are 4 kind of scopes:

      * file scope: outside of parameter lists and blocks
      * function prototype scope
      * function scope: labels are visible within the entire function, and declared implicitely
      * block scope

     While function scope is irrelevant for variable declarations, they might also appear in member declarations.
     Therefore, there are also 4 kinds of contexts where a variable might be declared:

      * File Scope Context: external declaration \/ definition
      * Block Scope Context: either external or local definition
      * Function prototype scope context
      * Member Declaration context

     See
       <http://www.embedded.com/design/206901036>
       C99 6
    -}

    -- | All ordinary identifiers map to 'IdenTyDecl': either a typedef or a object\/function\/enumerator
    type IdentEntry = Either TypeDef IdentDecl

    identOfTyDecl :: IdentEntry -> Ident
    identOfTyDecl = either identOfTypeDef declIdent

    data TagFwdDecl = CompDecl CompTypeRef
                    | EnumDecl EnumTypeRef
    instance HasSUERef TagFwdDecl where
      sueRef (CompDecl ctr) = sueRef ctr
      sueRef (EnumDecl etr) = sueRef etr
    instance CNode TagFwdDecl where
      nodeInfo (CompDecl ctr) = nodeInfo ctr
      nodeInfo (EnumDecl etr) = nodeInfo etr

    -- | Tag names map to forward declarations or definitions of struct\/union\/enum types
    type TagEntry = Either TagFwdDecl TagDef

    -- | Table holding current definitions
    data DefTable = DefTable
        {
            identDecls   :: NameSpaceMap Ident IdentEntry,    -- ^ declared `ordinary identifiers'
            tagDecls   :: NameSpaceMap SUERef TagEntry,       -- ^ declared struct/union/enum  tags
            labelDefs  :: NameSpaceMap Ident Ident,            -- ^ defined labels
            memberDecls :: NameSpaceMap Ident MemberDecl,      -- ^ member declarations (only local)
            refTable   :: IntMap Name                          -- ^ link names with definitions
        }

    -- | empty definition table, with all name space maps in global scope
    emptyDefTable :: DefTable
    emptyDefTable = DefTable nameSpaceMap nameSpaceMap nameSpaceMap nameSpaceMap IntMap.empty

    -- | get the globally defined entries of a definition table
    globalDefs :: DefTable -> GlobalDecls
    globalDefs deftbl = Map.foldWithKey insertDecl (GlobalDecls e gtags e) (globalNames $ identDecls deftbl)
        where
        e = Map.empty
        (_fwd_decls,gtags) = Map.mapEither id $ globalNames (tagDecls deftbl)
        insertDecl ident (Left tydef) ds = ds { gTypeDefs = Map.insert ident tydef (gTypeDefs ds)}
        insertDecl ident (Right obj) ds = ds { gObjs = Map.insert ident obj (gObjs ds) }

    leaveScope_ :: (Ord k) => NameSpaceMap k a -> NameSpaceMap k a
    leaveScope_ = fst . leaveScope

    enterLocalScope :: DefTable -> DefTable
    enterLocalScope deftbl = deftbl {
            identDecls = enterNewScope (identDecls deftbl),
            tagDecls = enterNewScope (tagDecls deftbl)
        }
    leaveLocalScope :: DefTable -> DefTable
    leaveLocalScope deftbl = deftbl {
                            identDecls = leaveScope_ (identDecls deftbl),
                            tagDecls = leaveScope_ (tagDecls deftbl)
                           }

    -- | Enter function scope (and the corresponding block scope)
    enterFunctionScope :: DefTable -> DefTable
    enterFunctionScope deftbl = enterLocalScope  $
                              deftbl { labelDefs = enterNewScope (labelDefs deftbl) }

    -- | Leave function scope, and return the associated DefTable.
    --   Error if not in function scope.
    leaveFunctionScope :: DefTable -> DefTable
    leaveFunctionScope deftbl = leaveLocalScope $ deftbl { labelDefs = leaveScope_ (labelDefs deftbl) }

    -- | Enter new block scope
    enterBlockScope :: DefTable -> DefTable
    enterBlockScope = enterLocalScope

    -- | Leave innermost block scope
    leaveBlockScope :: DefTable -> DefTable
    leaveBlockScope = leaveLocalScope

    -- | Enter new member declaration scope
    enterMemberDecl :: DefTable -> DefTable
    enterMemberDecl deftbl = deftbl { memberDecls = enterNewScope (memberDecls deftbl) }

    -- | Leave innermost member declaration scope
    leaveMemberDecl :: DefTable -> ([MemberDecl], DefTable)
    leaveMemberDecl deftbl =
        let (decls',members) = leaveScope (memberDecls deftbl)
        in (,) (map snd members)
               (deftbl { memberDecls = decls' })

    -- * declarations

    -- | Status of a declaration
    data DeclarationStatus t =
          NewDecl         -- ^ new entry
        | Redeclared t    -- ^ old def was overwritten
        | KeepDef t       -- ^ new def was discarded
        | Shadowed t      -- ^ new def shadows one in outer scope
        | KindMismatch t  -- ^ kind mismatch
        deriving (Data,Typeable)
    declStatusDescr :: DeclarationStatus t -> String
    declStatusDescr NewDecl = "new"
    declStatusDescr (Redeclared _) = "redeclared"
    declStatusDescr (KeepDef _) = "keep old"
    declStatusDescr (Shadowed _) = "shadowed"
    declStatusDescr (KindMismatch _) = "kind mismatch"

    compatIdentEntry :: IdentEntry -> IdentEntry -> Bool
    compatIdentEntry (Left _tydef) = either (const True) (const False)
    compatIdentEntry (Right def) = either (const False) $
      \other_def -> case (def,other_def) of
                      (EnumeratorDef _, EnumeratorDef _) -> True
                      (EnumeratorDef _, _) -> True
                      (_, EnumeratorDef _) -> True
                      (_,_) -> True

    data TagEntryKind = CompKind CompTyKind | EnumKind
                        deriving (Eq,Ord)
    instance Show TagEntryKind where
      show (CompKind ctk) = show ctk
      show EnumKind = "enum"

    -- | @sameTagKind ty1 ty2@ returns @True@ if @ty1,ty2@ are the same kind of tag (struct,union or enum)
    tagKind :: TagEntry -> TagEntryKind
    tagKind (Left (CompDecl cd)) = CompKind (compTag cd)
    tagKind (Left (EnumDecl _)) = EnumKind
    tagKind (Right (CompDef cd)) = CompKind (compTag cd)
    tagKind (Right (EnumDef _)) =  EnumKind

    compatTagEntry :: TagEntry -> TagEntry -> Bool
    compatTagEntry  te1 te2 = tagKind te1 == tagKind te2

    defRedeclStatus :: (t -> t -> Bool) -> t -> Maybe t -> DeclarationStatus t
    defRedeclStatus sameKind def oldDecl =
        case oldDecl of
            Just def' | def `sameKind` def' -> Redeclared def'
                      | otherwise           -> KindMismatch def'
            Nothing                         -> NewDecl
    defRedeclStatusLocal :: (Ord k) =>
                            (t -> t -> Bool) -> k -> t -> Maybe t -> NameSpaceMap k t -> DeclarationStatus t
    defRedeclStatusLocal sameKind ident def oldDecl nsm =
        case defRedeclStatus sameKind def oldDecl of
            NewDecl -> case lookupName nsm ident of
                         Just shadowed -> Shadowed shadowed
                         Nothing       -> NewDecl
            redecl  -> redecl

    defineTypeDef :: Ident -> TypeDef -> DefTable -> (DeclarationStatus IdentEntry, DefTable)
    defineTypeDef ident tydef deftbl =
      (defRedeclStatus compatIdentEntry (Left tydef) oldDecl, deftbl { identDecls = decls' })
      where
      (decls', oldDecl) = defGlobal (identDecls deftbl) ident (Left tydef)

    -- | declare\/define a global object\/function\/typeDef
    --
    --  returns @Redeclared def@ if there is already an object\/function\/typeDef
    --  in global scope, or @DifferentKindRedec def@ if the old declaration is of a different kind.
    defineGlobalIdent :: Ident -> IdentDecl -> DefTable -> (DeclarationStatus IdentEntry, DefTable)
    defineGlobalIdent ident def deftbl =
        (defRedeclStatus compatIdentEntry (Right def) oldDecl, deftbl { identDecls = decls' })
        where
        (decls',oldDecl) = defGlobal (identDecls deftbl) ident (Right def)
    -- | declare\/define a object\/function\/typeDef with lexical scope
    --
    --  returns @Redeclared def@ or @DifferentKindRedec def@  if there is already an object\/function\/typeDef
    --  in the same scope.
    defineScopedIdent :: Ident -> IdentDecl -> DefTable -> (DeclarationStatus IdentEntry, DefTable)
    defineScopedIdent = defineScopedIdentWhen (const True)

    -- | declare\/define a object\/function\/typeDef with lexical scope, if the given predicate holds on the old
    --   entry.
    --
    --  returns @Keep old_def@ if the old definition shouldn't be overwritten, and otherwise @Redeclared def@ or
    --  @DifferentKindRedec def@  if there is already an object\/function\/typeDef in the same scope.
    defineScopedIdentWhen :: (IdentDecl -> Bool) -> Ident -> IdentDecl -> DefTable ->
                               (DeclarationStatus IdentEntry, DefTable)
    defineScopedIdentWhen override_def ident def deftbl
        = (redecl_status, deftbl { identDecls = decls' })
        where
        new_def = Right def
        old_decls = identDecls deftbl
        old_decl_opt = lookupInnermostScope old_decls ident
        (decls',redecl_status)  | (Just old_decl) <- old_decl_opt, not (old_decl `compatIdentEntry` new_def)
                                  = (new_decls, KindMismatch old_decl)
                                | maybe True doOverride old_decl_opt
                                  = (new_decls, redeclStatus' old_decl_opt)
                                | otherwise
                                  = (old_decls, maybe NewDecl KeepDef old_decl_opt)
        new_decls = fst (defLocal old_decls ident new_def)
        doOverride (Left _) = False
        doOverride (Right old_def) = (override_def old_def)
        redeclStatus' overriden_decl = defRedeclStatusLocal compatIdentEntry ident new_def overriden_decl old_decls

    -- | declare a tag (fwd decl in case the struct name isn't defined yet)
    declareTag :: SUERef -> TagFwdDecl -> DefTable -> (DeclarationStatus TagEntry, DefTable)
    declareTag sueref decl deftbl =
      case lookupTag sueref deftbl of
        Nothing -> (NewDecl, deftbl { tagDecls = fst $ defLocal (tagDecls deftbl) sueref (Left decl) })
        Just old_def | tagKind old_def == tagKind (Left decl) ->  (KeepDef old_def, deftbl)
                     | otherwise -> (KindMismatch old_def, deftbl)

    -- | define a tag
    defineTag :: SUERef -> TagDef -> DefTable -> (DeclarationStatus TagEntry, DefTable)
    defineTag sueref def deftbl =
        (redeclStatus, deftbl { tagDecls = decls'})
        where
        (decls',olddecl) = defLocal (tagDecls deftbl) sueref (Right def)
        redeclStatus =
          case olddecl of
            Just fwd_decl@(Left decl) | tagKind fwd_decl == tagKind (Right def) -> NewDecl -- should be NewDef
                                      | otherwise -> KindMismatch fwd_decl
            _ -> defRedeclStatusLocal compatTagEntry sueref (Right def) olddecl (tagDecls deftbl)

    -- | define a label
    -- Return the old label if it is already defined in this function's scope
    defineLabel :: Ident -> DefTable -> (DeclarationStatus Ident, DefTable)
    defineLabel ident deftbl =
        let (labels',old_label) = defLocal (labelDefs deftbl) ident ident
        in  (maybe NewDecl Redeclared old_label, deftbl { labelDefs = labels' })

    -- | lookup identifier (object, function, typeDef, enumerator)
    lookupIdent :: Ident -> DefTable -> Maybe IdentEntry
    lookupIdent ident deftbl = lookupName (identDecls deftbl) ident

    -- | lookup tag
    lookupTag :: SUERef -> DefTable -> Maybe TagEntry
    lookupTag sue_ref deftbl = lookupName (tagDecls deftbl) sue_ref

    -- | lookup label
    lookupLabel :: Ident -> DefTable -> Maybe Ident
    lookupLabel ident deftbl = lookupName (labelDefs deftbl) ident

    -- | lookup an object in the innermost scope
    lookupIdentInner :: Ident -> DefTable -> Maybe IdentEntry
    lookupIdentInner ident deftbl = lookupInnermostScope (identDecls deftbl) ident

    -- | lookup an identifier in the innermost scope
    lookupTagInner :: SUERef -> DefTable -> Maybe TagEntry
    lookupTagInner sue_ref deftbl = lookupInnermostScope (tagDecls deftbl) sue_ref