Constants.hs

{-# LANGUAGE DeriveDataTypeable #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Language.C.Syntax.Constants
-- Copyright   :  (c) 2007..2008 Duncan Coutts, Benedikt Huber
-- License     :  BSD-style
-- Maintainer  : benedikt.huber@gmail.com
-- Stability   : experimental
-- Portability : ghc
--
-- This module provides support for representing, checking and exporting c
-- constants, i.e. integral, float, character and string constants.
-----------------------------------------------------------------------------
module Language.C.Syntax.Constants (
  -- * Utilities
  escapeChar, unescapeChar, unescapeString,
  Flags(..), noFlags, setFlag, clearFlag, testFlag,
  -- * C char constants (and multi-character character constants)
  cChar, cChar_w, cChars, CChar(..), getCChar, getCCharAsInt, isWideChar, showCharConst,
  -- * C integral constants
  CIntFlag(..), CIntRepr(..), cInteger, CInteger(..), getCInteger,readCInteger,
  -- * C floating point constants
  cFloat,  CFloat(..), readCFloat,
  -- * C string literals
  cString, cString_w, CString(..), getCString, showStringLit, concatCStrings,
)
where
import Data.Bits
import Data.Char
import Numeric (showOct, showHex, readHex, readOct, readDec)
import Language.C.Data.Node
import Language.C.Data.Position
import Data.Generics

-- | C char constants (abstract)
data CChar = CChar
              {-# UNPACK #-} !Char
              {-# UNPACK #-} !Bool  -- wide flag
           | CChars
                              [Char] -- multi-character character constant
              {-# UNPACK #-} !Bool   -- wide flag
           deriving (Eq,Ord,Data,Typeable)

instance Show CChar where
    showsPrec _ (CChar c wideflag)   = _showWideFlag wideflag . showCharConst c
    showsPrec _ (CChars cs wideflag) = _showWideFlag wideflag . (sQuote $ concatMap escapeCChar cs)

-- | @showCharConst c@ prepends _a_ String representing the C char constant corresponding to @c@.
-- If neccessary uses octal or hexadecimal escape sequences.
showCharConst :: Char -> ShowS
showCharConst c = sQuote $ escapeCChar c

_showWideFlag :: Bool -> ShowS
_showWideFlag flag = if flag then showString "L" else id

-- | get the haskell representation of a char constant
getCChar :: CChar -> [Char]
getCChar (CChar  c _)   = [c]
getCChar (CChars  cs _) = cs

-- | get integer value of a C char constant
-- undefined result for multi-char char constants
getCCharAsInt :: CChar -> Integer
getCCharAsInt (CChar c _) = fromIntegral (fromEnum c)
getCCharAsInt (CChars _cs _) = error "integer value of multi-character character constants is implementation defined"

-- | return @true@ if the character constant is /wide/.
isWideChar :: CChar -> Bool
isWideChar (CChar _ wideFlag) = wideFlag
isWideChar (CChars _ wideFlag) = wideFlag

-- | construct a character constant from a haskell 'Char'
-- Use 'cchar_w' if you want a wide character constant.
cChar :: Char -> CChar
cChar c = CChar c False

-- | construct a wide chararacter constant
cChar_w :: Char -> CChar
cChar_w c = CChar c True

-- | create a multi-character character constant
cChars :: [Char] -> Bool -> CChar
cChars = CChars

-- | datatype for memorizing the representation of an integer
data CIntRepr = DecRepr | HexRepr | OctalRepr deriving (Eq,Ord,Enum,Bounded,Data,Typeable)

-- | datatype representing type flags for integers
data CIntFlag = FlagUnsigned | FlagLong | FlagLongLong | FlagImag deriving (Eq,Ord,Enum,Bounded,Data,Typeable)
instance Show CIntFlag where
    show FlagUnsigned = "u"
    show FlagLong = "L"
    show FlagLongLong = "LL"
    show FlagImag = "i"

{-# SPECIALIZE setFlag :: CIntFlag -> Flags CIntFlag -> Flags CIntFlag #-}
{-# SPECIALIZE clearFlag :: CIntFlag -> Flags CIntFlag -> Flags CIntFlag #-}
{-# SPECIALIZE testFlag :: CIntFlag -> Flags CIntFlag -> Bool #-}

data CInteger = CInteger
                 {-# UNPACK #-} !Integer
                 {-# UNPACK #-} !CIntRepr
                 {-# UNPACK #-} !(Flags CIntFlag)  -- integer flags
                 deriving (Eq,Ord,Data,Typeable)
instance Show CInteger where
    showsPrec _ (CInteger i repr flags) = showInt i . showString (concatMap showIFlag [FlagUnsigned .. ]) where
        showIFlag f = if testFlag f flags then show f else []
        showInt i = case repr of DecRepr -> shows i
                                 OctalRepr -> showString "0" . showOct i
                                 HexRepr -> showString "0x" . showHex i

-- To be used in the lexer
-- Note that the flag lexer won't scale
readCInteger :: CIntRepr -> String -> Either String CInteger
readCInteger repr str =
  case readNum str of
    [(n,suffix)] -> mkCInt n suffix
    parseFailed  -> Left $ "Bad Integer literal: "++show parseFailed
  where
    readNum = case repr of DecRepr -> readDec; HexRepr -> readHex; OctalRepr -> readOct
    mkCInt n suffix = either Left (Right . CInteger n (repr' str))  $ readSuffix suffix
    repr' ('0':[]) = DecRepr -- hacking away lexer bug
    repr' _ = repr
    readSuffix = parseFlags noFlags
    parseFlags flags [] = Right flags
    parseFlags flags ('l':'l':fs) = parseFlags (setFlag FlagLongLong flags) fs
    parseFlags flags ('L':'L':fs) = parseFlags (setFlag FlagLongLong flags) fs
    parseFlags flags (f:fs) =
      let go1 flag = parseFlags (setFlag flag flags) fs in
      case f of
        'l' -> go1 FlagLong ; 'L' -> go1 FlagLong
        'u' -> go1 FlagUnsigned ; 'U' -> go1 FlagUnsigned
        'i' -> go1 FlagImag ; 'I' -> go1 FlagImag; 'j' -> go1 FlagImag; 'J' -> go1 FlagImag
        _ -> Left $ "Unexpected flag " ++ show f

getCInteger :: CInteger -> Integer
getCInteger (CInteger i _ _) = i

-- | construct a integer constant (without type flags) from a haskell integer
cInteger :: Integer -> CInteger
cInteger i = CInteger i DecRepr noFlags


-- | Floats (represented as strings)
data CFloat = CFloat
                {-# UNPACK #-} !String
                 deriving (Eq,Ord,Data,Typeable)
instance Show CFloat where
  showsPrec _ (CFloat internal) = showString internal

cFloat :: Float -> CFloat
cFloat = CFloat . show

-- dummy implementation
readCFloat :: String -> CFloat
readCFloat = CFloat

-- | C String literals
data CString = CString
                [Char]    -- characters
                Bool      -- wide flag
                deriving (Eq,Ord,Data,Typeable)
instance Show CString where
    showsPrec _ (CString str wideflag) = _showWideFlag wideflag . showStringLit str

-- construction
cString :: String -> CString
cString str = CString str False
cString_w :: String -> CString
cString_w str = CString str True

-- selectors
getCString :: CString -> String
getCString (CString str _) = str
isWideString :: CString -> Bool
isWideString (CString _ wideflag) = wideflag

-- | concatenate a list of C string literals
concatCStrings :: [CString] -> CString
concatCStrings cs = CString (concatMap getCString cs) (any isWideString cs)

-- | @showStringLiteral s@ prepends a String representing the C string literal corresponding to @s@.
-- If neccessary it uses octal or hexadecimal escape sequences.
showStringLit :: String -> ShowS
showStringLit = dQuote . concatMap showStringChar
  where
  showStringChar c | isSChar c = return c
                     | c == '"'  = "\\\""
                     | otherwise = escapeChar c



-- | @isAsciiSourceChar b@ returns @True@ if the given character is a character which
--   may appear in a ASCII C source file and is printable.
isAsciiSourceChar :: Char -> Bool
isAsciiSourceChar c = isAscii c && isPrint c

-- | @isCChar c@ returns true, if c is a source character which does not have to be escaped in
--   C char constants (C99: 6.4.4.4)
isCChar :: Char -> Bool
isCChar '\\' = False
isCChar '\'' = False
isCChar '\n' = False
isCChar c = isAsciiSourceChar c

-- | @escapeCChar c@ escapes c for use in a char constant
escapeCChar :: Char -> String
escapeCChar '\'' = "\\'"
escapeCChar c | isCChar c = [c]
              | otherwise = escapeChar c

-- | @isSChar c@ returns true if c is a source character which does not have to be escaped in C string
--  literals (C99: 6.4.5)
isSChar :: Char -> Bool
isSChar '\\' = False
isSChar '\"' = False
isSChar '\n' = False
isSChar c = isAsciiSourceChar c

escapeChar :: Char -> String
escapeChar '\\' = "\\\\"
escapeChar '\a' = "\\a"
escapeChar '\b' = "\\b"
escapeChar '\ESC' = "\\e";
escapeChar '\f' = "\\f"
escapeChar '\n' = "\\n"
escapeChar '\r' = "\\r"
escapeChar '\t' = "\\t"
escapeChar '\v' = "\\v"
escapeChar c  | (ord c) < 512   = '\\' : showOct (ord c) ""
              | otherwise       = '\\' : 'x'  : showHex (ord c) ""

unescapeChar :: String -> (Char, String)
unescapeChar ('\\':c:cs)  = case c of
       'n'  -> ('\n', cs)
       't'  -> ('\t', cs)
       'v'  -> ('\v', cs)
       'b'  -> ('\b', cs)
       'r'  -> ('\r', cs)
       'f'  -> ('\f', cs)
       'a'  -> ('\a', cs)
       'e'  -> ('\ESC', cs)  -- GNU extension
       'E'  -> ('\ESC', cs)  -- GNU extension
       '\\' -> ('\\', cs)
       '?'  -> ('?', cs)
       '\'' -> ('\'', cs)
       '"'  -> ('"', cs)
       'x'  -> case head' "bad escape sequence" (readHex cs) of
                 (i, cs') -> (toEnum i, cs')
       _    -> case head' "bad escape sequence" (readOct (c:cs)) of
                 (i, cs') -> (toEnum i, cs')
unescapeChar (c   :cs)    = (c, cs)
unescapeChar []  = error $ "unescape char: empty string"

unescapeString :: String -> String
unescapeString [] = []
unescapeString cs = case unescapeChar cs of
                        (c, cs') -> c : unescapeString cs'

-- helpers
sQuote :: String -> ShowS
sQuote s t = "'" ++ s ++ "'" ++ t
dQuote :: String -> ShowS
dQuote s t = ('"' : s) ++ "\"" ++ t
head' :: String -> [a] -> a
head' err []  = error err
head' _ (x:_) = x

-- TODO: Move to seperate file ?
newtype Flags f = Flags Integer deriving (Eq,Ord,Data,Typeable)
noFlags :: Flags f
noFlags = Flags 0
setFlag :: (Enum f) => f -> Flags f -> Flags f
setFlag flag (Flags k)   = Flags$ k  `setBit` fromEnum flag
clearFlag :: (Enum f) => f -> Flags f -> Flags f
clearFlag flag (Flags k) = Flags$ k `clearBit` fromEnum flag
testFlag :: (Enum f) => f -> Flags f -> Bool
testFlag flag (Flags k)  = k `testBit` fromEnum flag