    --  Compiler Toolkit: general purpose attribute management
    --
    --  Author : Manuel M. T. Chakravarty
    --  Created: 14 February 95
    --
    --  Version $Revision: 1.4 $ from $Date: 2005/06/22 16:01:03 $
    --
    --  Copyright (c) [1995..1999] Manuel M. T. Chakravarty
    --
    --  This file is free software; you can redistribute it and/or modify
    --  it under the terms of the GNU General Public License as published by
    --  the Free Software Foundation; either version 2 of the License, or
    --  (at your option) any later version.
    --
    --  This file is distributed in the hope that it will be useful,
    --  but WITHOUT ANY WARRANTY; without even the implied warranty of
    --  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    --  GNU General Public License for more details.
    --
    --- DESCRIPTION ---------------------------------------------------------------
    --
    --  This module provides an abstract notion of attributes (in the sense of
    --  compiler construction). The collection of attributes that is attached to a
    --  single node of the structure tree is referenced via an attributes
    --  identifier. This is basically a reference into so-called attribute tables,
    --  which manage attributes of one type and may use different representations.
    --  There is also a position attribute managed via the attribute identifier
    --  without needing a further table (it is already fixed on construction of
    --  the structure tree).
    --
    --  The `Attributed' class is based on a suggestion from Roman Lechtchinsky.
    --
    --- DOCU ----------------------------------------------------------------------
    --
    --  language: Haskell 98
    --
    --  * Attribute identifiers are generated during parsing and whenever new
    --    structure tree elements, possibly due to transformations, are generated.
    --
    --  * New attributes can be added by simply providing a new attribute table
    --    indexed by the attribute identifiers. Thus, adding or discarding an
    --    attribute does not involve any change in the structure tree.
    --
    --  * Consecutive sequences of names are used as attribute identifiers to
    --    facilitate the use of arrays for attributes that are fixed; speeds up
    --    read access. (See also TODO.)
    --
    --  * Each attribute table can simultaneously provide melted (updatable) and
    --    frozen (non-updatable) attributes. It also allows to dynamically grow the
    --    table, i.e., cover a wider range of attribute identifiers.
    --
    --  * There is a variant merely providing a position, which is used for
    --    internal identifiers and such.
    --
    --  * `StdAttr' provides standard undefined and don't care variants for
    --    attribute values.
    --
    --- TODO ----------------------------------------------------------------------
    --
    --  * When there are sparse attribute tables that we want to freeze (and they
    --    will occur sooner or later), then introduce a third variant of tables
    --    realized via hash table---depending on the type of attribute table, we
    --    may even allow them to be soft.
    --
    --    NOTE: Currently, if assertions are switched on, on freezing a table, its
    --          density is calculate and, if it is below 33%, an internal error is
    --          raised (only if there are more than 1000 entries in the table).
    --
    --  * check whether it would increase the performance significantly if we use
    --    a mixed finite map/array representation for soft tables (all attributes
    --    defined before the last `soften' could be held in the array, changing
    --    an attribute just means to update it in the FM; i.e., the FM entries take
    --    precedence over the array entries)
    --

    module Attributes (-- attribute management
                       --
                       Attrs, newAttrsOnlyPos, newAttrs,
                       Attributed(attrsOf), eqOfAttrsOf, posOfAttrsOf,
                       --
                       -- attributes and attribute tables
                       --
                       Attr(undef, isUndef, dontCare, isDontCare),
                       AttrTable, newAttrTable, getAttr, setAttr, updAttr,
                       copyAttr, freezeAttrTable, softenAttrTable,
                       StdAttr(..), getStdAttr, getStdAttrDft, isDontCareStdAttr,
                       isUndefStdAttr, setStdAttr, updStdAttr,
                       getGenAttr, setGenAttr, updGenAttr)
    where

    import Data.Array
    import Control.Exception (assert)
    import Position   (Position, Pos(posOf), nopos, isNopos, dontCarePos,
                       isDontCarePos)
    import Errors     (interr)
    import UNames     (NameSupply, Name,
                       rootSupply, splitSupply, names)
    import Map        (Map)
    import qualified  Map as Map (fromList, toList, insert,
                       findWithDefault, empty)
    import Binary     (Binary(..), putByte, getByte)

    -- attribute management data structures and operations
    -- ---------------------------------------------------

    -- abstract data structure used in the structure tree to represent the
    -- attribute identifier and the position (EXPORTED)
    --
    data Attrs = OnlyPos Position           -- only pos (for internal stuff only)
               | Attrs   Position Name      -- pos and unique name

    -- get the position associated with an attribute identifier (EXPORTED)
    --
    instance Pos Attrs where
      posOf (OnlyPos pos  ) = pos
      posOf (Attrs   pos _) = pos

    -- equality of attributes is used to define the equality of objects (EXPORTED)
    --
    instance Eq Attrs where
      (Attrs   _ id1) == (Attrs   _ id2) = id1 == id2
      _               == _               =
        interr "Attributes: Attempt to compare `OnlyPos' attributes!"

    -- attribute ordering is also lifted to objects (EXPORTED)
    --
    instance Ord Attrs where
      (Attrs   _ id1) <= (Attrs   _ id2) = id1 <= id2
      _               <= _               =
        interr "Attributes: Attempt to compare `OnlyPos' attributes!"

    -- a class for convenient access to the attributes of an attributed object
    -- (EXPORTED)
    --
    class Attributed a where
      attrsOf :: a -> Attrs

    -- equality induced by attribution (EXPORTED)
    --
    eqOfAttrsOf           :: Attributed a => a -> a -> Bool
    eqOfAttrsOf obj1 obj2  = (attrsOf obj1) == (attrsOf obj2)

    -- position induced by attribution (EXPORTED)
    --
    posOfAttrsOf :: Attributed a => a -> Position
    posOfAttrsOf  = posOf . attrsOf

    -- attribute identifier creation
    -- -----------------------------

    -- Given only a source position, create a new attribute identifier (EXPORTED)
    --
    newAttrsOnlyPos     :: Position -> Attrs
    newAttrsOnlyPos pos  = OnlyPos pos

    -- Given a source position and a unique name, create a new attribute
    -- identifier (EXPORTED)
    --
    newAttrs          :: Position -> Name -> Attrs
    newAttrs pos name  = Attrs pos name

    -- attribute tables and operations on them
    -- ---------------------------------------

    -- the type class `Attr' determines which types may be used as attributes
    -- (EXPORTED)
    --
    --  * such types have to provide values representing an undefined and a don't
    --   care state, together with two functions to test for these values
    --
    --  * an attribute in an attribute table is initially set to `undef' (before
    --   some value is assigned to it)
    --
    --  * an attribute with value `dontCare' participated in an already detected
    --   error, it's value may not be used for further computations in order to
    --   avoid error avalanches
    --
    class Attr a where
      undef      :: a
      isUndef    :: a -> Bool
      dontCare   :: a
      isDontCare :: a -> Bool
      undef       = interr "Attributes: Undefined `undef' method in `Attr' class!"
      isUndef     = interr "Attributes: Undefined `isUndef' method in `Attr' \
                           \class!"
      dontCare    = interr "Attributes: Undefined `dontCare' method in `Attr' \
                           \class!"
      isDontCare  = interr "Attributes: Undefined `isDontCare' method in `Attr' \
                           \class!"

    -- attribute tables map attribute identifiers to attribute values
    -- (EXPORTED ABSTRACT)
    --
    --  * the attributes within a table can be soft or frozen, the former may by be
    --   updated, but the latter can not be changed
    --
    --  * the attributes in a frozen table are stored in an array for fast
    --   lookup; consequently, the attribute identifiers must be *dense*
    --
    --  * the table description string is used to emit better error messages (for
    --   internal errors)
    --
    data Attr a =>
         AttrTable a = -- for all attribute identifiers not contained in the
                       -- finite map the value is `undef'
                       --
                       SoftTable (Map Name a)   -- updated attr.s
                                 String               -- desc of the table

                       -- the array contains `undef' attributes for the undefined
                       -- attributes; for all attribute identifiers outside the
                       -- bounds, the value is also `undef';
                       --
                     | FrozenTable (Array Name a)     -- attribute values
                                   String             -- desc of the table

    -- create an attribute table, where all attributes are `undef' (EXPORTED)
    --
    -- the description string is used to identify the table in error messages
    -- (internal errors); a table is initially soft
    --
    newAttrTable      :: Attr a => String -> AttrTable a
    newAttrTable desc  = SoftTable Map.empty desc

    -- get the value of an attribute from the given attribute table (EXPORTED)
    --
    getAttr                      :: Attr a => AttrTable a -> Attrs -> a
    getAttr at (OnlyPos pos    )  = onlyPosErr "getAttr" at pos
    getAttr at (Attrs   _   aid)  =
      case at of
        (SoftTable   fm  _) -> Map.findWithDefault undef aid fm
        (FrozenTable arr _) -> let (lbd, ubd) = bounds arr
                               in
                               if (aid < lbd || aid > ubd) then undef else arr!aid

    -- set the value of an, up to now, undefined attribute from the given
    -- attribute table (EXPORTED)
    --
    setAttr :: Attr a => AttrTable a -> Attrs -> a -> AttrTable a
    setAttr at (OnlyPos pos    ) av = onlyPosErr "setAttr" at pos
    setAttr at (Attrs   pos aid) av =
      case at of
        (SoftTable fm desc) -> assert (isUndef (Map.findWithDefault undef aid fm)) $
                                 SoftTable (Map.insert aid av fm) desc
        (FrozenTable arr _) -> interr frozenErr
      where
        frozenErr     = "Attributes.setAttr: Tried to write frozen attribute in\n"
                        ++ errLoc at pos

    -- update the value of an attribute from the given attribute table (EXPORTED)
    --
    updAttr :: Attr a => AttrTable a -> Attrs -> a -> AttrTable a
    updAttr at (OnlyPos pos    ) av = onlyPosErr "updAttr" at pos
    updAttr at (Attrs   pos aid) av =
      case at of
        (SoftTable   fm  desc) -> SoftTable (Map.insert aid av fm) desc
        (FrozenTable arr _)    -> interr $ "Attributes.updAttr: Tried to\
                                           \ update frozen attribute in\n"
                                           ++ errLoc at pos

    -- copy the value of an attribute to another one (EXPORTED)
    --
    --  * undefined attributes are not copied, to avoid filling the table
    --
    copyAttr :: Attr a => AttrTable a -> Attrs -> Attrs -> AttrTable a
    copyAttr at ats ats'
      | isUndef av = assert (isUndef (getAttr at ats'))
                       at
      | otherwise  = updAttr at ats' av
      where
        av = getAttr at ats

    -- auxiliary functions for error messages
    --
    onlyPosErr                :: Attr a => String -> AttrTable a -> Position -> b
    onlyPosErr fctName at pos  =
      interr $ "Attributes." ++ fctName ++ ": No attribute identifier in\n"
               ++ errLoc at pos
    --
    errLoc        :: Attr a => AttrTable a -> Position -> String
    errLoc at pos  = "  table `" ++ tableDesc at ++ "' for construct at\n\
                     \  position " ++ show pos ++ "!"
      where
        tableDesc (SoftTable   _ desc) = desc
        tableDesc (FrozenTable _ desc) = desc

    -- freeze a soft table; afterwards no more changes are possible until the
    -- table is softened again (EXPORTED)
    --
    freezeAttrTable                        :: Attr a => AttrTable a -> AttrTable a
    freezeAttrTable (SoftTable   fm  desc)  =
      let contents = Map.toList fm
          keys     = map fst contents
          lbd      = minimum keys
          ubd      = maximum keys
      in
      assert (length keys < 1000 || (length . range) (lbd, ubd) > 3 * length keys)
      (FrozenTable (array (lbd, ubd) contents) desc)
    freezeAttrTable (FrozenTable arr desc)  =
      interr ("Attributes.freezeAttrTable: Attempt to freeze the already frozen\n\
              \  table `" ++ desc ++ "'!")

    -- soften a frozen table; afterwards changes are possible until the
    -- table is frozen again (EXPORTED)
    --
    softenAttrTable                        :: Attr a => AttrTable a -> AttrTable a
    softenAttrTable (SoftTable   fm  desc)  =
      interr ("Attributes.softenAttrTable: Attempt to soften the already \
              \softened\n  table `" ++ desc ++ "'!")
    softenAttrTable (FrozenTable arr desc)  =
      SoftTable (Map.fromList . assocs $ arr) desc

    -- standard attributes
    -- -------------------

    -- standard attribute variants (EXPORTED)
    --
    data StdAttr a = UndefStdAttr
                   | DontCareStdAttr
                   | JustStdAttr a

    instance Attr (StdAttr a) where
      undef = UndefStdAttr

      isUndef UndefStdAttr = True
      isUndef _            = False

      dontCare = DontCareStdAttr

      isDontCare DontCareStdAttr = True
      isDontCare _               = False

    -- get an attribute value from a standard attribute table (EXPORTED)
    --
    --  * if the attribute can be "don't care", this should be checked before
    --   calling this function (using `isDontCareStdAttr')
    --
    getStdAttr         :: AttrTable (StdAttr a) -> Attrs -> a
    getStdAttr atab at  = getStdAttrDft atab at err
      where
        err = interr $ "Attributes.getStdAttr: Don't care in\n"
                       ++ errLoc atab (posOf at)

    -- get an attribute value from a standard attribute table, where a default is
    -- substituted if the table is don't care (EXPORTED)
    --
    getStdAttrDft             :: AttrTable (StdAttr a) -> Attrs -> a -> a
    getStdAttrDft atab at dft  =
      case getAttr atab at of
        DontCareStdAttr -> dft
        JustStdAttr av  -> av
        UndefStdAttr    -> interr $ "Attributes.getStdAttrDft: Undefined in\n"
                                    ++ errLoc atab (posOf at)

    -- check if the attribue value is marked as "don't care" (EXPORTED)
    --
    isDontCareStdAttr         :: AttrTable (StdAttr a) -> Attrs -> Bool
    isDontCareStdAttr atab at  = isDontCare (getAttr atab at)

    -- check if the attribue value is still undefined (EXPORTED)
    --
    --  * we also regard "don't care" attributes as undefined
    --
    isUndefStdAttr         :: AttrTable (StdAttr a) -> Attrs -> Bool
    isUndefStdAttr atab at  = isUndef (getAttr atab at)

    -- set an attribute value in a standard attribute table (EXPORTED)
    --
    setStdAttr :: AttrTable (StdAttr a) -> Attrs -> a -> AttrTable (StdAttr a)
    setStdAttr atab at av = setAttr atab at (JustStdAttr av)

    -- update an attribute value in a standard attribute table (EXPORTED)
    --
    updStdAttr :: AttrTable (StdAttr a) -> Attrs -> a -> AttrTable (StdAttr a)
    updStdAttr atab at av = updAttr atab at (JustStdAttr av)

    -- generic attribute table access (EXPORTED)
    -- ------------------------------

    getGenAttr         :: (Attr a, Attributed obj) => AttrTable a -> obj -> a
    getGenAttr atab at  = getAttr atab (attrsOf at)

    setGenAttr            :: (Attr a, Attributed obj)
                          => AttrTable a -> obj -> a -> AttrTable a
    setGenAttr atab at av  = setAttr atab (attrsOf at) av

    updGenAttr            :: (Attr a, Attributed obj)
                          => AttrTable a -> obj -> a -> AttrTable a
    updGenAttr atab at av  = updAttr atab (attrsOf at) av

    {-! for Attrs derive : GhcBinary !-}
    {-! for AttrTable derive : GhcBinary !-}
    {-* Generated by DrIFT : Look, but Don't Touch. *-}
    instance Binary Attrs where
        put_ bh (OnlyPos aa) = do
                putByte bh 0
                put_ bh aa
        put_ bh (Attrs ab ac) = do
                putByte bh 1
                put_ bh ab
                put_ bh ac
        get bh = do
                h <- getByte bh
                case h of
                  0 -> do
                        aa <- get bh
                        return (OnlyPos aa)
                  1 -> do
                        ab <- get bh
                        ac <- get bh
                        return (Attrs ab ac)

    instance (Binary a, Attr a) => Binary (AttrTable a) where
        put_ bh (SoftTable aa ab) = do
                putByte bh 0
                put_ bh aa
                put_ bh ab
        put_ bh (FrozenTable ac ad) = do
                putByte bh 1
                put_ bh ac
                put_ bh ad
        get bh = do
                h <- getByte bh
                case h of
                  0 -> do
                        aa <- get bh
                        ab <- get bh
                        return (SoftTable aa ab)
                  1 -> do
                        ac <- get bh
                        ad <- get bh
                        return (FrozenTable ac ad)