-----------------------------------------------------------------------------
-- |
-- Module      :  CppIfdef
-- Copyright   :  1999-2004 Malcolm Wallace
-- Licence     :  LGPL
--
-- Maintainer  :  Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>
-- Stability   :  experimental
-- Portability :  All

-- Perform a cpp.first-pass, gathering \#define's and evaluating \#ifdef's.
-- and \#include's.
-----------------------------------------------------------------------------

module Language.Preprocessor.Cpphs.CppIfdef
  ( cppIfdef    -- :: FilePath -> [(String,String)] -> [String] -> Options
                --      -> String -> IO [(Posn,String)]
  ) where


import Text.Parse
import Language.Preprocessor.Cpphs.SymTab
import Language.Preprocessor.Cpphs.Position  (Posn,newfile,newline,newlines
                                             ,cppline,cpp2hask,newpos)
import Language.Preprocessor.Cpphs.ReadFirst (readFirst)
import Language.Preprocessor.Cpphs.Tokenise  (linesCpp,reslash)
import Language.Preprocessor.Cpphs.Options   (BoolOptions(..))
import Language.Preprocessor.Cpphs.HashDefine(HashDefine(..),parseHashDefine
                                             ,expandMacro)
import Language.Preprocessor.Cpphs.MacroPass (preDefine,defineMacro)
import Data.Char        (isDigit,isSpace,isAlphaNum)
import Data.List        (intercalate,isPrefixOf)
import Numeric          (readHex,readOct,readDec)
import System.IO.Unsafe (unsafeInterleaveIO)
import System.IO        (hPutStrLn,stderr)
import Control.Monad    (when)

-- | Run a first pass of cpp, evaluating \#ifdef's and processing \#include's,
--   whilst taking account of \#define's and \#undef's as we encounter them.
cppIfdef :: FilePath            -- ^ File for error reports
        -> [(String,String)]    -- ^ Pre-defined symbols and their values
        -> [String]             -- ^ Search path for \#includes
        -> BoolOptions          -- ^ Options controlling output style
        -> String               -- ^ The input file content
        -> IO [(Posn,String)]   -- ^ The file after processing (in lines)
cppIfdef :: [Char]
-> [([Char], [Char])]
-> [[Char]]
-> BoolOptions
-> [Char]
-> IO [(Posn, [Char])]
cppIfdef [Char]
fp [([Char], [Char])]
syms [[Char]]
search BoolOptions
options =
    Posn
-> SymTab HashDefine
-> [[Char]]
-> BoolOptions
-> KeepState
-> [[Char]]
-> IO [(Posn, [Char])]
cpp Posn
posn SymTab HashDefine
defs [[Char]]
search BoolOptions
options ([Posn] -> KeepState
Keep []) ([[Char]] -> IO [(Posn, [Char])])
-> ([Char] -> [[Char]]) -> [Char] -> IO [(Posn, [Char])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [[Char]]
initial ([[Char]] -> [[Char]])
-> ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
linesCpp
  where
    posn :: Posn
posn = [Char] -> Posn
newfile [Char]
fp
    defs :: SymTab HashDefine
defs = BoolOptions -> [([Char], [Char])] -> SymTab HashDefine
preDefine BoolOptions
options [([Char], [Char])]
syms
    initial :: [[Char]] -> [[Char]]
initial = if BoolOptions -> Bool
literate BoolOptions
options then [[Char]] -> [[Char]]
forall a. a -> a
id else (Posn -> [Char]
cppline Posn
posn[Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:)
-- Previous versions had a very simple symbol table  mapping strings
-- to strings.  Now the #ifdef pass uses a more elaborate table, in
-- particular to deal with parameterised macros in conditionals.


-- | Internal state for whether lines are being kept or dropped.
--   In @Drop n b ps@, @n@ is the depth of nesting, @b@ is whether
--   we have already succeeded in keeping some lines in a chain of
--   @elif@'s, and @ps@ is the stack of positions of open @#if@ contexts,
--   used for error messages in case EOF is reached too soon.
data KeepState = Keep [Posn] | Drop Int Bool [Posn]

-- | Return just the list of lines that the real cpp would decide to keep.
cpp :: Posn -> SymTab HashDefine -> [String] -> BoolOptions -> KeepState
       -> [String] -> IO [(Posn,String)]

cpp :: Posn
-> SymTab HashDefine
-> [[Char]]
-> BoolOptions
-> KeepState
-> [[Char]]
-> IO [(Posn, [Char])]
cpp Posn
_ SymTab HashDefine
_ [[Char]]
_ BoolOptions
_ (Keep [Posn]
ps) [] | Bool -> Bool
not ([Posn] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Posn]
ps) = do
    Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Unmatched #if: positions of open context are:\n"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                       [[Char]] -> [Char]
unlines ((Posn -> [Char]) -> [Posn] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Posn -> [Char]
forall a. Show a => a -> [Char]
show [Posn]
ps)
    [(Posn, [Char])] -> IO [(Posn, [Char])]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
cpp Posn
_ SymTab HashDefine
_ [[Char]]
_ BoolOptions
_ KeepState
_ [] = [(Posn, [Char])] -> IO [(Posn, [Char])]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []

cpp Posn
p SymTab HashDefine
syms [[Char]]
path BoolOptions
options (Keep [Posn]
ps) (l :: [Char]
l@(Char
'#':[Char]
x):[[Char]]
xs) =
    let ws :: [[Char]]
ws = [Char] -> [[Char]]
words [Char]
x
        cmd :: [Char]
cmd = if [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
ws then [Char]
"" else [[Char]] -> [Char]
forall a. HasCallStack => [a] -> a
head [[Char]]
ws
        line :: [[Char]]
line = if [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
ws then [] else [[Char]] -> [[Char]]
forall a. HasCallStack => [a] -> [a]
tail [[Char]]
ws
        sym :: [Char]
sym  = if [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
line then [Char]
"" else [[Char]] -> [Char]
forall a. HasCallStack => [a] -> a
head [[Char]]
line
        rest :: [[Char]]
rest = if [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
line then [] else [[Char]] -> [[Char]]
forall a. HasCallStack => [a] -> [a]
tail [[Char]]
line
        def :: ([Char], HashDefine)
def = BoolOptions -> [Char] -> ([Char], HashDefine)
defineMacro BoolOptions
options ([Char]
sym[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> ([Char] -> [Char]) -> Maybe [Char] -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"1" [Char] -> [Char]
forall a. a -> a
id ([[Char]] -> Maybe [Char]
un [[Char]]
rest))
        un :: [[Char]] -> Maybe [Char]
un [[Char]]
v = if [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
v then Maybe [Char]
forall a. Maybe a
Nothing else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([[Char]] -> [Char]
unwords [[Char]]
v)
        keepIf :: Bool -> KeepState
keepIf Bool
b = if Bool
b then [Posn] -> KeepState
Keep (Posn
pPosn -> [Posn] -> [Posn]
forall a. a -> [a] -> [a]
:[Posn]
ps) else Int -> Bool -> [Posn] -> KeepState
Drop Int
1 Bool
False (Posn
pPosn -> [Posn] -> [Posn]
forall a. a -> [a] -> [a]
:[Posn]
ps)
        skipn :: SymTab HashDefine
-> Bool -> KeepState -> [[Char]] -> IO [(Posn, [Char])]
skipn SymTab HashDefine
syms' Bool
retain KeepState
ud [[Char]]
xs' =
            let n :: Int
n = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\n') [Char]
l) in
            (if BoolOptions -> Bool
macros BoolOptions
options Bool -> Bool -> Bool
&& Bool
retain then (Posn, [Char]) -> IO [(Posn, [Char])] -> IO [(Posn, [Char])]
forall a. a -> IO [a] -> IO [a]
emitOne  (Posn
p,[Char] -> [Char]
reslash [Char]
l)
                                         else [(Posn, [Char])] -> IO [(Posn, [Char])] -> IO [(Posn, [Char])]
forall a. [a] -> IO [a] -> IO [a]
emitMany (Int -> (Posn, [Char]) -> [(Posn, [Char])]
forall a. Int -> a -> [a]
replicate Int
n (Posn
p,[Char]
""))) (IO [(Posn, [Char])] -> IO [(Posn, [Char])])
-> IO [(Posn, [Char])] -> IO [(Posn, [Char])]
forall a b. (a -> b) -> a -> b
$
            Posn
-> SymTab HashDefine
-> [[Char]]
-> BoolOptions
-> KeepState
-> [[Char]]
-> IO [(Posn, [Char])]
cpp (Int -> Posn -> Posn
newlines Int
n Posn
p) SymTab HashDefine
syms' [[Char]]
path BoolOptions
options KeepState
ud [[Char]]
xs'
    in case [Char]
cmd of
        [Char]
"define" -> SymTab HashDefine
-> Bool -> KeepState -> [[Char]] -> IO [(Posn, [Char])]
skipn (([Char], HashDefine) -> SymTab HashDefine -> SymTab HashDefine
forall v. ([Char], v) -> SymTab v -> SymTab v
insertST ([Char], HashDefine)
def SymTab HashDefine
syms) Bool
True ([Posn] -> KeepState
Keep [Posn]
ps) [[Char]]
xs
        [Char]
"undef"  -> SymTab HashDefine
-> Bool -> KeepState -> [[Char]] -> IO [(Posn, [Char])]
skipn ([Char] -> SymTab HashDefine -> SymTab HashDefine
forall v. [Char] -> SymTab v -> SymTab v
deleteST [Char]
sym SymTab HashDefine
syms) Bool
True ([Posn] -> KeepState
Keep [Posn]
ps) [[Char]]
xs
        [Char]
"ifndef" -> SymTab HashDefine
-> Bool -> KeepState -> [[Char]] -> IO [(Posn, [Char])]
skipn SymTab HashDefine
syms Bool
False (Bool -> KeepState
keepIf (Bool -> Bool
not ([Char] -> SymTab HashDefine -> Bool
forall v. [Char] -> SymTab v -> Bool
definedST [Char]
sym SymTab HashDefine
syms))) [[Char]]
xs
        [Char]
"ifdef"  -> SymTab HashDefine
-> Bool -> KeepState -> [[Char]] -> IO [(Posn, [Char])]
skipn SymTab HashDefine
syms Bool
False (Bool -> KeepState
keepIf      ([Char] -> SymTab HashDefine -> Bool
forall v. [Char] -> SymTab v -> Bool
definedST [Char]
sym SymTab HashDefine
syms)) [[Char]]
xs
        [Char]
"if"     -> do b <- Posn -> SymTab HashDefine -> [Char] -> IO Bool
gatherDefined Posn
p SymTab HashDefine
syms ([[Char]] -> [Char]
unwords [[Char]]
line)
                       skipn syms False (keepIf b) xs
        [Char]
"else"   -> SymTab HashDefine
-> Bool -> KeepState -> [[Char]] -> IO [(Posn, [Char])]
skipn SymTab HashDefine
syms Bool
False (Int -> Bool -> [Posn] -> KeepState
Drop Int
1 Bool
False [Posn]
ps) [[Char]]
xs
        [Char]
"elif"   -> SymTab HashDefine
-> Bool -> KeepState -> [[Char]] -> IO [(Posn, [Char])]
skipn SymTab HashDefine
syms Bool
False (Int -> Bool -> [Posn] -> KeepState
Drop Int
1 Bool
True [Posn]
ps) [[Char]]
xs
        [Char]
"endif"  | [Posn] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Posn]
ps ->
                    do Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Unmatched #endif at "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Posn -> [Char]
forall a. Show a => a -> [Char]
show Posn
p
                       [(Posn, [Char])] -> IO [(Posn, [Char])]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
        [Char]
"endif"  -> SymTab HashDefine
-> Bool -> KeepState -> [[Char]] -> IO [(Posn, [Char])]
skipn SymTab HashDefine
syms Bool
False ([Posn] -> KeepState
Keep ([Posn] -> [Posn]
forall a. HasCallStack => [a] -> [a]
tail [Posn]
ps)) [[Char]]
xs
        [Char]
"pragma" -> SymTab HashDefine
-> Bool -> KeepState -> [[Char]] -> IO [(Posn, [Char])]
skipn SymTab HashDefine
syms Bool
True  ([Posn] -> KeepState
Keep [Posn]
ps) [[Char]]
xs
        (Char
'!':[Char]
_)  -> SymTab HashDefine
-> Bool -> KeepState -> [[Char]] -> IO [(Posn, [Char])]
skipn SymTab HashDefine
syms Bool
False ([Posn] -> KeepState
Keep [Posn]
ps) [[Char]]
xs       -- \#!runhs scripts
        [Char]
"include"-> do (inc,content) <- [Char] -> Posn -> [[Char]] -> Bool -> IO ([Char], [Char])
readFirst (SymTab HashDefine -> [Char] -> [Char]
file SymTab HashDefine
syms ([[Char]] -> [Char]
unwords [[Char]]
line))
                                                  Posn
p [[Char]]
path
                                                  (BoolOptions -> Bool
warnings BoolOptions
options)
                       cpp p syms path options (Keep ps)
                             (("#line 1 "++show inc): linesCpp content
                                                    ++ cppline (newline p): xs)
        [Char]
"warning"-> if BoolOptions -> Bool
warnings BoolOptions
options then
                      do Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char]
l[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"\nin "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Posn -> [Char]
forall a. Show a => a -> [Char]
show Posn
p)
                         SymTab HashDefine
-> Bool -> KeepState -> [[Char]] -> IO [(Posn, [Char])]
skipn SymTab HashDefine
syms Bool
False ([Posn] -> KeepState
Keep [Posn]
ps) [[Char]]
xs
                    else SymTab HashDefine
-> Bool -> KeepState -> [[Char]] -> IO [(Posn, [Char])]
skipn SymTab HashDefine
syms Bool
False ([Posn] -> KeepState
Keep [Posn]
ps) [[Char]]
xs
        [Char]
"error"  -> [Char] -> IO [(Posn, [Char])]
forall a. HasCallStack => [Char] -> a
error ([Char]
l[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"\nin "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Posn -> [Char]
forall a. Show a => a -> [Char]
show Posn
p)
        [Char]
"line"   | (Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit [Char]
sym
                 -> (if BoolOptions -> Bool
locations BoolOptions
options Bool -> Bool -> Bool
&& BoolOptions -> Bool
hashline BoolOptions
options then (Posn, [Char]) -> IO [(Posn, [Char])] -> IO [(Posn, [Char])]
forall a. a -> IO [a] -> IO [a]
emitOne (Posn
p,[Char]
l)
                     else if BoolOptions -> Bool
locations BoolOptions
options then (Posn, [Char]) -> IO [(Posn, [Char])] -> IO [(Posn, [Char])]
forall a. a -> IO [a] -> IO [a]
emitOne (Posn
p,[Char] -> [Char]
cpp2hask [Char]
l)
                     else IO [(Posn, [Char])] -> IO [(Posn, [Char])]
forall a. a -> a
id) (IO [(Posn, [Char])] -> IO [(Posn, [Char])])
-> IO [(Posn, [Char])] -> IO [(Posn, [Char])]
forall a b. (a -> b) -> a -> b
$
                    Posn
-> SymTab HashDefine
-> [[Char]]
-> BoolOptions
-> KeepState
-> [[Char]]
-> IO [(Posn, [Char])]
cpp (Int -> Maybe [Char] -> Posn -> Posn
newpos ([Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
sym) ([[Char]] -> Maybe [Char]
un [[Char]]
rest) Posn
p)
                        SymTab HashDefine
syms [[Char]]
path BoolOptions
options ([Posn] -> KeepState
Keep [Posn]
ps) [[Char]]
xs
        [Char]
n | (Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit [Char]
n Bool -> Bool -> Bool
&& Bool -> Bool
not ([Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
n)
                 -> (if BoolOptions -> Bool
locations BoolOptions
options Bool -> Bool -> Bool
&& BoolOptions -> Bool
hashline BoolOptions
options then (Posn, [Char]) -> IO [(Posn, [Char])] -> IO [(Posn, [Char])]
forall a. a -> IO [a] -> IO [a]
emitOne (Posn
p,[Char]
l)
                     else if BoolOptions -> Bool
locations BoolOptions
options then (Posn, [Char]) -> IO [(Posn, [Char])] -> IO [(Posn, [Char])]
forall a. a -> IO [a] -> IO [a]
emitOne (Posn
p,[Char] -> [Char]
cpp2hask [Char]
l)
                     else IO [(Posn, [Char])] -> IO [(Posn, [Char])]
forall a. a -> a
id) (IO [(Posn, [Char])] -> IO [(Posn, [Char])])
-> IO [(Posn, [Char])] -> IO [(Posn, [Char])]
forall a b. (a -> b) -> a -> b
$
                    Posn
-> SymTab HashDefine
-> [[Char]]
-> BoolOptions
-> KeepState
-> [[Char]]
-> IO [(Posn, [Char])]
cpp (Int -> Maybe [Char] -> Posn -> Posn
newpos ([Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
n) ([[Char]] -> Maybe [Char]
un ([[Char]] -> [[Char]]
forall a. HasCallStack => [a] -> [a]
tail [[Char]]
ws)) Posn
p)
                        SymTab HashDefine
syms [[Char]]
path BoolOptions
options ([Posn] -> KeepState
Keep [Posn]
ps) [[Char]]
xs
          | Bool
otherwise
                 -> do Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BoolOptions -> Bool
warnings BoolOptions
options) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                           Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char]
"Warning: unknown directive #"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
n
                                             [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"\nin "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Posn -> [Char]
forall a. Show a => a -> [Char]
show Posn
p)
                       (Posn, [Char]) -> IO [(Posn, [Char])] -> IO [(Posn, [Char])]
forall a. a -> IO [a] -> IO [a]
emitOne (Posn
p,[Char]
l) (IO [(Posn, [Char])] -> IO [(Posn, [Char])])
-> IO [(Posn, [Char])] -> IO [(Posn, [Char])]
forall a b. (a -> b) -> a -> b
$
                               Posn
-> SymTab HashDefine
-> [[Char]]
-> BoolOptions
-> KeepState
-> [[Char]]
-> IO [(Posn, [Char])]
cpp (Posn -> Posn
newline Posn
p) SymTab HashDefine
syms [[Char]]
path BoolOptions
options ([Posn] -> KeepState
Keep [Posn]
ps) [[Char]]
xs

cpp Posn
p SymTab HashDefine
syms [[Char]]
path BoolOptions
options (Drop Int
n Bool
b [Posn]
ps) ((Char
'#':[Char]
x):[[Char]]
xs) =
    let ws :: [[Char]]
ws = [Char] -> [[Char]]
words [Char]
x
        cmd :: [Char]
cmd = if [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
ws then [Char]
"" else [[Char]] -> [Char]
forall a. HasCallStack => [a] -> a
head [[Char]]
ws
        delse :: KeepState
delse    | Int
nInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
1 Bool -> Bool -> Bool
&& Bool
b = Int -> Bool -> [Posn] -> KeepState
Drop Int
1 Bool
b [Posn]
ps
                 | Int
nInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
1      = [Posn] -> KeepState
Keep [Posn]
ps
                 | Bool
otherwise = Int -> Bool -> [Posn] -> KeepState
Drop Int
n Bool
b [Posn]
ps
        dend :: KeepState
dend     | Int
nInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
1      = [Posn] -> KeepState
Keep ([Posn] -> [Posn]
forall a. HasCallStack => [a] -> [a]
tail [Posn]
ps)
                 | Bool
otherwise = Int -> Bool -> [Posn] -> KeepState
Drop (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Bool
b ([Posn] -> [Posn]
forall a. HasCallStack => [a] -> [a]
tail [Posn]
ps)
        delif :: Bool -> KeepState
delif Bool
v  | Int
nInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
1 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
b Bool -> Bool -> Bool
&& Bool
v
                             = [Posn] -> KeepState
Keep [Posn]
ps
                 | Bool
otherwise = Int -> Bool -> [Posn] -> KeepState
Drop Int
n Bool
b [Posn]
ps
        skipn :: KeepState -> [[Char]] -> IO [(Posn, [Char])]
skipn KeepState
ud [[Char]]
xs' =
                 let n' :: Int
n' = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\n') [Char]
x) in
                 [(Posn, [Char])] -> IO [(Posn, [Char])] -> IO [(Posn, [Char])]
forall a. [a] -> IO [a] -> IO [a]
emitMany (Int -> (Posn, [Char]) -> [(Posn, [Char])]
forall a. Int -> a -> [a]
replicate Int
n' (Posn
p,[Char]
"")) (IO [(Posn, [Char])] -> IO [(Posn, [Char])])
-> IO [(Posn, [Char])] -> IO [(Posn, [Char])]
forall a b. (a -> b) -> a -> b
$
                    Posn
-> SymTab HashDefine
-> [[Char]]
-> BoolOptions
-> KeepState
-> [[Char]]
-> IO [(Posn, [Char])]
cpp (Int -> Posn -> Posn
newlines Int
n' Posn
p) SymTab HashDefine
syms [[Char]]
path BoolOptions
options KeepState
ud [[Char]]
xs'
    in
    if      [Char]
cmd [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"ifndef" Bool -> Bool -> Bool
||
            [Char]
cmd [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"if"     Bool -> Bool -> Bool
||
            [Char]
cmd [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"ifdef" then    KeepState -> [[Char]] -> IO [(Posn, [Char])]
skipn (Int -> Bool -> [Posn] -> KeepState
Drop (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Bool
b (Posn
pPosn -> [Posn] -> [Posn]
forall a. a -> [a] -> [a]
:[Posn]
ps)) [[Char]]
xs
    else if [Char]
cmd [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"elif"  then do v <- Posn -> SymTab HashDefine -> [Char] -> IO Bool
gatherDefined Posn
p SymTab HashDefine
syms ([[Char]] -> [Char]
unwords ([[Char]] -> [[Char]]
forall a. HasCallStack => [a] -> [a]
tail [[Char]]
ws))
                                   skipn (delif v) xs
    else if [Char]
cmd [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"else"  then    KeepState -> [[Char]] -> IO [(Posn, [Char])]
skipn  KeepState
delse [[Char]]
xs
    else if [Char]
cmd [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"endif" then
            if [Posn] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Posn]
ps then do Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Unmatched #endif at "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Posn -> [Char]
forall a. Show a => a -> [Char]
show Posn
p
                               [(Posn, [Char])] -> IO [(Posn, [Char])]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
                       else KeepState -> [[Char]] -> IO [(Posn, [Char])]
skipn  KeepState
dend  [[Char]]
xs
    else KeepState -> [[Char]] -> IO [(Posn, [Char])]
skipn (Int -> Bool -> [Posn] -> KeepState
Drop Int
n Bool
b [Posn]
ps) [[Char]]
xs
        -- define, undef, include, error, warning, pragma, line

cpp Posn
p SymTab HashDefine
syms [[Char]]
path BoolOptions
options (Keep [Posn]
ps) ([Char]
x:[[Char]]
xs) =
    let p' :: Posn
p' = Posn -> Posn
newline Posn
p in Posn -> IO [(Posn, [Char])] -> IO [(Posn, [Char])]
forall a b. a -> b -> b
seq Posn
p' (IO [(Posn, [Char])] -> IO [(Posn, [Char])])
-> IO [(Posn, [Char])] -> IO [(Posn, [Char])]
forall a b. (a -> b) -> a -> b
$
    (Posn, [Char]) -> IO [(Posn, [Char])] -> IO [(Posn, [Char])]
forall a. a -> IO [a] -> IO [a]
emitOne (Posn
p,[Char]
x)  (IO [(Posn, [Char])] -> IO [(Posn, [Char])])
-> IO [(Posn, [Char])] -> IO [(Posn, [Char])]
forall a b. (a -> b) -> a -> b
$  Posn
-> SymTab HashDefine
-> [[Char]]
-> BoolOptions
-> KeepState
-> [[Char]]
-> IO [(Posn, [Char])]
cpp Posn
p' SymTab HashDefine
syms [[Char]]
path BoolOptions
options ([Posn] -> KeepState
Keep [Posn]
ps) [[Char]]
xs
cpp Posn
p SymTab HashDefine
syms [[Char]]
path BoolOptions
options d :: KeepState
d@(Drop Int
_ Bool
_ [Posn]
_) ([Char]
_:[[Char]]
xs) =
    let p' :: Posn
p' = Posn -> Posn
newline Posn
p in Posn -> IO [(Posn, [Char])] -> IO [(Posn, [Char])]
forall a b. a -> b -> b
seq Posn
p' (IO [(Posn, [Char])] -> IO [(Posn, [Char])])
-> IO [(Posn, [Char])] -> IO [(Posn, [Char])]
forall a b. (a -> b) -> a -> b
$
    (Posn, [Char]) -> IO [(Posn, [Char])] -> IO [(Posn, [Char])]
forall a. a -> IO [a] -> IO [a]
emitOne (Posn
p,[Char]
"") (IO [(Posn, [Char])] -> IO [(Posn, [Char])])
-> IO [(Posn, [Char])] -> IO [(Posn, [Char])]
forall a b. (a -> b) -> a -> b
$  Posn
-> SymTab HashDefine
-> [[Char]]
-> BoolOptions
-> KeepState
-> [[Char]]
-> IO [(Posn, [Char])]
cpp Posn
p' SymTab HashDefine
syms [[Char]]
path BoolOptions
options KeepState
d [[Char]]
xs


-- | Auxiliary IO functions
emitOne  ::  a  -> IO [a] -> IO [a]
emitMany :: [a] -> IO [a] -> IO [a]
emitOne :: forall a. a -> IO [a] -> IO [a]
emitOne  a
x  IO [a]
io = do ys <- IO [a] -> IO [a]
forall a. IO a -> IO a
unsafeInterleaveIO IO [a]
io
                    return (x:ys)
emitMany :: forall a. [a] -> IO [a] -> IO [a]
emitMany [a]
xs IO [a]
io = do ys <- IO [a] -> IO [a]
forall a. IO a -> IO a
unsafeInterleaveIO IO [a]
io
                    return (xs++ys)


----
gatherDefined :: Posn -> SymTab HashDefine -> String -> IO Bool
gatherDefined :: Posn -> SymTab HashDefine -> [Char] -> IO Bool
gatherDefined Posn
p SymTab HashDefine
st [Char]
inp =
  case Parser Char [Char] -> [Char] -> (Either [Char] [Char], [Char])
forall t a. Parser t a -> [t] -> (Either [Char] a, [t])
runParser (SymTab HashDefine -> Parser Char [Char]
preExpand SymTab HashDefine
st) [Char]
inp of
    (Left [Char]
msg, [Char]
_) -> [Char] -> IO Bool
forall a. HasCallStack => [Char] -> a
error ([Char]
"Cannot expand #if directive in file "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Posn -> [Char]
forall a. Show a => a -> [Char]
show Posn
p
                           [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
":\n    "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
msg)
    (Right [Char]
s, [Char]
xs) -> do
--      hPutStrLn stderr $ "Expanded #if at "++show p++" is:\n  "++s
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace) [Char]
xs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
             Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char]
"Warning: trailing characters after #if"
                              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" macro expansion in file "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Posn -> [Char]
forall a. Show a => a -> [Char]
show Posn
p[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
": "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
xs)

        case Parser Char Bool -> [Char] -> (Either [Char] Bool, [Char])
forall t a. Parser t a -> [t] -> (Either [Char] a, [t])
runParser Parser Char Bool
parseBoolExp [Char]
s of
          (Left [Char]
msg, [Char]
_) -> [Char] -> IO Bool
forall a. HasCallStack => [Char] -> a
error ([Char]
"Cannot parse #if directive in file "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Posn -> [Char]
forall a. Show a => a -> [Char]
show Posn
p
                                 [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
":\n    "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
msg)
          (Right Bool
b, [Char]
xs) -> do Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace) [Char]
xs Bool -> Bool -> Bool
&& [Char] -> Bool
notComment [Char]
xs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                                   Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr
                                     ([Char]
"Warning: trailing characters after #if"
                                      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" directive in file "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Posn -> [Char]
forall a. Show a => a -> [Char]
show Posn
p[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
": "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
xs)
                              Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
b

notComment :: [Char] -> Bool
notComment = Bool -> Bool
not (Bool -> Bool) -> ([Char] -> Bool) -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"//"[Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) ([Char] -> Bool) -> ([Char] -> [Char]) -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace


-- | The preprocessor must expand all macros (recursively) before evaluating
--   the conditional.
preExpand :: SymTab HashDefine -> TextParser String
preExpand :: SymTab HashDefine -> Parser Char [Char]
preExpand SymTab HashDefine
st =
  do  Parser Char ()
forall t. Parser t ()
eof
      [Char] -> Parser Char [Char]
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
""
  Parser Char [Char] -> Parser Char [Char] -> Parser Char [Char]
forall a. Parser Char a -> Parser Char a -> Parser Char a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  do  a <- Parser Char Char -> Parser Char [Char]
forall (p :: * -> *) a. PolyParse p => p a -> p [a]
many1 ((Char -> Bool) -> Parser Char Char
forall t. (t -> Bool) -> Parser t t
satisfy Char -> Bool
notIdent)
      commit $ pure (a++) `apply` preExpand st
  Parser Char [Char] -> Parser Char [Char] -> Parser Char [Char]
forall a. Parser Char a -> Parser Char a -> Parser Char a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  do  b <- SymTab HashDefine -> Parser Char [Char]
expandSymOrCall SymTab HashDefine
st
      commit $ pure (b++) `apply` preExpand st

-- | Expansion of symbols.
expandSymOrCall :: SymTab HashDefine -> TextParser String
expandSymOrCall :: SymTab HashDefine -> Parser Char [Char]
expandSymOrCall SymTab HashDefine
st =
  do sym <- Parser Char [Char]
parseSym
     if sym=="defined" then do arg <- skip parseSym; convert sym [arg]
                            <|>
                            do arg <- skip $ parenthesis (do x <- skip parseSym;
                                                             skip (return x))
                               convert sym [arg]
                            <|> convert sym []
      else
      ( do  args <- parenthesis (commit $ fragment `sepBy` skip (isWord ","))
            args' <- flip mapM args $ \[Char]
arg->
                         case Parser Char [Char] -> [Char] -> (Either [Char] [Char], [Char])
forall t a. Parser t a -> [t] -> (Either [Char] a, [t])
runParser (SymTab HashDefine -> Parser Char [Char]
preExpand SymTab HashDefine
st) [Char]
arg of
                             (Left [Char]
msg, [Char]
_) -> [Char] -> Parser Char [Char]
forall a. HasCallStack => [Char] -> Parser Char a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail [Char]
msg
                             (Right [Char]
s, [Char]
_)  -> [Char] -> Parser Char [Char]
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
s
            convert sym args'
        <|> convert sym []
      )
  where
    fragment :: Parser Char [Char]
fragment = Parser Char Char -> Parser Char [Char]
forall (p :: * -> *) a. PolyParse p => p a -> p [a]
many1 ((Char -> Bool) -> Parser Char Char
forall t. (t -> Bool) -> Parser t t
satisfy (Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem`[Char]
",)"))
    convert :: [Char] -> [[Char]] -> Parser Char [Char]
convert [Char]
"defined" [[Char]
arg] =
      case [Char] -> SymTab HashDefine -> Maybe HashDefine
forall v. [Char] -> SymTab v -> Maybe v
lookupST [Char]
arg SymTab HashDefine
st of
        Maybe HashDefine
Nothing | (Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit [Char]
arg    -> [Char] -> Parser Char [Char]
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
arg
        Maybe HashDefine
Nothing                      -> [Char] -> Parser Char [Char]
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
"0"
        Just (a :: HashDefine
a@AntiDefined{})       -> [Char] -> Parser Char [Char]
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
"0"
        Just (a :: HashDefine
a@SymbolReplacement{}) -> [Char] -> Parser Char [Char]
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
"1"
        Just (a :: HashDefine
a@MacroExpansion{})    -> [Char] -> Parser Char [Char]
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
"1"
    convert [Char]
sym [[Char]]
args =
      case [Char] -> SymTab HashDefine -> Maybe HashDefine
forall v. [Char] -> SymTab v -> Maybe v
lookupST [Char]
sym SymTab HashDefine
st of
        Maybe HashDefine
Nothing  -> if [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
args then [Char] -> Parser Char [Char]
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
sym
                    else [Char] -> Parser Char [Char]
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
"0"
                 -- else fail (disp sym args++" is not a defined macro")
        Just (a :: HashDefine
a@SymbolReplacement{}) -> do [Char] -> Parser Char ()
forall t. [t] -> Parser t ()
reparse (HashDefine -> [Char]
replacement HashDefine
a)
                                           [Char] -> Parser Char [Char]
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
""
        Just (a :: HashDefine
a@MacroExpansion{})    -> do [Char] -> Parser Char ()
forall t. [t] -> Parser t ()
reparse (HashDefine -> [[Char]] -> Bool -> [Char]
expandMacro HashDefine
a [[Char]]
args Bool
False)
                                           [Char] -> Parser Char [Char]
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
""
        Just (a :: HashDefine
a@AntiDefined{})       ->
                    if [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
args then [Char] -> Parser Char [Char]
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
sym
                    else [Char] -> Parser Char [Char]
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
"0"
                 -- else fail (disp sym args++" explicitly undefined with -U")
    disp :: [Char] -> t a -> [Char]
disp [Char]
sym t a
args = let len :: Int
len = t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
args
                        chars :: [[Char]]
chars = (Char -> [Char]) -> [Char] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[]) [Char
'a'..Char
'z']
                    in [Char]
sym [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ if t a -> Bool
forall a. t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
args then [Char]
""
                              else [Char]
"("[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," (Int -> [[Char]] -> [[Char]]
forall a. Int -> [a] -> [a]
take Int
len [[Char]]
chars)[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
")"

parseBoolExp :: TextParser Bool
parseBoolExp :: Parser Char Bool
parseBoolExp =
  do  a <- Parser Char Bool
parseExp1
      bs <- many (do skip (isWord "||")
                     commit $ skip parseBoolExp)
      return $ foldr (||) a bs

parseExp1 :: TextParser Bool
parseExp1 :: Parser Char Bool
parseExp1 =
  do  a <- Parser Char Bool
parseExp0
      bs <- many (do skip (isWord "&&")
                     commit $ skip parseExp1)
      return $ foldr (&&) a bs

parseExp0 :: TextParser Bool
parseExp0 :: Parser Char Bool
parseExp0 =
  do  Parser Char [Char] -> Parser Char [Char]
forall a. Parser Char a -> Parser Char a
skip ([Char] -> Parser Char [Char]
isWord [Char]
"!")
      a <- Parser Char Bool -> Parser Char Bool
forall a. Parser Char a -> Parser Char a
forall (p :: * -> *) a. Commitment p => p a -> p a
commit (Parser Char Bool -> Parser Char Bool)
-> Parser Char Bool -> Parser Char Bool
forall a b. (a -> b) -> a -> b
$ Parser Char Bool
parseExp0
      return (not a)
  Parser Char Bool -> Parser Char Bool -> Parser Char Bool
forall a. Parser Char a -> Parser Char a -> Parser Char a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  do  val1 <- TextParser Integer
parseArithExp1
      op   <- parseCmpOp
      val2 <- parseArithExp1
      return (val1 `op` val2)
  Parser Char Bool -> Parser Char Bool -> Parser Char Bool
forall a. Parser Char a -> Parser Char a -> Parser Char a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  do  sym <- TextParser Integer
parseArithExp1
      case sym of
        Integer
0 -> Bool -> Parser Char Bool
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Integer
_ -> Bool -> Parser Char Bool
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  Parser Char Bool -> Parser Char Bool -> Parser Char Bool
forall a. Parser Char a -> Parser Char a -> Parser Char a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  do  Parser Char Bool -> Parser Char Bool
forall a. Parser Char a -> Parser Char a
parenthesis (Parser Char Bool -> Parser Char Bool
forall a. Parser Char a -> Parser Char a
forall (p :: * -> *) a. Commitment p => p a -> p a
commit Parser Char Bool
parseBoolExp)

parseArithExp1 :: TextParser Integer
parseArithExp1 :: TextParser Integer
parseArithExp1 =
  do  val1 <- TextParser Integer
parseArithExp0
      ( do op   <- parseArithOp1
           val2 <- parseArithExp1
           return (val1 `op` val2)
        <|> return val1 )
  TextParser Integer -> TextParser Integer -> TextParser Integer
forall a. Parser Char a -> Parser Char a -> Parser Char a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  do  TextParser Integer -> TextParser Integer
forall a. Parser Char a -> Parser Char a
parenthesis TextParser Integer
parseArithExp1

parseArithExp0 :: TextParser Integer
parseArithExp0 :: TextParser Integer
parseArithExp0 =
  do  val1 <- TextParser Integer
parseNumber
      ( do op   <- parseArithOp0
           val2 <- parseArithExp0
           return (val1 `op` val2)
        <|> return val1 )
  TextParser Integer -> TextParser Integer -> TextParser Integer
forall a. Parser Char a -> Parser Char a -> Parser Char a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  do  TextParser Integer -> TextParser Integer
forall a. Parser Char a -> Parser Char a
parenthesis TextParser Integer
parseArithExp0

parseNumber :: TextParser Integer
parseNumber :: TextParser Integer
parseNumber = ([Char] -> Integer) -> Parser Char [Char] -> TextParser Integer
forall a b. (a -> b) -> Parser Char a -> Parser Char b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> Integer
safeRead (Parser Char [Char] -> TextParser Integer)
-> Parser Char [Char] -> TextParser Integer
forall a b. (a -> b) -> a -> b
$ Parser Char [Char] -> Parser Char [Char]
forall a. Parser Char a -> Parser Char a
skip Parser Char [Char]
parseSym
  where
    safeRead :: [Char] -> Integer
safeRead [Char]
s =
      case [Char]
s of
        Char
'0':Char
'x':[Char]
s' -> ([Char] -> [(Integer, [Char])]) -> [Char] -> Integer
forall {t} {b}. (t -> [(Integer, b)]) -> t -> Integer
number [Char] -> [(Integer, [Char])]
forall a. (Eq a, Num a) => ReadS a
readHex [Char]
s'
        Char
'0':Char
'o':[Char]
s' -> ([Char] -> [(Integer, [Char])]) -> [Char] -> Integer
forall {t} {b}. (t -> [(Integer, b)]) -> t -> Integer
number [Char] -> [(Integer, [Char])]
forall a. (Eq a, Num a) => ReadS a
readOct [Char]
s'
        [Char]
_          -> ([Char] -> [(Integer, [Char])]) -> [Char] -> Integer
forall {t} {b}. (t -> [(Integer, b)]) -> t -> Integer
number [Char] -> [(Integer, [Char])]
forall a. (Eq a, Num a) => ReadS a
readDec [Char]
s
    number :: (t -> [(Integer, b)]) -> t -> Integer
number t -> [(Integer, b)]
rd t
s =
      case t -> [(Integer, b)]
rd t
s of
        []        -> Integer
0 :: Integer
        ((Integer
n,b
_):[(Integer, b)]
_) -> Integer
n :: Integer

parseCmpOp :: TextParser (Integer -> Integer -> Bool)
parseCmpOp :: TextParser (Integer -> Integer -> Bool)
parseCmpOp =
  do  Parser Char [Char] -> Parser Char [Char]
forall a. Parser Char a -> Parser Char a
skip ([Char] -> Parser Char [Char]
isWord [Char]
">=")
      (Integer -> Integer -> Bool)
-> TextParser (Integer -> Integer -> Bool)
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
(>=)
  TextParser (Integer -> Integer -> Bool)
-> TextParser (Integer -> Integer -> Bool)
-> TextParser (Integer -> Integer -> Bool)
forall a. Parser Char a -> Parser Char a -> Parser Char a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  do  Parser Char [Char] -> Parser Char [Char]
forall a. Parser Char a -> Parser Char a
skip ([Char] -> Parser Char [Char]
isWord [Char]
">")
      (Integer -> Integer -> Bool)
-> TextParser (Integer -> Integer -> Bool)
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
(>)
  TextParser (Integer -> Integer -> Bool)
-> TextParser (Integer -> Integer -> Bool)
-> TextParser (Integer -> Integer -> Bool)
forall a. Parser Char a -> Parser Char a -> Parser Char a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  do  Parser Char [Char] -> Parser Char [Char]
forall a. Parser Char a -> Parser Char a
skip ([Char] -> Parser Char [Char]
isWord [Char]
"<=")
      (Integer -> Integer -> Bool)
-> TextParser (Integer -> Integer -> Bool)
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
(<=)
  TextParser (Integer -> Integer -> Bool)
-> TextParser (Integer -> Integer -> Bool)
-> TextParser (Integer -> Integer -> Bool)
forall a. Parser Char a -> Parser Char a -> Parser Char a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  do  Parser Char [Char] -> Parser Char [Char]
forall a. Parser Char a -> Parser Char a
skip ([Char] -> Parser Char [Char]
isWord [Char]
"<")
      (Integer -> Integer -> Bool)
-> TextParser (Integer -> Integer -> Bool)
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
(<)
  TextParser (Integer -> Integer -> Bool)
-> TextParser (Integer -> Integer -> Bool)
-> TextParser (Integer -> Integer -> Bool)
forall a. Parser Char a -> Parser Char a -> Parser Char a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  do  Parser Char [Char] -> Parser Char [Char]
forall a. Parser Char a -> Parser Char a
skip ([Char] -> Parser Char [Char]
isWord [Char]
"==")
      (Integer -> Integer -> Bool)
-> TextParser (Integer -> Integer -> Bool)
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
(==)
  TextParser (Integer -> Integer -> Bool)
-> TextParser (Integer -> Integer -> Bool)
-> TextParser (Integer -> Integer -> Bool)
forall a. Parser Char a -> Parser Char a -> Parser Char a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  do  Parser Char [Char] -> Parser Char [Char]
forall a. Parser Char a -> Parser Char a
skip ([Char] -> Parser Char [Char]
isWord [Char]
"!=")
      (Integer -> Integer -> Bool)
-> TextParser (Integer -> Integer -> Bool)
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
(/=)

parseArithOp1 :: TextParser (Integer -> Integer -> Integer)
parseArithOp1 :: TextParser (Integer -> Integer -> Integer)
parseArithOp1 =
  do  Parser Char [Char] -> Parser Char [Char]
forall a. Parser Char a -> Parser Char a
skip ([Char] -> Parser Char [Char]
isWord [Char]
"+")
      (Integer -> Integer -> Integer)
-> TextParser (Integer -> Integer -> Integer)
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+)
  TextParser (Integer -> Integer -> Integer)
-> TextParser (Integer -> Integer -> Integer)
-> TextParser (Integer -> Integer -> Integer)
forall a. Parser Char a -> Parser Char a -> Parser Char a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  do  Parser Char [Char] -> Parser Char [Char]
forall a. Parser Char a -> Parser Char a
skip ([Char] -> Parser Char [Char]
isWord [Char]
"-")
      (Integer -> Integer -> Integer)
-> TextParser (Integer -> Integer -> Integer)
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return (-)

parseArithOp0 :: TextParser (Integer -> Integer -> Integer)
parseArithOp0 :: TextParser (Integer -> Integer -> Integer)
parseArithOp0 =
  do  Parser Char [Char] -> Parser Char [Char]
forall a. Parser Char a -> Parser Char a
skip ([Char] -> Parser Char [Char]
isWord [Char]
"*")
      (Integer -> Integer -> Integer)
-> TextParser (Integer -> Integer -> Integer)
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(*)
  TextParser (Integer -> Integer -> Integer)
-> TextParser (Integer -> Integer -> Integer)
-> TextParser (Integer -> Integer -> Integer)
forall a. Parser Char a -> Parser Char a -> Parser Char a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  do  Parser Char [Char] -> Parser Char [Char]
forall a. Parser Char a -> Parser Char a
skip ([Char] -> Parser Char [Char]
isWord [Char]
"/")
      (Integer -> Integer -> Integer)
-> TextParser (Integer -> Integer -> Integer)
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
div)
  TextParser (Integer -> Integer -> Integer)
-> TextParser (Integer -> Integer -> Integer)
-> TextParser (Integer -> Integer -> Integer)
forall a. Parser Char a -> Parser Char a -> Parser Char a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  do  Parser Char [Char] -> Parser Char [Char]
forall a. Parser Char a -> Parser Char a
skip ([Char] -> Parser Char [Char]
isWord [Char]
"%")
      (Integer -> Integer -> Integer)
-> TextParser (Integer -> Integer -> Integer)
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
rem)

-- | Return the expansion of the symbol (if there is one).
parseSymOrCall :: SymTab HashDefine -> TextParser String
parseSymOrCall :: SymTab HashDefine -> Parser Char [Char]
parseSymOrCall SymTab HashDefine
st =
  do  sym <- Parser Char [Char] -> Parser Char [Char]
forall a. Parser Char a -> Parser Char a
skip Parser Char [Char]
parseSym
      args <- parenthesis (commit $ parseSymOrCall st `sepBy` skip (isWord ","))
      return $ convert sym args
  Parser Char [Char] -> Parser Char [Char] -> Parser Char [Char]
forall a. Parser Char a -> Parser Char a -> Parser Char a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  do  sym <- Parser Char [Char] -> Parser Char [Char]
forall a. Parser Char a -> Parser Char a
skip Parser Char [Char]
parseSym
      return $ convert sym []
  where
    convert :: [Char] -> [[Char]] -> [Char]
convert [Char]
sym [[Char]]
args =
      case [Char] -> SymTab HashDefine -> Maybe HashDefine
forall v. [Char] -> SymTab v -> Maybe v
lookupST [Char]
sym SymTab HashDefine
st of
        Maybe HashDefine
Nothing  -> [Char]
sym
        Just (a :: HashDefine
a@SymbolReplacement{}) -> SymTab HashDefine -> [Char] -> [Char]
recursivelyExpand SymTab HashDefine
st (HashDefine -> [Char]
replacement HashDefine
a)
        Just (a :: HashDefine
a@MacroExpansion{})    -> SymTab HashDefine -> [Char] -> [Char]
recursivelyExpand SymTab HashDefine
st (HashDefine -> [[Char]] -> Bool -> [Char]
expandMacro HashDefine
a [[Char]]
args Bool
False)
        Just (a :: HashDefine
a@AntiDefined{})       -> HashDefine -> [Char]
name HashDefine
a

recursivelyExpand :: SymTab HashDefine -> String -> String
recursivelyExpand :: SymTab HashDefine -> [Char] -> [Char]
recursivelyExpand SymTab HashDefine
st [Char]
inp =
  case Parser Char [Char] -> [Char] -> (Either [Char] [Char], [Char])
forall t a. Parser t a -> [t] -> (Either [Char] a, [t])
runParser (SymTab HashDefine -> Parser Char [Char]
parseSymOrCall SymTab HashDefine
st) [Char]
inp of
    (Left [Char]
msg, [Char]
_) -> [Char]
inp
    (Right [Char]
s,  [Char]
_) -> [Char]
s

parseSym :: TextParser String
parseSym :: Parser Char [Char]
parseSym = Parser Char Char -> Parser Char [Char]
forall (p :: * -> *) a. PolyParse p => p a -> p [a]
many1 ((Char -> Bool) -> Parser Char Char
forall t. (t -> Bool) -> Parser t t
satisfy (\Char
c-> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
cChar -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`[Char]
"'`_"))
           Parser Char [Char] -> Parser Char [Char] -> Parser Char [Char]
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
           do xs <- Parser Char [Char]
allAsString
              fail $ "Expected an identifier, got \""++xs++"\""

notIdent :: Char -> Bool
notIdent :: Char -> Bool
notIdent Char
c = Bool -> Bool
not (Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
cChar -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`[Char]
"'`_")

skip :: TextParser a -> TextParser a
skip :: forall a. Parser Char a -> Parser Char a
skip TextParser a
p = Parser Char Char -> Parser Char [Char]
forall a. Parser Char a -> Parser Char [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ((Char -> Bool) -> Parser Char Char
forall t. (t -> Bool) -> Parser t t
satisfy Char -> Bool
isSpace) Parser Char [Char] -> TextParser a -> TextParser a
forall a b. Parser Char a -> Parser Char b -> Parser Char b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TextParser a
p

-- | The standard "parens" parser does not work for us here.  Define our own.
parenthesis :: TextParser a -> TextParser a
parenthesis :: forall a. Parser Char a -> Parser Char a
parenthesis TextParser a
p = do [Char] -> Parser Char [Char]
isWord [Char]
"("
                   x <- TextParser a
p
                   isWord ")"
                   return x

-- | Determine filename in \#include
file :: SymTab HashDefine -> String -> String
file :: SymTab HashDefine -> [Char] -> [Char]
file SymTab HashDefine
st [Char]
name =
    case [Char]
name of
      (Char
'"':[Char]
ns) -> [Char] -> [Char]
forall a. HasCallStack => [a] -> [a]
init [Char]
ns
      (Char
'<':[Char]
ns) -> [Char] -> [Char]
forall a. HasCallStack => [a] -> [a]
init [Char]
ns
      [Char]
_ -> let ex :: [Char]
ex = SymTab HashDefine -> [Char] -> [Char]
recursivelyExpand SymTab HashDefine
st [Char]
name in
           if [Char]
ex [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
name then [Char]
name else SymTab HashDefine -> [Char] -> [Char]
file SymTab HashDefine
st [Char]
ex