-----------------------------------------------------------------------------
-- |
-- 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
(HashDefine -> HashDefine -> Bool)
-> (HashDefine -> HashDefine -> Bool) -> Eq HashDefine
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
(Int -> HashDefine -> ShowS)
-> (HashDefine -> String)
-> ([HashDefine] -> ShowS)
-> Show HashDefine
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 :: String -> String -> Int -> HashDefine
SymbolReplacement
         { name :: String
name=String
forall a. HasCallStack => a
undefined, replacement :: String
replacement=String
forall a. HasCallStack => a
undefined, linebreaks :: Int
linebreaks=Int
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
(ArgOrText -> ArgOrText -> Bool)
-> (ArgOrText -> ArgOrText -> Bool) -> Eq ArgOrText
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
(Int -> ArgOrText -> ShowS)
-> (ArgOrText -> String)
-> ([ArgOrText] -> ShowS)
-> Show ArgOrText
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 = [String] -> [String] -> [(String, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip (HashDefine -> [String]
arguments HashDefine
macro) [String]
parameters
        replace :: (ArgOrText, String) -> String
replace (ArgOrText
Arg,String
s)  = String -> ShowS -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String
"")      ShowS
forall a. a -> a
id (String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
s [(String, String)]
env)
        replace (ArgOrText
Str,String
s)  = String -> ShowS -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ShowS
str String
"") ShowS
str (String -> [(String, String)] -> Maybe String
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 (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'\n') String
s
        str :: ShowS
str String
s = Char
'"'Char -> ShowS
forall a. a -> [a] -> [a]
:String
sString -> ShowS
forall a. [a] -> [a] -> [a]
++String
"\""
        checkArity :: a -> a
checkArity | [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (HashDefine -> [String]
arguments HashDefine
macro) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
parameters Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1
                   Bool -> Bool -> Bool
|| [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (HashDefine -> [String]
arguments HashDefine
macro) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
parameters = a -> a
forall a. a -> a
id
                   | Bool
otherwise = String -> a -> a
forall a. HasCallStack => String -> a
error (String
"macro "String -> ShowS
forall a. [a] -> [a] -> [a]
++HashDefine -> String
name HashDefine
macroString -> ShowS
forall a. [a] -> [a] -> [a]
++String
" expected "String -> ShowS
forall a. [a] -> [a] -> [a]
++
                                        Int -> String
forall a. Show a => a -> String
show ([String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (HashDefine -> [String]
arguments HashDefine
macro))String -> ShowS
forall a. [a] -> [a] -> [a]
++
                                        String
" arguments, but was given "String -> ShowS
forall a. [a] -> [a] -> [a]
++
                                        Int -> String
forall a. Show a => a -> String
show ([String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
parameters))
    in
    ShowS
forall a. a -> a
checkArity ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ((ArgOrText, String) -> String) -> [(ArgOrText, String)] -> String
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 ([String] -> Maybe HashDefine)
-> ([String] -> [String]) -> [String] -> Maybe HashDefine
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
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) | (Char -> Bool) -> t Char -> Bool
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)   = HashDefine -> Maybe HashDefine
forall a. a -> Maybe a
Just (String -> HashDefine
LineDrop (String
"#line"String -> ShowS
forall a. [a] -> [a] -> [a]
++[String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
xs))
    command (String
"pragma":[String]
xs) = HashDefine -> Maybe HashDefine
forall a. a -> Maybe a
Just (String -> HashDefine
Pragma (String
"#pragma"String -> ShowS
forall a. [a] -> [a] -> [a]
++[String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
xs))
    command (String
"define":[String]
xs) = HashDefine -> Maybe HashDefine
forall a. a -> Maybe a
Just ((([String] -> HashDefine
define ([String] -> HashDefine)
-> ([String] -> [String]) -> [String] -> HashDefine
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall (t :: * -> *). Foldable t => [t Char] -> [t Char]
skip) [String]
xs) { linebreaks :: Int
linebreaks=[String] -> Int
count [String]
def })
    command (String
"undef":[String]
xs)  = HashDefine -> Maybe HashDefine
forall a. a -> Maybe a
Just ((([String] -> HashDefine
undef  ([String] -> HashDefine)
-> ([String] -> [String]) -> [String] -> HashDefine
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall (t :: * -> *). Foldable t => [t Char] -> [t Char]
skip) [String]
xs))
    command [String]
_             = Maybe HashDefine
forall a. Maybe a
Nothing
    undef :: [String] -> HashDefine
undef  (String
sym:[String]
_)   = AntiDefined :: String -> Int -> HashDefine
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 [] ([String] -> HashDefine)
-> ([String] -> [String]) -> [String] -> HashDefine
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall (t :: * -> *). Foldable t => [t Char] -> [t Char]
skip) [String]
ys
                           [String]
ys   -> HashDefine
symbolReplacement
                                     { name :: String
name=String
sym
                                     , replacement :: String
replacement = ((ArgOrText, String) -> String) -> [(ArgOrText, String)] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ArgOrText, String) -> String
forall a b. (a, b) -> b
snd
                                             ([String] -> [String] -> [(ArgOrText, String)]
forall (t :: * -> *).
Foldable t =>
t String -> [String] -> [(ArgOrText, String)]
classifyRhs [] ([String] -> [String]
chop ([String] -> [String]
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 ([String] -> HashDefine)
-> ([String] -> [String]) -> [String] -> HashDefine
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall (t :: * -> *). Foldable t => [t Char] -> [t Char]
skip) [String]
xs
    macroHead String
sym [String]
args (String
")":[String]
xs) = MacroExpansion :: String -> [String] -> [(ArgOrText, String)] -> Int -> HashDefine
MacroExpansion
                                    { name :: String
name =String
sym , arguments :: [String]
arguments = [String] -> [String]
forall a. [a] -> [a]
reverse [String]
args
                                    , expansion :: [(ArgOrText, String)]
expansion = [String] -> [String] -> [(ArgOrText, String)]
forall (t :: * -> *).
Foldable t =>
t String -> [String] -> [(ArgOrText, String)]
classifyRhs [String]
args ([String] -> [String]
forall (t :: * -> *). Foldable t => [t Char] -> [t Char]
skip [String]
xs)
                                    , linebreaks :: Int
linebreaks = Int
forall a. HasCallStack => a
undefined }
    macroHead String
sym [String]
args (String
var:[String]
xs) = (String -> [String] -> [String] -> HashDefine
macroHead String
sym (String
varString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
args) ([String] -> HashDefine)
-> ([String] -> [String]) -> [String] -> HashDefine
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall (t :: * -> *). Foldable t => [t Char] -> [t Char]
skip) [String]
xs
    macroHead String
sym [String]
args []       = String -> HashDefine
forall a. HasCallStack => String -> a
error (String
"incomplete macro definition:\n"
                                        String -> ShowS
forall a. [a] -> [a] -> [a]
++String
"  #define "String -> ShowS
forall a. [a] -> [a] -> [a]
++String
symString -> ShowS
forall a. [a] -> [a] -> [a]
++String
"("
                                        String -> ShowS
forall a. [a] -> [a] -> [a]
++String -> [String] -> String
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 String -> t String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t String
args    = (ArgOrText
Str,String
x)(ArgOrText, String)
-> [(ArgOrText, String)] -> [(ArgOrText, String)]
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
&& (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
s Bool -> Bool -> Bool
&& (Char -> Bool) -> String -> 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 String -> t String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t String
args = (ArgOrText
Arg,String
word)(ArgOrText, String)
-> [(ArgOrText, String)] -> [(ArgOrText, String)]
forall a. a -> [a] -> [a]
: t String -> [String] -> [(ArgOrText, String)]
classifyRhs t String
args [String]
xs
                          | Bool
otherwise        = (ArgOrText
Text,String
word)(ArgOrText, String)
-> [(ArgOrText, String)] -> [(ArgOrText, String)]
forall a. a -> [a] -> [a]
: t String -> [String] -> [(ArgOrText, String)]
classifyRhs t String
args [String]
xs
    classifyRhs t String
_    []                      = []
    count :: [String] -> Int
count = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int) -> ([String] -> String) -> [String] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\n') ShowS -> ([String] -> String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    chop :: [String] -> [String]
chop  = [String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace) ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
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 = (HashDefine -> [(String, String)])
-> [HashDefine] -> [(String, String)]
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
hdString -> ShowS
forall a. [a] -> [a] -> [a]
++String
"("String -> ShowS
forall a. [a] -> [a] -> [a]
++String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," (HashDefine -> [String]
arguments HashDefine
hd)
                                           String -> ShowS
forall a. [a] -> [a] -> [a]
++String
")"
                                   ,((ArgOrText, String) -> String) -> [(ArgOrText, String)] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ArgOrText, String) -> String
forall a b. (a, b) -> b
snd (HashDefine -> [(ArgOrText, String)]
expansion HashDefine
hd))]