    --  Compiler Toolkit: identifiers
    --
    --  Author : Manuel M. T. Chakravarty
    --  Created: 14 February 95
    --
    --  Version $Revision: 1.2 $ from $Date: 2004/11/13 17:26:50 $
    --
    --  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 identifiers.
    --
    --- DOCU ----------------------------------------------------------------------
    --
    --  language: Haskell 98
    --
    --  * We speed up the equality test between identifiers by assigning an
    --    identification number to each of them, and providing a special equality
    --    that compares the lexemes only if the identification numbers are equal.
    --
    --  * The ordering relation on identifiers is also oriented at the
    --    identification number and, hence, does *not* follow the alphanumerical
    --    ordering of the lexemes of the identifiers. Instead, it provides a fast
    --    ordering when identifiers are used as keys in a `Map'.
    --
    --  * The ambiguousness resolving number of an identifier is `-1' when no such
    --    number is present (so, such identifiers are distinguished from
    --    identifiers that share the front part of the lexeme while having an
    --    ambiguousness resolving number).
    --
    --    The ambiguousness resolving number of primitive identifiers (`pid' in the
    --    grammar contained in the KCode definition) is `-2' (this gives primitive
    --    identifiers a distinct name space).
    --
    --  * Attributes may be associated to identifiers, except with `OnlyPos'
    --    identifiers, which have a position as their only attribute (they do not
    --    carry an attribute identifier, which can be used to index attribute
    --    tables).
    --
    --  * Internal identifiers that are forming a completely unique name space are
    --    supported. But note, they do not have a proper lexeme, i.e., they are not
    --    suited for code generation.
    --
    --- TODO ----------------------------------------------------------------------
    --
    --  * Hashing is not 8bit clean.
    --

    module Idents (Ident, noARNum, isLegalIdent, lexemeToIdent, internalIdent,
                   onlyPosIdent, cloneIdent, identToLexeme, isIdentSimple,
                   isIdentPrim, stripIdentARNum, getIdentARNum, newIdentARNum,
                   getIdentAttrs, dumpIdent)
    where

    import Data.Char
    import Position   (Position, Pos(posOf), nopos)
    import UNames     (Name)
    import Errors     (interr)
    import Attributes (Attrs, newAttrsOnlyPos, newAttrs,
                       Attributed(attrsOf), posOfAttrsOf)
    import Binary     (Binary(..), putSharedString, getSharedString)

    -- simple identifier representation (EXPORTED)
    --
    -- identifiers without an ambiguousness resolving number get `noARNum' as
    -- number
    --
    data Ident = Ident String       -- lexeme
                       !Int         -- ambiguousness resolving number
                       !Int         -- id. number to speed up equality check
                       !Attrs       -- attributes of this ident. incl. position

    -- the definition of the equality allows identifiers to be equal that are
    -- defined at different source text positions, and aims at speeding up the
    -- equality test, by comparing the lexemes only if the two numbers are equal
    --
    instance Eq Ident where
      (Ident s k id _) == (Ident s' k' id' _) =    (k == k')
                                                && (id == id')
                                                && (s == s')

    -- this does *not* follow the alphanumerical ordering of the lexemes
    --
    instance Ord Ident where
      (Ident s k id _) < (Ident s' k' id' _) =    (k < k')
                                               || ((k == k') && (id < id'))
                                               || ((k == k') && (id == id')
                                                   && (s < s'))
      id1 <= id2 = (id1 < id2) || (id1 == id2)

    -- for displaying identifiers
    --
    instance Show Ident where
      showsPrec _ ide = showString ("`" ++ identToLexeme ide ++ "'")

    -- identifiers are attributed
    --
    instance Attributed Ident where
      attrsOf (Ident _ _ _ at) = at

    -- identifiers have a canonical position
    --
    instance Pos Ident where
      posOf = posOfAttrsOf

    -- to speed up the equality test we compute some hash-like value for each
    -- identifiers lexeme and store it in the identifiers representation

    -- hash function from the dragon book pp437; assumes 7 bit characters and needs
    -- the (nearly) full range of values guaranteed for `Int' by the Haskell
    -- language definition; can handle 8 bit characters provided we have 29 bit
    -- for the `Int's without sign
    --
    quad                 :: String -> Int
    quad (c1:c2:c3:c4:s)  = ((ord c4 * bits21
                              + ord c3 * bits14
                              + ord c2 * bits7
                              + ord c1)
                             `mod` bits28)
                            + (quad s `mod` bits28)
    quad (c1:c2:c3:[]  )  = ord c3 * bits14 + ord c2 * bits7 + ord c1
    quad (c1:c2:[]     )  = ord c2 * bits7 + ord c1
    quad (c1:[]        )  = ord c1
    quad ([]           )  = 0

    bits7  = 2^7
    bits14 = 2^14
    bits21 = 2^21
    bits28 = 2^28

    -- used as a substitute for the ambiguousness resolving number if it is not
    -- present (EXPORTED)
    --
    noARNum :: Int
    noARNum  = -1

    -- used as the ambiguousness resolving number for primitive identifiers
    --
    primARNum :: Int
    primARNum  = -2

    -- used as the ambiguousness resolving number for internal identifiers
    --
    internARNum :: Int
    internARNum  = -3

    -- checks whether the given lexeme is a legal identifier (EXPORTED)
    --
    isLegalIdent        :: String -> Bool
    isLegalIdent []      = False
    isLegalIdent (c:cs)  = if c == '`' then isQualIdent cs
                           else (isAlpha c || c == '_') && isIdent (c:cs)
                           where
                             isIdent = checkTail . (dropWhile isAlphaNumOrUS)

                             checkTail []        = True
                             checkTail ("##")    = True
                             checkTail ('#':cs') = all isDigit cs'
                             checkTail _         = False

                             isAlphaNumOrUS c = isAlphaNum c || (c == '_')
                             isAlphaNum     c = isAlpha c || isNum c
                             isAlpha        c = c `elem` ['a'..'z'] ++ ['A'..'Z']
                             isNum          c = c `elem` ['0'..'9']

                             isQualIdent cs = let
                                                cs' = skip cs
                                              in
                                                (not . null) cs'
                                                && (checkTail . tail) cs'

                             skip []        = []
                             skip ('\'':cs) = '\'':cs
                             skip ('\\':cs) = case cs of
                                                ('\'':cs') -> skip cs'
                                                ('\\':cs') -> skip cs'
                                                _          -> skip cs
                             skip (c  :cs)  = skip cs

    -- given the lexeme of an identifier, yield the abstract identifier (EXPORTED)
    --
    --  * the only attribute of the resulting identifier is its source text
    --   position; as provided in the first argument of this function
    --
    --  * only minimal error checking, e.g., the characters of the identifier are
    --   not checked for being alphanumerical only; the correct lexis of the
    --   identifier should be ensured by the caller, e.g., the scanner or
    --   `isLegalIdent'
    --
    --  * for reasons of simplicity the complete lexeme is hashed (with `quad')
    --
    lexemeToIdent            :: Position -> String -> Name -> Ident
    lexemeToIdent pos l name  = Ident s k (quad s) (newAttrs pos name)
                                where
                                  (s, k) = parseIdent pos l

    -- generate an internal identifier (has no position and cannot be asccociated
    -- with attributes) (EXPORTED)
    --
    internalIdent   :: String -> Ident
    internalIdent s  = Ident s internARNum (quad s) (newAttrsOnlyPos nopos)

    -- generate a `only pos' identifier (may not be used to index attribute
    -- tables, but has a position value) (EXPORTED)
    --
    onlyPosIdent       :: Position -> String -> Ident
    onlyPosIdent pos l  = Ident s k (quad s) (newAttrsOnlyPos pos)
                          where
                            (s, k) = parseIdent pos l

    -- Extract the name and ambiguousness resolving number from a lexeme.
    --
    parseIdent   :: Position -> String -> (String, Int)
    parseIdent pos l
                  = if (null l)
                    then
                      interr $ "Idents: lexemeToIdent: Empty lexeme! " ++ show pos
                    else
                    if (head l == '\'')
                    then
                      parseQuoted (tail l)
                    else
                      parseNorm l
                    where
                    -- parse lexeme without quotes
                    --
                    parseNorm []        = ([], noARNum)
                    parseNorm ("##")    = ([], primARNum)
                    parseNorm ('#':cs)  = ([], ((read . check) cs)::Int)
                    parseNorm (c  :cs)  = let
                                            (cs', k) = parseNorm cs
                                          in
                                            (c:cs', k)

                    check []       = interr "Idents: lexemeToIdent: Missing\
                                            \ number!"
                    check ('-':cs) = interr "Idents: lexemeToIdent: Illegal\
                                            \ negative number!"
                    check s        = s

                    -- parse lexeme with quotes
                    --
                    parseQuoted []        = interr endInQuotes
                    parseQuoted ('\\':cs) = parseSpecial cs
                    parseQuoted ('\'':cs) = let
                                              (rmd, k) = parseNorm cs
                                            in
                                              if (null rmd) then ([], k)
                                              else interr afterQuotes
                    parseQuoted (c   :cs) = let
                                              (cs', k) = parseQuoted cs
                                            in
                                              (c:cs', k)

                    endInQuotes  = "Idents: lexemeToIdent: Unexpected end of\
                                   \ lexeme (in quotes)!"

                    afterQuotes  = "Idents: lexemeToIdent: Superfluous\
                                   \ characters after quotes!"

                    endInSpecial = "Idents: lexemeToIdent: Unexpected end of\
                                   \ lexeme (in escape sequence)!"

                    illegalSpecial = "Idents: lexemeToIdent: Illegal escape\
                                     \ sequence!"

                    -- parse single escaped character, then continue with
                    -- `parseQuoted'
                    --
                    parseSpecial []              = interr endInSpecial
                    parseSpecial (c1:c2:c3:cs)
                                 | isDigit c1
                                   && isDigit c2
                                   && isDigit c3 = let
                                                     (cs', k) = parseQuoted cs
                                                     ord0     = ord '0'
                                                     d1       = ord c1 - ord0
                                                     d2       = ord c2 - ord0
                                                     d3       = ord c3 - ord0
                                                   in
                                                     (chr (100*d1 + 10*d2 + d3)
                                                      :cs', k)
                    parseSpecial (c:cs)
                                 | c == '\\'     = ('\\':cs', k)
                                 | c == '\"'     = ('\"':cs', k)
                                 | c == '\''     = ('\'':cs', k)
                                 | c == 'n'      = ('\n':cs', k)
                                 | c == 't'      = ('\t':cs', k)
                                 | c == 'r'      = ('\r':cs', k)
                                                   where
                                                     (cs', k) = parseQuoted cs
                    parseSpecial _               = interr illegalSpecial

    -- create an identifier identical to the given one, but with its own set of
    -- attributes (EXPORTED)
    --
    cloneIdent                           :: Ident -> Name -> Ident
    cloneIdent (Ident s k idnum at) name  =
      Ident s k idnum (newAttrs (posOf at) name)

    -- given an abstract identifier, yield its lexeme (EXPORTED)
    --
    identToLexeme                 :: Ident -> String
    identToLexeme (Ident s k _ _)  = s ++ suffix
                                     where
                                       suffix = if      (k == noARNum)
                                                then ""
                                                else if (k == primARNum)
                                                then "##"
                                                else if (k == internARNum)
                                                then "<internal>"
                                                else "#" ++ show k

    -- test if the given identifier is simple, i.e., has no ambiguousness
    -- resolving number and is not a primitive identifier (EXPORTED)
    --
    isIdentSimple                 :: Ident -> Bool
    isIdentSimple (Ident _ k _ _)  = k == noARNum

    -- test if the given identifier is a primitive identifier (EXPORTED)
    --
    isIdentPrim                 :: Ident -> Bool
    isIdentPrim (Ident _ k _ _)  = k == primARNum

    -- remove ambiguousness resolving of an identifier (EXPORTED)
    --
    -- NOTE: The new identifier will not be equal (==) to the old one!
    --
    stripIdentARNum                        :: Ident -> Ident
    stripIdentARNum (Ident s k id at)
      | k == primARNum || k == internARNum  = interr "Idents: stripIdentARNum: \
                                                     \Not allowed!"
      | otherwise                           = Ident s noARNum id at

    -- get the ambiguousness resolving of an identifier (EXPORTED)
    --
    getIdentARNum                        :: Ident -> Int
    getIdentARNum (Ident s k id at)
      | k == primARNum || k == internARNum  = interr "Idents: getIdentARNum: \
                                                     \Not allowed!"
      | otherwise                           = k

    -- enter a new ambiguousness resolving into the identifier (EXPORTED)
    --
    -- NOTE: The new identifier will not be equal (==) to the old one!
    --
    newIdentARNum :: Ident -> Int -> Ident
    newIdentARNum (Ident s k id at) k'
      | k' < 0                              = interr "Idents: newIdentARNum: \
                                                     \Negative number!"
      | k == primARNum || k == internARNum  = interr "Idents: newIdentARNum: \
                                                     \Not allowed!"
      | otherwise                           = Ident s k' id at

    -- get the attribute identifier associated with the given identifier (EXPORTED)
    --
    getIdentAttrs                  :: Ident -> Attrs
    getIdentAttrs (Ident _ _ _ as)  = as

    -- dump the lexeme and its positions into a string for debugging purposes
    -- (EXPORTED)
    --
    dumpIdent     :: Ident -> String
    dumpIdent ide  = identToLexeme ide ++ " at " ++ show (posOf ide)

    {-! for Ident derive : GhcBinary !-}
    {-* Generated by DrIFT : Look, but Don't Touch. *-}
    instance Binary Ident where
        put_ bh (Ident aa ab ac ad) = do
                putSharedString bh aa
    --            put_ bh aa
                put_ bh ab
                put_ bh ac
                put_ bh ad
        get bh = do
        aa <- getSharedString bh
    --    aa <- get bh
        ab <- get bh
        ac <- get bh
        ad <- get bh
        return (Ident aa ab ac ad)