-----------------------------------------------------------------------------
-- |
-- Module      :  HashDefine
-- Copyright   :  2004 Malcolm Wallace
-- Licence     :  LGPL
--
-- Maintainer  :  Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>
-- Stability   :  experimental
-- Portability :  All
--
-- What structures are declared in a \#define.
-----------------------------------------------------------------------------
 
module Language.Preprocessor.Cpphs.HashDefine
  ( HashDefine(..)
  , ArgOrText(..)
  , expandMacro
  , parseHashDefine
  , simplifyHashDefines
  ) where

import Data.Char (isSpace)
import Data.List (intercalate)

data HashDefine
        = LineDrop
                { HashDefine -> String
name :: String }
        | Pragma
                { name :: String }
        | AntiDefined
                { name          :: String
                , HashDefine -> Int
linebreaks    :: Int
                }
        | SymbolReplacement
                { name          :: String
                , HashDefine -> String
replacement   :: String
                , linebreaks    :: Int
                }
        | MacroExpansion
                { name          :: String
                , HashDefine -> [String]
arguments     :: [String]
                , HashDefine -> [(ArgOrText, String)]
expansion     :: [(ArgOrText,String)]
                , linebreaks    :: Int
                }
    deriving (HashDefine -> HashDefine -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HashDefine -> HashDefine -> Bool
$c/= :: HashDefine -> HashDefine -> Bool
== :: HashDefine -> HashDefine -> Bool
$c== :: HashDefine -> HashDefine -> Bool
Eq,Int -> HashDefine -> ShowS
[HashDefine] -> ShowS
HashDefine -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HashDefine] -> ShowS
$cshowList :: [HashDefine] -> ShowS
show :: HashDefine -> String
$cshow :: HashDefine -> String
showsPrec :: Int -> HashDefine -> ShowS
$cshowsPrec :: Int -> HashDefine -> ShowS
Show)

-- | 'smart' constructor to avoid warnings from ghc (undefined fields)
symbolReplacement :: HashDefine
symbolReplacement :: HashDefine
symbolReplacement =
    SymbolReplacement
         { name :: String
name=forall a. HasCallStack => a
undefined, replacement :: String
replacement=forall a. HasCallStack => a
undefined, linebreaks :: Int
linebreaks=forall a. HasCallStack => a
undefined }

-- | Macro expansion text is divided into sections, each of which is classified
--   as one of three kinds: a formal argument (Arg), plain text (Text),
--   or a stringised formal argument (Str).
data ArgOrText = Arg | Text | Str deriving (ArgOrText -> ArgOrText -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ArgOrText -> ArgOrText -> Bool
$c/= :: ArgOrText -> ArgOrText -> Bool
== :: ArgOrText -> ArgOrText -> Bool
$c== :: ArgOrText -> ArgOrText -> Bool
Eq,Int -> ArgOrText -> ShowS
[ArgOrText] -> ShowS
ArgOrText -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ArgOrText] -> ShowS
$cshowList :: [ArgOrText] -> ShowS
show :: ArgOrText -> String
$cshow :: ArgOrText -> String
showsPrec :: Int -> ArgOrText -> ShowS
$cshowsPrec :: Int -> ArgOrText -> ShowS
Show)

-- | Expand an instance of a macro.
--   Precondition: got a match on the macro name.
expandMacro :: HashDefine -> [String] -> Bool -> String
expandMacro :: HashDefine -> [String] -> Bool -> String
expandMacro HashDefine
macro [String]
parameters Bool
layout =
    let env :: [(String, String)]
env = forall a b. [a] -> [b] -> [(a, b)]
zip (HashDefine -> [String]
arguments HashDefine
macro) [String]
parameters
        replace :: (ArgOrText, String) -> String
replace (ArgOrText
Arg,String
s)  = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String
"")      forall a. a -> a
id (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
s [(String, String)]
env)
        replace (ArgOrText
Str,String
s)  = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ShowS
str String
"") ShowS
str (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
s [(String, String)]
env)
        replace (ArgOrText
Text,String
s) = if Bool
layout then String
s else forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/=Char
'\n') String
s
        str :: ShowS
str String
s = Char
'"'forall a. a -> [a] -> [a]
:String
sforall a. [a] -> [a] -> [a]
++String
"\""
        checkArity :: a -> a
checkArity | forall (t :: * -> *) a. Foldable t => t a -> Int
length (HashDefine -> [String]
arguments HashDefine
macro) forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
parameters forall a. Ord a => a -> a -> Bool
<= Int
1
                   Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Int
length (HashDefine -> [String]
arguments HashDefine
macro) forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
parameters = forall a. a -> a
id
                   | Bool
otherwise = forall a. HasCallStack => String -> a
error (String
"macro "forall a. [a] -> [a] -> [a]
++HashDefine -> String
name HashDefine
macroforall a. [a] -> [a] -> [a]
++String
" expected "forall a. [a] -> [a] -> [a]
++
                                        forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length (HashDefine -> [String]
arguments HashDefine
macro))forall a. [a] -> [a] -> [a]
++
                                        String
" arguments, but was given "forall a. [a] -> [a] -> [a]
++
                                        forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
parameters))
    in
    forall a. a -> a
checkArity forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ArgOrText, String) -> String
replace (HashDefine -> [(ArgOrText, String)]
expansion HashDefine
macro)

-- | Parse a \#define, or \#undef, ignoring other \# directives
parseHashDefine :: Bool -> [String] -> Maybe HashDefine
parseHashDefine :: Bool -> [String] -> Maybe HashDefine
parseHashDefine Bool
ansi [String]
def = ([String] -> Maybe HashDefine
command forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {t :: * -> *}. Foldable t => [t Char] -> [t Char]
skip) [String]
def
  where
    skip :: [t Char] -> [t Char]
skip xss :: [t Char]
xss@(t Char
x:[t Char]
xs) | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace t Char
x = [t Char] -> [t Char]
skip [t Char]
xs
                    | Bool
otherwise     = [t Char]
xss
    skip    []      = []
    command :: [String] -> Maybe HashDefine
command (String
"line":[String]
xs)   = forall a. a -> Maybe a
Just (String -> HashDefine
LineDrop (String
"#line"forall a. [a] -> [a] -> [a]
++forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
xs))
    command (String
"pragma":[String]
xs) = forall a. a -> Maybe a
Just (String -> HashDefine
Pragma (String
"#pragma"forall a. [a] -> [a] -> [a]
++forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
xs))
    command (String
"define":[String]
xs) = forall a. a -> Maybe a
Just ((([String] -> HashDefine
define forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {t :: * -> *}. Foldable t => [t Char] -> [t Char]
skip) [String]
xs) { linebreaks :: Int
linebreaks=[String] -> Int
count [String]
def })
    command (String
"undef":[String]
xs)  = forall a. a -> Maybe a
Just ((([String] -> HashDefine
undef  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {t :: * -> *}. Foldable t => [t Char] -> [t Char]
skip) [String]
xs))
    command [String]
_             = forall a. Maybe a
Nothing
    undef :: [String] -> HashDefine
undef  (String
sym:[String]
_)   = AntiDefined { name :: String
name=String
sym, linebreaks :: Int
linebreaks=Int
0 }
    define :: [String] -> HashDefine
define (String
sym:[String]
xs)  = case {-skip-} [String]
xs of
                           (String
"(":[String]
ys) -> (String -> [String] -> [String] -> HashDefine
macroHead String
sym [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {t :: * -> *}. Foldable t => [t Char] -> [t Char]
skip) [String]
ys
                           [String]
ys   -> HashDefine
symbolReplacement
                                     { name :: String
name=String
sym
                                     , replacement :: String
replacement = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd
                                             (forall {t :: * -> *}.
Foldable t =>
t String -> [String] -> [(ArgOrText, String)]
classifyRhs [] ([String] -> [String]
chop (forall {t :: * -> *}. Foldable t => [t Char] -> [t Char]
skip [String]
ys))) }
    macroHead :: String -> [String] -> [String] -> HashDefine
macroHead String
sym [String]
args (String
",":[String]
xs) = (String -> [String] -> [String] -> HashDefine
macroHead String
sym [String]
args forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {t :: * -> *}. Foldable t => [t Char] -> [t Char]
skip) [String]
xs
    macroHead String
sym [String]
args (String
")":[String]
xs) = MacroExpansion
                                    { name :: String
name =String
sym , arguments :: [String]
arguments = forall a. [a] -> [a]
reverse [String]
args
                                    , expansion :: [(ArgOrText, String)]
expansion = forall {t :: * -> *}.
Foldable t =>
t String -> [String] -> [(ArgOrText, String)]
classifyRhs [String]
args (forall {t :: * -> *}. Foldable t => [t Char] -> [t Char]
skip [String]
xs)
                                    , linebreaks :: Int
linebreaks = forall a. HasCallStack => a
undefined }
    macroHead String
sym [String]
args (String
var:[String]
xs) = (String -> [String] -> [String] -> HashDefine
macroHead String
sym (String
varforall a. a -> [a] -> [a]
:[String]
args) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {t :: * -> *}. Foldable t => [t Char] -> [t Char]
skip) [String]
xs
    macroHead String
sym [String]
args []       = forall a. HasCallStack => String -> a
error (String
"incomplete macro definition:\n"
                                        forall a. [a] -> [a] -> [a]
++String
"  #define "forall a. [a] -> [a] -> [a]
++String
symforall a. [a] -> [a] -> [a]
++String
"("
                                        forall a. [a] -> [a] -> [a]
++forall a. [a] -> [[a]] -> [a]
intercalate String
"," [String]
args)
    classifyRhs :: t String -> [String] -> [(ArgOrText, String)]
classifyRhs t String
args (String
"#":String
x:[String]
xs)
                          | Bool
ansi Bool -> Bool -> Bool
&&
                            String
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t String
args    = (ArgOrText
Str,String
x)forall a. a -> [a] -> [a]
: t String -> [String] -> [(ArgOrText, String)]
classifyRhs t String
args [String]
xs
    classifyRhs t String
args (String
"##":[String]
xs)
                          | Bool
ansi             = t String -> [String] -> [(ArgOrText, String)]
classifyRhs t String
args [String]
xs
    classifyRhs t String
args (String
s:String
"##":String
s':[String]
xs)
                          | Bool
ansi Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
s Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
s'
                                             = t String -> [String] -> [(ArgOrText, String)]
classifyRhs t String
args [String]
xs
    classifyRhs t String
args (String
word:[String]
xs)
                          | String
word forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t String
args = (ArgOrText
Arg,String
word)forall a. a -> [a] -> [a]
: t String -> [String] -> [(ArgOrText, String)]
classifyRhs t String
args [String]
xs
                          | Bool
otherwise        = (ArgOrText
Text,String
word)forall a. a -> [a] -> [a]
: t String -> [String] -> [(ArgOrText, String)]
classifyRhs t String
args [String]
xs
    classifyRhs t String
_    []                      = []
    count :: [String] -> Int
count = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
==Char
'\n') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    chop :: [String] -> [String]
chop  = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse

-- | Pretty-print hash defines to a simpler format, as key-value pairs.
simplifyHashDefines :: [HashDefine] -> [(String,String)]
simplifyHashDefines :: [HashDefine] -> [(String, String)]
simplifyHashDefines = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HashDefine -> [(String, String)]
simp
  where
    simp :: HashDefine -> [(String, String)]
simp hd :: HashDefine
hd@LineDrop{}    = []
    simp hd :: HashDefine
hd@Pragma{}      = []
    simp hd :: HashDefine
hd@AntiDefined{} = []
    simp hd :: HashDefine
hd@SymbolReplacement{} = [(HashDefine -> String
name HashDefine
hd, HashDefine -> String
replacement HashDefine
hd)]
    simp hd :: HashDefine
hd@MacroExpansion{}    = [(HashDefine -> String
name HashDefine
hdforall a. [a] -> [a] -> [a]
++String
"("forall a. [a] -> [a] -> [a]
++forall a. [a] -> [[a]] -> [a]
intercalate String
"," (HashDefine -> [String]
arguments HashDefine
hd)
                                           forall a. [a] -> [a] -> [a]
++String
")"
                                   ,forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd (HashDefine -> [(ArgOrText, String)]
expansion HashDefine
hd))]