module Language.Preprocessor.Cpphs.MacroPass
( macroPass
, preDefine
, defineMacro
, macroPassReturningSymTab
) where
import Language.Preprocessor.Cpphs.HashDefine (HashDefine(..), expandMacro
, simplifyHashDefines)
import Language.Preprocessor.Cpphs.Tokenise (tokenise, WordStyle(..)
, parseMacroCall)
import Language.Preprocessor.Cpphs.SymTab (SymTab, lookupST, insertST
, emptyST, flattenST)
import Language.Preprocessor.Cpphs.Position (Posn, newfile, filename, lineno)
import Language.Preprocessor.Cpphs.Options (BoolOptions(..))
import System.IO.Unsafe (unsafeInterleaveIO)
import Control.Monad ((=<<))
import Data.Time.Clock (getCurrentTime)
import Data.Time.Format (formatTime)
import TimeCompat (defaultTimeLocale)
noPos :: Posn
noPos :: Posn
noPos = String -> Posn
newfile String
"preDefined"
macroPass :: [(String,String)]
-> BoolOptions
-> [(Posn,String)]
-> IO String
macroPass :: [(String, String)] -> BoolOptions -> [(Posn, String)] -> IO String
macroPass [(String, String)]
syms BoolOptions
options =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall {a}. [a] -> [a]
safetail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [Either a b] -> [b]
onlyRights)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess (BoolOptions -> Bool
pragma BoolOptions
options) (BoolOptions -> Bool
layout BoolOptions
options) (BoolOptions -> Bool
lang BoolOptions
options)
(BoolOptions -> [(String, String)] -> SymTab HashDefine
preDefine BoolOptions
options [(String, String)]
syms)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool -> Bool -> Bool -> [(Posn, String)] -> [WordStyle]
tokenise (BoolOptions -> Bool
stripEol BoolOptions
options) (BoolOptions -> Bool
stripC89 BoolOptions
options)
(BoolOptions -> Bool
ansi BoolOptions
options) (BoolOptions -> Bool
lang BoolOptions
options)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Posn
noPos,String
"")forall a. a -> [a] -> [a]
:)
where
safetail :: [a] -> [a]
safetail [] = []
safetail (a
_:[a]
xs) = [a]
xs
onlyRights :: [Either a b] -> [b]
onlyRights :: forall a b. [Either a b] -> [b]
onlyRights = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Either a b
x->case Either a b
x of Right b
t-> [b
t]; Left a
_-> [];)
macroPassReturningSymTab
:: [(String,String)]
-> BoolOptions
-> [(Posn,String)]
-> IO (String,[(String,String)])
macroPassReturningSymTab :: [(String, String)]
-> BoolOptions
-> [(Posn, String)]
-> IO (String, [(String, String)])
macroPassReturningSymTab [(String, String)]
syms BoolOptions
options =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall {t} {a} {b}. (t -> a) -> (t, b) -> (a, b)
mapFst (forall {a}. [a] -> [a]
safetail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}.
[Either (SymTab HashDefine) a] -> ([a], [(String, String)])
walk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess (BoolOptions -> Bool
pragma BoolOptions
options) (BoolOptions -> Bool
layout BoolOptions
options) (BoolOptions -> Bool
lang BoolOptions
options)
(BoolOptions -> [(String, String)] -> SymTab HashDefine
preDefine BoolOptions
options [(String, String)]
syms)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool -> Bool -> Bool -> [(Posn, String)] -> [WordStyle]
tokenise (BoolOptions -> Bool
stripEol BoolOptions
options) (BoolOptions -> Bool
stripC89 BoolOptions
options)
(BoolOptions -> Bool
ansi BoolOptions
options) (BoolOptions -> Bool
lang BoolOptions
options)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Posn
noPos,String
"")forall a. a -> [a] -> [a]
:)
where
safetail :: [a] -> [a]
safetail [] = []
safetail (a
_:[a]
xs) = [a]
xs
walk :: [Either (SymTab HashDefine) a] -> ([a], [(String, String)])
walk (Right a
x: [Either (SymTab HashDefine) a]
rest) = let ([a]
xs, [(String, String)]
foo) = [Either (SymTab HashDefine) a] -> ([a], [(String, String)])
walk [Either (SymTab HashDefine) a]
rest
in (a
xforall a. a -> [a] -> [a]
:[a]
xs, [(String, String)]
foo)
walk (Left SymTab HashDefine
x: []) = ( [] , [HashDefine] -> [(String, String)]
simplifyHashDefines (forall v. SymTab v -> [v]
flattenST SymTab HashDefine
x) )
walk (Left SymTab HashDefine
x: [Either (SymTab HashDefine) a]
rest) = [Either (SymTab HashDefine) a] -> ([a], [(String, String)])
walk [Either (SymTab HashDefine) a]
rest
mapFst :: (t -> a) -> (t, b) -> (a, b)
mapFst t -> a
f (t
a,b
b) = (t -> a
f t
a, b
b)
preDefine :: BoolOptions -> [(String,String)] -> SymTab HashDefine
preDefine :: BoolOptions -> [(String, String)] -> SymTab HashDefine
preDefine BoolOptions
options [(String, String)]
defines =
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall v. (String, v) -> SymTab v -> SymTab v
insertST forall b c a. (b -> c) -> (a -> b) -> a -> c
. BoolOptions -> String -> (String, HashDefine)
defineMacro BoolOptions
options forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\ (String
s,String
d)-> String
sforall a. [a] -> [a] -> [a]
++String
" "forall a. [a] -> [a] -> [a]
++String
d))
forall v. SymTab v
emptyST [(String, String)]
defines
defineMacro :: BoolOptions -> String -> (String,HashDefine)
defineMacro :: BoolOptions -> String -> (String, HashDefine)
defineMacro BoolOptions
opts String
s =
let (Cmd (Just HashDefine
hd):[WordStyle]
_) = Bool -> Bool -> Bool -> Bool -> [(Posn, String)] -> [WordStyle]
tokenise Bool
True Bool
True (BoolOptions -> Bool
ansi BoolOptions
opts) (BoolOptions -> Bool
lang BoolOptions
opts)
[(Posn
noPos,String
"\n#define "forall a. [a] -> [a] -> [a]
++String
sforall a. [a] -> [a] -> [a]
++String
"\n")]
in (HashDefine -> String
name HashDefine
hd, HashDefine
hd)
macroProcess :: Bool -> Bool -> Bool -> SymTab HashDefine -> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess :: Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess Bool
_ Bool
_ Bool
_ SymTab HashDefine
st [] = forall (m :: * -> *) a. Monad m => a -> m a
return [forall a b. a -> Either a b
Left SymTab HashDefine
st]
macroProcess Bool
p Bool
y Bool
l SymTab HashDefine
st (Other String
x: [WordStyle]
ws) = forall a b. a -> IO [Either b a] -> IO [Either b a]
emit String
x forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess Bool
p Bool
y Bool
l SymTab HashDefine
st [WordStyle]
ws
macroProcess Bool
p Bool
y Bool
l SymTab HashDefine
st (Cmd Maybe HashDefine
Nothing: [WordStyle]
ws) = forall a b. a -> IO [Either b a] -> IO [Either b a]
emit String
"\n" forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess Bool
p Bool
y Bool
l SymTab HashDefine
st [WordStyle]
ws
macroProcess Bool
p Bool
y Bool
l SymTab HashDefine
st (Cmd (Just (LineDrop String
x)): [WordStyle]
ws)
= forall a b. a -> IO [Either b a] -> IO [Either b a]
emit String
"\n" forall a b. (a -> b) -> a -> b
$
forall a b. a -> IO [Either b a] -> IO [Either b a]
emit String
x forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess Bool
p Bool
y Bool
l SymTab HashDefine
st [WordStyle]
ws
macroProcess Bool
pragma Bool
y Bool
l SymTab HashDefine
st (Cmd (Just (Pragma String
x)): [WordStyle]
ws)
| Bool
pragma = forall a b. a -> IO [Either b a] -> IO [Either b a]
emit String
"\n" forall a b. (a -> b) -> a -> b
$ forall a b. a -> IO [Either b a] -> IO [Either b a]
emit String
x forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess Bool
pragma Bool
y Bool
l SymTab HashDefine
st [WordStyle]
ws
| Bool
otherwise = forall a b. a -> IO [Either b a] -> IO [Either b a]
emit String
"\n" forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess Bool
pragma Bool
y Bool
l SymTab HashDefine
st [WordStyle]
ws
macroProcess Bool
p Bool
layout Bool
lang SymTab HashDefine
st (Cmd (Just HashDefine
hd): [WordStyle]
ws) =
let n :: Int
n = Int
1 forall a. Num a => a -> a -> a
+ HashDefine -> Int
linebreaks HashDefine
hd
newST :: SymTab HashDefine
newST = forall v. (String, v) -> SymTab v -> SymTab v
insertST (HashDefine -> String
name HashDefine
hd, HashDefine
hd) SymTab HashDefine
st
in
forall a b. a -> IO [Either b a] -> IO [Either b a]
emit (forall a. Int -> a -> [a]
replicate Int
n Char
'\n') forall a b. (a -> b) -> a -> b
$
forall b a. b -> IO [Either b a] -> IO [Either b a]
emitSymTab SymTab HashDefine
newST forall a b. (a -> b) -> a -> b
$
Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess Bool
p Bool
layout Bool
lang SymTab HashDefine
newST [WordStyle]
ws
macroProcess Bool
pr Bool
layout Bool
lang SymTab HashDefine
st (Ident Posn
p String
x: [WordStyle]
ws) =
case String
x of
String
"__FILE__" -> forall a b. a -> IO [Either b a] -> IO [Either b a]
emit (forall a. Show a => a -> String
show (Posn -> String
filename Posn
p))forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess Bool
pr Bool
layout Bool
lang SymTab HashDefine
st [WordStyle]
ws
String
"__LINE__" -> forall a b. a -> IO [Either b a] -> IO [Either b a]
emit (forall a. Show a => a -> String
show (Posn -> Int
lineno Posn
p)) forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess Bool
pr Bool
layout Bool
lang SymTab HashDefine
st [WordStyle]
ws
String
"__DATE__" -> do String
w <- forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"\"%d %b %Y\""
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO UTCTime
getCurrentTime
forall a b. a -> IO [Either b a] -> IO [Either b a]
emit String
w forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess Bool
pr Bool
layout Bool
lang SymTab HashDefine
st [WordStyle]
ws
String
"__TIME__" -> do String
w <- forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"\"%H:%M:%S\""
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO UTCTime
getCurrentTime
forall a b. a -> IO [Either b a] -> IO [Either b a]
emit String
w forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess Bool
pr Bool
layout Bool
lang SymTab HashDefine
st [WordStyle]
ws
String
_ ->
case forall v. String -> SymTab v -> Maybe v
lookupST String
x SymTab HashDefine
st of
Maybe HashDefine
Nothing -> forall a b. a -> IO [Either b a] -> IO [Either b a]
emit String
x forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess Bool
pr Bool
layout Bool
lang SymTab HashDefine
st [WordStyle]
ws
Just HashDefine
hd ->
case HashDefine
hd of
AntiDefined {name :: HashDefine -> String
name=String
n} -> forall a b. a -> IO [Either b a] -> IO [Either b a]
emit String
n forall a b. (a -> b) -> a -> b
$
Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess Bool
pr Bool
layout Bool
lang SymTab HashDefine
st [WordStyle]
ws
SymbolReplacement {replacement :: HashDefine -> String
replacement=String
r} ->
let r' :: String
r' = if Bool
layout then String
r else forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/=Char
'\n') String
r in
Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess Bool
pr Bool
layout Bool
lang SymTab HashDefine
st
(Bool -> Bool -> Bool -> Bool -> [(Posn, String)] -> [WordStyle]
tokenise Bool
True Bool
True Bool
False Bool
lang [(Posn
p,String
r')]
forall a. [a] -> [a] -> [a]
++ [WordStyle]
ws)
MacroExpansion {} ->
case Posn -> [WordStyle] -> Maybe ([[WordStyle]], [WordStyle])
parseMacroCall Posn
p [WordStyle]
ws of
Maybe ([[WordStyle]], [WordStyle])
Nothing -> forall a b. a -> IO [Either b a] -> IO [Either b a]
emit String
x forall a b. (a -> b) -> a -> b
$
Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess Bool
pr Bool
layout Bool
lang SymTab HashDefine
st [WordStyle]
ws
Just ([[WordStyle]]
args,[WordStyle]
ws') ->
if forall (t :: * -> *) a. Foldable t => t a -> Int
length [[WordStyle]]
args forall a. Eq a => a -> a -> Bool
/= forall (t :: * -> *) a. Foldable t => t a -> Int
length (HashDefine -> [String]
arguments HashDefine
hd) then
forall a b. a -> IO [Either b a] -> IO [Either b a]
emit String
x forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess Bool
pr Bool
layout Bool
lang SymTab HashDefine
st [WordStyle]
ws
else do [String]
args' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concatforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. [Either a b] -> [b]
onlyRights)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess Bool
pr Bool
layout
Bool
lang SymTab HashDefine
st)
[[WordStyle]]
args
Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess Bool
pr Bool
layout Bool
lang SymTab HashDefine
st
(Bool -> Bool -> Bool -> Bool -> [(Posn, String)] -> [WordStyle]
tokenise Bool
True Bool
True Bool
False Bool
lang
[(Posn
p,HashDefine -> [String] -> Bool -> String
expandMacro HashDefine
hd [String]
args' Bool
layout)]
forall a. [a] -> [a] -> [a]
++ [WordStyle]
ws')
emit :: a -> IO [Either b a] -> IO [Either b a]
emit :: forall a b. a -> IO [Either b a] -> IO [Either b a]
emit a
x IO [Either b a]
io = do [Either b a]
xs <- forall a. IO a -> IO a
unsafeInterleaveIO IO [Either b a]
io
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right a
xforall a. a -> [a] -> [a]
:[Either b a]
xs)
emitSymTab :: b -> IO [Either b a] -> IO [Either b a]
emitSymTab :: forall b a. b -> IO [Either b a] -> IO [Either b a]
emitSymTab b
x IO [Either b a]
io = do [Either b a]
xs <- forall a. IO a -> IO a
unsafeInterleaveIO IO [Either b a]
io
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left b
xforall a. a -> [a] -> [a]
:[Either b a]
xs)