module Language.Preprocessor.Cpphs.CppIfdef
( cppIfdef
) 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)
cppIfdef :: FilePath
-> [(String,String)]
-> [String]
-> BoolOptions
-> String
-> IO [(Posn,String)]
cppIfdef :: String
-> [(String, String)]
-> [String]
-> BoolOptions
-> String
-> IO [(Posn, String)]
cppIfdef String
fp [(String, String)]
syms [String]
search BoolOptions
options =
Posn
-> SymTab HashDefine
-> [String]
-> BoolOptions
-> KeepState
-> [String]
-> IO [(Posn, String)]
cpp Posn
posn SymTab HashDefine
defs [String]
search BoolOptions
options ([Posn] -> KeepState
Keep []) ([String] -> IO [(Posn, String)])
-> (String -> [String]) -> String -> IO [(Posn, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
initial ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
linesCpp
where
posn :: Posn
posn = String -> Posn
newfile String
fp
defs :: SymTab HashDefine
defs = BoolOptions -> [(String, String)] -> SymTab HashDefine
preDefine BoolOptions
options [(String, String)]
syms
initial :: [String] -> [String]
initial = if BoolOptions -> Bool
literate BoolOptions
options then [String] -> [String]
forall a. a -> a
id else (Posn -> String
cppline Posn
posnString -> [String] -> [String]
forall a. a -> [a] -> [a]
:)
data KeepState = Keep [Posn] | Drop Int Bool [Posn]
cpp :: Posn -> SymTab HashDefine -> [String] -> BoolOptions -> KeepState
-> [String] -> IO [(Posn,String)]
cpp :: Posn
-> SymTab HashDefine
-> [String]
-> BoolOptions
-> KeepState
-> [String]
-> IO [(Posn, String)]
cpp Posn
_ SymTab HashDefine
_ [String]
_ 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 -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Unmatched #if: positions of open context are:\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++
[String] -> String
unlines ((Posn -> String) -> [Posn] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Posn -> String
forall a. Show a => a -> String
show [Posn]
ps)
[(Posn, String)] -> IO [(Posn, String)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
cpp Posn
_ SymTab HashDefine
_ [String]
_ BoolOptions
_ KeepState
_ [] = [(Posn, String)] -> IO [(Posn, String)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
cpp Posn
p SymTab HashDefine
syms [String]
path BoolOptions
options (Keep [Posn]
ps) (l :: String
l@(Char
'#':String
x):[String]
xs) =
let ws :: [String]
ws = String -> [String]
words String
x
cmd :: String
cmd = if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
ws then String
"" else [String] -> String
forall a. HasCallStack => [a] -> a
head [String]
ws
line :: [String]
line = if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
ws then [] else [String] -> [String]
forall a. HasCallStack => [a] -> [a]
tail [String]
ws
sym :: String
sym = if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
line then String
"" else [String] -> String
forall a. HasCallStack => [a] -> a
head [String]
line
rest :: [String]
rest = if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
line then [] else [String] -> [String]
forall a. HasCallStack => [a] -> [a]
tail [String]
line
def :: (String, HashDefine)
def = BoolOptions -> String -> (String, HashDefine)
defineMacro BoolOptions
options (String
symString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" "String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"1" String -> String
forall a. a -> a
id ([String] -> Maybe String
un [String]
rest))
un :: [String] -> Maybe String
un [String]
v = if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
v then Maybe String
forall a. Maybe a
Nothing else String -> Maybe String
forall a. a -> Maybe a
Just ([String] -> String
unwords [String]
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 -> [String] -> IO [(Posn, String)]
skipn SymTab HashDefine
syms' Bool
retain KeepState
ud [String]
xs' =
let n :: Int
n = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\n') String
l) in
(if BoolOptions -> Bool
macros BoolOptions
options Bool -> Bool -> Bool
&& Bool
retain then (Posn, String) -> IO [(Posn, String)] -> IO [(Posn, String)]
forall a. a -> IO [a] -> IO [a]
emitOne (Posn
p,String -> String
reslash String
l)
else [(Posn, String)] -> IO [(Posn, String)] -> IO [(Posn, String)]
forall a. [a] -> IO [a] -> IO [a]
emitMany (Int -> (Posn, String) -> [(Posn, String)]
forall a. Int -> a -> [a]
replicate Int
n (Posn
p,String
""))) (IO [(Posn, String)] -> IO [(Posn, String)])
-> IO [(Posn, String)] -> IO [(Posn, String)]
forall a b. (a -> b) -> a -> b
$
Posn
-> SymTab HashDefine
-> [String]
-> BoolOptions
-> KeepState
-> [String]
-> IO [(Posn, String)]
cpp (Int -> Posn -> Posn
newlines Int
n Posn
p) SymTab HashDefine
syms' [String]
path BoolOptions
options KeepState
ud [String]
xs'
in case String
cmd of
String
"define" -> SymTab HashDefine
-> Bool -> KeepState -> [String] -> IO [(Posn, String)]
skipn ((String, HashDefine) -> SymTab HashDefine -> SymTab HashDefine
forall v. (String, v) -> SymTab v -> SymTab v
insertST (String, HashDefine)
def SymTab HashDefine
syms) Bool
True ([Posn] -> KeepState
Keep [Posn]
ps) [String]
xs
String
"undef" -> SymTab HashDefine
-> Bool -> KeepState -> [String] -> IO [(Posn, String)]
skipn (String -> SymTab HashDefine -> SymTab HashDefine
forall v. String -> SymTab v -> SymTab v
deleteST String
sym SymTab HashDefine
syms) Bool
True ([Posn] -> KeepState
Keep [Posn]
ps) [String]
xs
String
"ifndef" -> SymTab HashDefine
-> Bool -> KeepState -> [String] -> IO [(Posn, String)]
skipn SymTab HashDefine
syms Bool
False (Bool -> KeepState
keepIf (Bool -> Bool
not (String -> SymTab HashDefine -> Bool
forall v. String -> SymTab v -> Bool
definedST String
sym SymTab HashDefine
syms))) [String]
xs
String
"ifdef" -> SymTab HashDefine
-> Bool -> KeepState -> [String] -> IO [(Posn, String)]
skipn SymTab HashDefine
syms Bool
False (Bool -> KeepState
keepIf (String -> SymTab HashDefine -> Bool
forall v. String -> SymTab v -> Bool
definedST String
sym SymTab HashDefine
syms)) [String]
xs
String
"if" -> do Bool
b <- Posn -> SymTab HashDefine -> String -> IO Bool
gatherDefined Posn
p SymTab HashDefine
syms ([String] -> String
unwords [String]
line)
SymTab HashDefine
-> Bool -> KeepState -> [String] -> IO [(Posn, String)]
skipn SymTab HashDefine
syms Bool
False (Bool -> KeepState
keepIf Bool
b) [String]
xs
String
"else" -> SymTab HashDefine
-> Bool -> KeepState -> [String] -> IO [(Posn, String)]
skipn SymTab HashDefine
syms Bool
False (Int -> Bool -> [Posn] -> KeepState
Drop Int
1 Bool
False [Posn]
ps) [String]
xs
String
"elif" -> SymTab HashDefine
-> Bool -> KeepState -> [String] -> IO [(Posn, String)]
skipn SymTab HashDefine
syms Bool
False (Int -> Bool -> [Posn] -> KeepState
Drop Int
1 Bool
True [Posn]
ps) [String]
xs
String
"endif" | [Posn] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Posn]
ps ->
do Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Unmatched #endif at "String -> String -> String
forall a. [a] -> [a] -> [a]
++Posn -> String
forall a. Show a => a -> String
show Posn
p
[(Posn, String)] -> IO [(Posn, String)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
String
"endif" -> SymTab HashDefine
-> Bool -> KeepState -> [String] -> IO [(Posn, String)]
skipn SymTab HashDefine
syms Bool
False ([Posn] -> KeepState
Keep ([Posn] -> [Posn]
forall a. HasCallStack => [a] -> [a]
tail [Posn]
ps)) [String]
xs
String
"pragma" -> SymTab HashDefine
-> Bool -> KeepState -> [String] -> IO [(Posn, String)]
skipn SymTab HashDefine
syms Bool
True ([Posn] -> KeepState
Keep [Posn]
ps) [String]
xs
(Char
'!':String
_) -> SymTab HashDefine
-> Bool -> KeepState -> [String] -> IO [(Posn, String)]
skipn SymTab HashDefine
syms Bool
False ([Posn] -> KeepState
Keep [Posn]
ps) [String]
xs
String
"include"-> do (String
inc,String
content) <- String -> Posn -> [String] -> Bool -> IO (String, String)
readFirst (SymTab HashDefine -> String -> String
file SymTab HashDefine
syms ([String] -> String
unwords [String]
line))
Posn
p [String]
path
(BoolOptions -> Bool
warnings BoolOptions
options)
Posn
-> SymTab HashDefine
-> [String]
-> BoolOptions
-> KeepState
-> [String]
-> IO [(Posn, String)]
cpp Posn
p SymTab HashDefine
syms [String]
path BoolOptions
options ([Posn] -> KeepState
Keep [Posn]
ps)
((String
"#line 1 "String -> String -> String
forall a. [a] -> [a] -> [a]
++String -> String
forall a. Show a => a -> String
show String
inc)String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
linesCpp String
content
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Posn -> String
cppline (Posn -> Posn
newline Posn
p)String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
xs)
String
"warning"-> if BoolOptions -> Bool
warnings BoolOptions
options then
do Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
lString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\nin "String -> String -> String
forall a. [a] -> [a] -> [a]
++Posn -> String
forall a. Show a => a -> String
show Posn
p)
SymTab HashDefine
-> Bool -> KeepState -> [String] -> IO [(Posn, String)]
skipn SymTab HashDefine
syms Bool
False ([Posn] -> KeepState
Keep [Posn]
ps) [String]
xs
else SymTab HashDefine
-> Bool -> KeepState -> [String] -> IO [(Posn, String)]
skipn SymTab HashDefine
syms Bool
False ([Posn] -> KeepState
Keep [Posn]
ps) [String]
xs
String
"error" -> String -> IO [(Posn, String)]
forall a. HasCallStack => String -> a
error (String
lString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\nin "String -> String -> String
forall a. [a] -> [a] -> [a]
++Posn -> String
forall a. Show a => a -> String
show Posn
p)
String
"line" | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit String
sym
-> (if BoolOptions -> Bool
locations BoolOptions
options Bool -> Bool -> Bool
&& BoolOptions -> Bool
hashline BoolOptions
options then (Posn, String) -> IO [(Posn, String)] -> IO [(Posn, String)]
forall a. a -> IO [a] -> IO [a]
emitOne (Posn
p,String
l)
else if BoolOptions -> Bool
locations BoolOptions
options then (Posn, String) -> IO [(Posn, String)] -> IO [(Posn, String)]
forall a. a -> IO [a] -> IO [a]
emitOne (Posn
p,String -> String
cpp2hask String
l)
else IO [(Posn, String)] -> IO [(Posn, String)]
forall a. a -> a
id) (IO [(Posn, String)] -> IO [(Posn, String)])
-> IO [(Posn, String)] -> IO [(Posn, String)]
forall a b. (a -> b) -> a -> b
$
Posn
-> SymTab HashDefine
-> [String]
-> BoolOptions
-> KeepState
-> [String]
-> IO [(Posn, String)]
cpp (Int -> Maybe String -> Posn -> Posn
newpos (String -> Int
forall a. Read a => String -> a
read String
sym) ([String] -> Maybe String
un [String]
rest) Posn
p)
SymTab HashDefine
syms [String]
path BoolOptions
options ([Posn] -> KeepState
Keep [Posn]
ps) [String]
xs
String
n | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit String
n Bool -> Bool -> Bool
&& Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
n)
-> (if BoolOptions -> Bool
locations BoolOptions
options Bool -> Bool -> Bool
&& BoolOptions -> Bool
hashline BoolOptions
options then (Posn, String) -> IO [(Posn, String)] -> IO [(Posn, String)]
forall a. a -> IO [a] -> IO [a]
emitOne (Posn
p,String
l)
else if BoolOptions -> Bool
locations BoolOptions
options then (Posn, String) -> IO [(Posn, String)] -> IO [(Posn, String)]
forall a. a -> IO [a] -> IO [a]
emitOne (Posn
p,String -> String
cpp2hask String
l)
else IO [(Posn, String)] -> IO [(Posn, String)]
forall a. a -> a
id) (IO [(Posn, String)] -> IO [(Posn, String)])
-> IO [(Posn, String)] -> IO [(Posn, String)]
forall a b. (a -> b) -> a -> b
$
Posn
-> SymTab HashDefine
-> [String]
-> BoolOptions
-> KeepState
-> [String]
-> IO [(Posn, String)]
cpp (Int -> Maybe String -> Posn -> Posn
newpos (String -> Int
forall a. Read a => String -> a
read String
n) ([String] -> Maybe String
un ([String] -> [String]
forall a. HasCallStack => [a] -> [a]
tail [String]
ws)) Posn
p)
SymTab HashDefine
syms [String]
path BoolOptions
options ([Posn] -> KeepState
Keep [Posn]
ps) [String]
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 -> String -> IO ()
hPutStrLn Handle
stderr (String
"Warning: unknown directive #"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
n
String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\nin "String -> String -> String
forall a. [a] -> [a] -> [a]
++Posn -> String
forall a. Show a => a -> String
show Posn
p)
(Posn, String) -> IO [(Posn, String)] -> IO [(Posn, String)]
forall a. a -> IO [a] -> IO [a]
emitOne (Posn
p,String
l) (IO [(Posn, String)] -> IO [(Posn, String)])
-> IO [(Posn, String)] -> IO [(Posn, String)]
forall a b. (a -> b) -> a -> b
$
Posn
-> SymTab HashDefine
-> [String]
-> BoolOptions
-> KeepState
-> [String]
-> IO [(Posn, String)]
cpp (Posn -> Posn
newline Posn
p) SymTab HashDefine
syms [String]
path BoolOptions
options ([Posn] -> KeepState
Keep [Posn]
ps) [String]
xs
cpp Posn
p SymTab HashDefine
syms [String]
path BoolOptions
options (Drop Int
n Bool
b [Posn]
ps) ((Char
'#':String
x):[String]
xs) =
let ws :: [String]
ws = String -> [String]
words String
x
cmd :: String
cmd = if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
ws then String
"" else [String] -> String
forall a. HasCallStack => [a] -> a
head [String]
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 -> [String] -> IO [(Posn, String)]
skipn KeepState
ud [String]
xs' =
let n' :: Int
n' = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\n') String
x) in
[(Posn, String)] -> IO [(Posn, String)] -> IO [(Posn, String)]
forall a. [a] -> IO [a] -> IO [a]
emitMany (Int -> (Posn, String) -> [(Posn, String)]
forall a. Int -> a -> [a]
replicate Int
n' (Posn
p,String
"")) (IO [(Posn, String)] -> IO [(Posn, String)])
-> IO [(Posn, String)] -> IO [(Posn, String)]
forall a b. (a -> b) -> a -> b
$
Posn
-> SymTab HashDefine
-> [String]
-> BoolOptions
-> KeepState
-> [String]
-> IO [(Posn, String)]
cpp (Int -> Posn -> Posn
newlines Int
n' Posn
p) SymTab HashDefine
syms [String]
path BoolOptions
options KeepState
ud [String]
xs'
in
if String
cmd String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"ifndef" Bool -> Bool -> Bool
||
String
cmd String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"if" Bool -> Bool -> Bool
||
String
cmd String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"ifdef" then KeepState -> [String] -> IO [(Posn, String)]
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)) [String]
xs
else if String
cmd String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"elif" then do Bool
v <- Posn -> SymTab HashDefine -> String -> IO Bool
gatherDefined Posn
p SymTab HashDefine
syms ([String] -> String
unwords ([String] -> [String]
forall a. HasCallStack => [a] -> [a]
tail [String]
ws))
KeepState -> [String] -> IO [(Posn, String)]
skipn (Bool -> KeepState
delif Bool
v) [String]
xs
else if String
cmd String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"else" then KeepState -> [String] -> IO [(Posn, String)]
skipn KeepState
delse [String]
xs
else if String
cmd String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"endif" then
if [Posn] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Posn]
ps then do Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Unmatched #endif at "String -> String -> String
forall a. [a] -> [a] -> [a]
++Posn -> String
forall a. Show a => a -> String
show Posn
p
[(Posn, String)] -> IO [(Posn, String)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
else KeepState -> [String] -> IO [(Posn, String)]
skipn KeepState
dend [String]
xs
else KeepState -> [String] -> IO [(Posn, String)]
skipn (Int -> Bool -> [Posn] -> KeepState
Drop Int
n Bool
b [Posn]
ps) [String]
xs
cpp Posn
p SymTab HashDefine
syms [String]
path BoolOptions
options (Keep [Posn]
ps) (String
x:[String]
xs) =
let p' :: Posn
p' = Posn -> Posn
newline Posn
p in Posn -> IO [(Posn, String)] -> IO [(Posn, String)]
forall a b. a -> b -> b
seq Posn
p' (IO [(Posn, String)] -> IO [(Posn, String)])
-> IO [(Posn, String)] -> IO [(Posn, String)]
forall a b. (a -> b) -> a -> b
$
(Posn, String) -> IO [(Posn, String)] -> IO [(Posn, String)]
forall a. a -> IO [a] -> IO [a]
emitOne (Posn
p,String
x) (IO [(Posn, String)] -> IO [(Posn, String)])
-> IO [(Posn, String)] -> IO [(Posn, String)]
forall a b. (a -> b) -> a -> b
$ Posn
-> SymTab HashDefine
-> [String]
-> BoolOptions
-> KeepState
-> [String]
-> IO [(Posn, String)]
cpp Posn
p' SymTab HashDefine
syms [String]
path BoolOptions
options ([Posn] -> KeepState
Keep [Posn]
ps) [String]
xs
cpp Posn
p SymTab HashDefine
syms [String]
path BoolOptions
options d :: KeepState
d@(Drop Int
_ Bool
_ [Posn]
_) (String
_:[String]
xs) =
let p' :: Posn
p' = Posn -> Posn
newline Posn
p in Posn -> IO [(Posn, String)] -> IO [(Posn, String)]
forall a b. a -> b -> b
seq Posn
p' (IO [(Posn, String)] -> IO [(Posn, String)])
-> IO [(Posn, String)] -> IO [(Posn, String)]
forall a b. (a -> b) -> a -> b
$
(Posn, String) -> IO [(Posn, String)] -> IO [(Posn, String)]
forall a. a -> IO [a] -> IO [a]
emitOne (Posn
p,String
"") (IO [(Posn, String)] -> IO [(Posn, String)])
-> IO [(Posn, String)] -> IO [(Posn, String)]
forall a b. (a -> b) -> a -> b
$ Posn
-> SymTab HashDefine
-> [String]
-> BoolOptions
-> KeepState
-> [String]
-> IO [(Posn, String)]
cpp Posn
p' SymTab HashDefine
syms [String]
path BoolOptions
options KeepState
d [String]
xs
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 [a]
ys <- IO [a] -> IO [a]
forall a. IO a -> IO a
unsafeInterleaveIO IO [a]
io
[a] -> IO [a]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys)
emitMany :: forall a. [a] -> IO [a] -> IO [a]
emitMany [a]
xs IO [a]
io = do [a]
ys <- IO [a] -> IO [a]
forall a. IO a -> IO a
unsafeInterleaveIO IO [a]
io
[a] -> IO [a]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([a]
xs[a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++[a]
ys)
gatherDefined :: Posn -> SymTab HashDefine -> String -> IO Bool
gatherDefined :: Posn -> SymTab HashDefine -> String -> IO Bool
gatherDefined Posn
p SymTab HashDefine
st String
inp =
case Parser Char String -> String -> (Either String String, String)
forall t a. Parser t a -> [t] -> (Either String a, [t])
runParser (SymTab HashDefine -> Parser Char String
preExpand SymTab HashDefine
st) String
inp of
(Left String
msg, String
_) -> String -> IO Bool
forall a. HasCallStack => String -> a
error (String
"Cannot expand #if directive in file "String -> String -> String
forall a. [a] -> [a] -> [a]
++Posn -> String
forall a. Show a => a -> String
show Posn
p
String -> String -> String
forall a. [a] -> [a] -> [a]
++String
":\n "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
msg)
(Right String
s, String
xs) -> do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Char -> Bool) -> String -> 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) String
xs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"Warning: trailing characters after #if"
String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" macro expansion in file "String -> String -> String
forall a. [a] -> [a] -> [a]
++Posn -> String
forall a. Show a => a -> String
show Posn
pString -> String -> String
forall a. [a] -> [a] -> [a]
++String
": "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
xs)
case Parser Char Bool -> String -> (Either String Bool, String)
forall t a. Parser t a -> [t] -> (Either String a, [t])
runParser Parser Char Bool
parseBoolExp String
s of
(Left String
msg, String
_) -> String -> IO Bool
forall a. HasCallStack => String -> a
error (String
"Cannot parse #if directive in file "String -> String -> String
forall a. [a] -> [a] -> [a]
++Posn -> String
forall a. Show a => a -> String
show Posn
p
String -> String -> String
forall a. [a] -> [a] -> [a]
++String
":\n "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
msg)
(Right Bool
b, String
xs) -> do Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Char -> Bool) -> String -> 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) String
xs Bool -> Bool -> Bool
&& String -> Bool
notComment String
xs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Handle -> String -> IO ()
hPutStrLn Handle
stderr
(String
"Warning: trailing characters after #if"
String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" directive in file "String -> String -> String
forall a. [a] -> [a] -> [a]
++Posn -> String
forall a. Show a => a -> String
show Posn
pString -> String -> String
forall a. [a] -> [a] -> [a]
++String
": "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
xs)
Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
b
= Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"//"String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) (String -> Bool) -> (String -> String) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace
preExpand :: SymTab HashDefine -> TextParser String
preExpand :: SymTab HashDefine -> Parser Char String
preExpand SymTab HashDefine
st =
do Parser Char ()
forall t. Parser t ()
eof
String -> Parser Char String
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
Parser Char String -> Parser Char String -> Parser Char String
forall a. Parser Char a -> Parser Char a -> Parser Char a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
do String
a <- Parser Char Char -> Parser Char String
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)
Parser Char String -> Parser Char String
forall a. Parser Char a -> Parser Char a
forall (p :: * -> *) a. Commitment p => p a -> p a
commit (Parser Char String -> Parser Char String)
-> Parser Char String -> Parser Char String
forall a b. (a -> b) -> a -> b
$ (String -> String) -> Parser Char (String -> String)
forall a. a -> Parser Char a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
aString -> String -> String
forall a. [a] -> [a] -> [a]
++) Parser Char (String -> String)
-> Parser Char String -> Parser Char String
forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` SymTab HashDefine -> Parser Char String
preExpand SymTab HashDefine
st
Parser Char String -> Parser Char String -> Parser Char String
forall a. Parser Char a -> Parser Char a -> Parser Char a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
do String
b <- SymTab HashDefine -> Parser Char String
expandSymOrCall SymTab HashDefine
st
Parser Char String -> Parser Char String
forall a. Parser Char a -> Parser Char a
forall (p :: * -> *) a. Commitment p => p a -> p a
commit (Parser Char String -> Parser Char String)
-> Parser Char String -> Parser Char String
forall a b. (a -> b) -> a -> b
$ (String -> String) -> Parser Char (String -> String)
forall a. a -> Parser Char a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
bString -> String -> String
forall a. [a] -> [a] -> [a]
++) Parser Char (String -> String)
-> Parser Char String -> Parser Char String
forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` SymTab HashDefine -> Parser Char String
preExpand SymTab HashDefine
st
expandSymOrCall :: SymTab HashDefine -> TextParser String
expandSymOrCall :: SymTab HashDefine -> Parser Char String
expandSymOrCall SymTab HashDefine
st =
do String
sym <- Parser Char String
parseSym
if String
symString -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
"defined" then do String
arg <- Parser Char String -> Parser Char String
forall a. Parser Char a -> Parser Char a
skip Parser Char String
parseSym; String -> [String] -> Parser Char String
convert String
sym [String
arg]
Parser Char String -> Parser Char String -> Parser Char String
forall a. Parser Char a -> Parser Char a -> Parser Char a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
do String
arg <- Parser Char String -> Parser Char String
forall a. Parser Char a -> Parser Char a
skip (Parser Char String -> Parser Char String)
-> Parser Char String -> Parser Char String
forall a b. (a -> b) -> a -> b
$ Parser Char String -> Parser Char String
forall a. Parser Char a -> Parser Char a
parenthesis (do String
x <- Parser Char String -> Parser Char String
forall a. Parser Char a -> Parser Char a
skip Parser Char String
parseSym;
Parser Char String -> Parser Char String
forall a. Parser Char a -> Parser Char a
skip (String -> Parser Char String
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return String
x))
String -> [String] -> Parser Char String
convert String
sym [String
arg]
Parser Char String -> Parser Char String -> Parser Char String
forall a. Parser Char a -> Parser Char a -> Parser Char a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> [String] -> Parser Char String
convert String
sym []
else
( do [String]
args <- TextParser [String] -> TextParser [String]
forall a. Parser Char a -> Parser Char a
parenthesis (TextParser [String] -> TextParser [String]
forall a. Parser Char a -> Parser Char a
forall (p :: * -> *) a. Commitment p => p a -> p a
commit (TextParser [String] -> TextParser [String])
-> TextParser [String] -> TextParser [String]
forall a b. (a -> b) -> a -> b
$ Parser Char String
fragment Parser Char String -> Parser Char String -> TextParser [String]
forall (p :: * -> *) a sep. PolyParse p => p a -> p sep -> p [a]
`sepBy` Parser Char String -> Parser Char String
forall a. Parser Char a -> Parser Char a
skip (String -> Parser Char String
isWord String
","))
[String]
args' <- ((String -> Parser Char String) -> [String] -> TextParser [String])
-> [String]
-> (String -> Parser Char String)
-> TextParser [String]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (String -> Parser Char String) -> [String] -> TextParser [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM [String]
args ((String -> Parser Char String) -> TextParser [String])
-> (String -> Parser Char String) -> TextParser [String]
forall a b. (a -> b) -> a -> b
$ \String
arg->
case Parser Char String -> String -> (Either String String, String)
forall t a. Parser t a -> [t] -> (Either String a, [t])
runParser (SymTab HashDefine -> Parser Char String
preExpand SymTab HashDefine
st) String
arg of
(Left String
msg, String
_) -> String -> Parser Char String
forall a. String -> Parser Char a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
msg
(Right String
s, String
_) -> String -> Parser Char String
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return String
s
String -> [String] -> Parser Char String
convert String
sym [String]
args'
Parser Char String -> Parser Char String -> Parser Char String
forall a. Parser Char a -> Parser Char a -> Parser Char a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> [String] -> Parser Char String
convert String
sym []
)
where
fragment :: Parser Char String
fragment = Parser Char Char -> Parser Char String
forall (p :: * -> *) a. PolyParse p => p a -> p [a]
many1 ((Char -> Bool) -> Parser Char Char
forall t. (t -> Bool) -> Parser t t
satisfy (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem`String
",)"))
convert :: String -> [String] -> Parser Char String
convert String
"defined" [String
arg] =
case String -> SymTab HashDefine -> Maybe HashDefine
forall v. String -> SymTab v -> Maybe v
lookupST String
arg SymTab HashDefine
st of
Maybe HashDefine
Nothing | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit String
arg -> String -> Parser Char String
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return String
arg
Maybe HashDefine
Nothing -> String -> Parser Char String
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return String
"0"
Just (a :: HashDefine
a@AntiDefined{}) -> String -> Parser Char String
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return String
"0"
Just (a :: HashDefine
a@SymbolReplacement{}) -> String -> Parser Char String
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return String
"1"
Just (a :: HashDefine
a@MacroExpansion{}) -> String -> Parser Char String
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return String
"1"
convert String
sym [String]
args =
case String -> SymTab HashDefine -> Maybe HashDefine
forall v. String -> SymTab v -> Maybe v
lookupST String
sym SymTab HashDefine
st of
Maybe HashDefine
Nothing -> if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
args then String -> Parser Char String
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return String
sym
else String -> Parser Char String
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return String
"0"
Just (a :: HashDefine
a@SymbolReplacement{}) -> do String -> Parser Char ()
forall t. [t] -> Parser t ()
reparse (HashDefine -> String
replacement HashDefine
a)
String -> Parser Char String
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
Just (a :: HashDefine
a@MacroExpansion{}) -> do String -> Parser Char ()
forall t. [t] -> Parser t ()
reparse (HashDefine -> [String] -> Bool -> String
expandMacro HashDefine
a [String]
args Bool
False)
String -> Parser Char String
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
Just (a :: HashDefine
a@AntiDefined{}) ->
if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
args then String -> Parser Char String
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return String
sym
else String -> Parser Char String
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return String
"0"
disp :: String -> t a -> String
disp String
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 :: [String]
chars = (Char -> String) -> String -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Char -> String -> String
forall a. a -> [a] -> [a]
:[]) [Char
'a'..Char
'z']
in String
sym String -> String -> String
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 String
""
else String
"("String -> String -> String
forall a. [a] -> [a] -> [a]
++String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
len [String]
chars)String -> String -> String
forall a. [a] -> [a] -> [a]
++String
")"
parseBoolExp :: TextParser Bool
parseBoolExp :: Parser Char Bool
parseBoolExp =
do Bool
a <- Parser Char Bool
parseExp1
[Bool]
bs <- Parser Char Bool -> Parser Char [Bool]
forall a. Parser Char a -> Parser Char [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (do Parser Char String -> Parser Char String
forall a. Parser Char a -> Parser Char a
skip (String -> Parser Char String
isWord String
"||")
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 -> Parser Char Bool
forall a. Parser Char a -> Parser Char a
skip Parser Char Bool
parseBoolExp)
Bool -> Parser Char Bool
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Parser Char Bool) -> Bool -> Parser Char Bool
forall a b. (a -> b) -> a -> b
$ (Bool -> Bool -> Bool) -> Bool -> [Bool] -> Bool
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Bool -> Bool -> Bool
(||) Bool
a [Bool]
bs
parseExp1 :: TextParser Bool
parseExp1 :: Parser Char Bool
parseExp1 =
do Bool
a <- Parser Char Bool
parseExp0
[Bool]
bs <- Parser Char Bool -> Parser Char [Bool]
forall a. Parser Char a -> Parser Char [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (do Parser Char String -> Parser Char String
forall a. Parser Char a -> Parser Char a
skip (String -> Parser Char String
isWord String
"&&")
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 -> Parser Char Bool
forall a. Parser Char a -> Parser Char a
skip Parser Char Bool
parseExp1)
Bool -> Parser Char Bool
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Parser Char Bool) -> Bool -> Parser Char Bool
forall a b. (a -> b) -> a -> b
$ (Bool -> Bool -> Bool) -> Bool -> [Bool] -> Bool
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Bool -> Bool -> Bool
(&&) Bool
a [Bool]
bs
parseExp0 :: TextParser Bool
parseExp0 :: Parser Char Bool
parseExp0 =
do Parser Char String -> Parser Char String
forall a. Parser Char a -> Parser Char a
skip (String -> Parser Char String
isWord String
"!")
Bool
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
Bool -> Parser Char Bool
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Bool
not Bool
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 Integer
val1 <- TextParser Integer
parseArithExp1
Integer -> Integer -> Bool
op <- TextParser (Integer -> Integer -> Bool)
parseCmpOp
Integer
val2 <- TextParser Integer
parseArithExp1
Bool -> Parser Char Bool
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
val1 Integer -> Integer -> Bool
`op` Integer
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 Integer
sym <- TextParser Integer
parseArithExp1
case Integer
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 Integer
val1 <- TextParser Integer
parseArithExp0
( do Integer -> Integer -> Integer
op <- TextParser (Integer -> Integer -> Integer)
parseArithOp1
Integer
val2 <- TextParser Integer
parseArithExp1
Integer -> TextParser Integer
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
val1 Integer -> Integer -> Integer
`op` Integer
val2)
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
<|> Integer -> TextParser Integer
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
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 Integer
val1 <- TextParser Integer
parseNumber
( do Integer -> Integer -> Integer
op <- TextParser (Integer -> Integer -> Integer)
parseArithOp0
Integer
val2 <- TextParser Integer
parseArithExp0
Integer -> TextParser Integer
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
val1 Integer -> Integer -> Integer
`op` Integer
val2)
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
<|> Integer -> TextParser Integer
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
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 = (String -> Integer) -> Parser Char String -> 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 String -> Integer
safeRead (Parser Char String -> TextParser Integer)
-> Parser Char String -> TextParser Integer
forall a b. (a -> b) -> a -> b
$ Parser Char String -> Parser Char String
forall a. Parser Char a -> Parser Char a
skip Parser Char String
parseSym
where
safeRead :: String -> Integer
safeRead String
s =
case String
s of
Char
'0':Char
'x':String
s' -> (String -> [(Integer, String)]) -> String -> Integer
forall {t} {b}. (t -> [(Integer, b)]) -> t -> Integer
number String -> [(Integer, String)]
forall a. (Eq a, Num a) => ReadS a
readHex String
s'
Char
'0':Char
'o':String
s' -> (String -> [(Integer, String)]) -> String -> Integer
forall {t} {b}. (t -> [(Integer, b)]) -> t -> Integer
number String -> [(Integer, String)]
forall a. (Eq a, Num a) => ReadS a
readOct String
s'
String
_ -> (String -> [(Integer, String)]) -> String -> Integer
forall {t} {b}. (t -> [(Integer, b)]) -> t -> Integer
number String -> [(Integer, String)]
forall a. (Eq a, Num a) => ReadS a
readDec String
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 String -> Parser Char String
forall a. Parser Char a -> Parser Char a
skip (String -> Parser Char String
isWord String
">=")
(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 String -> Parser Char String
forall a. Parser Char a -> Parser Char a
skip (String -> Parser Char String
isWord String
">")
(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 String -> Parser Char String
forall a. Parser Char a -> Parser Char a
skip (String -> Parser Char String
isWord String
"<=")
(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 String -> Parser Char String
forall a. Parser Char a -> Parser Char a
skip (String -> Parser Char String
isWord String
"<")
(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 String -> Parser Char String
forall a. Parser Char a -> Parser Char a
skip (String -> Parser Char String
isWord String
"==")
(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 String -> Parser Char String
forall a. Parser Char a -> Parser Char a
skip (String -> Parser Char String
isWord String
"!=")
(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 String -> Parser Char String
forall a. Parser Char a -> Parser Char a
skip (String -> Parser Char String
isWord String
"+")
(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 String -> Parser Char String
forall a. Parser Char a -> Parser Char a
skip (String -> Parser Char String
isWord String
"-")
(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 String -> Parser Char String
forall a. Parser Char a -> Parser Char a
skip (String -> Parser Char String
isWord String
"*")
(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 String -> Parser Char String
forall a. Parser Char a -> Parser Char a
skip (String -> Parser Char String
isWord String
"/")
(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 String -> Parser Char String
forall a. Parser Char a -> Parser Char a
skip (String -> Parser Char String
isWord String
"%")
(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)
parseSymOrCall :: SymTab HashDefine -> TextParser String
parseSymOrCall :: SymTab HashDefine -> Parser Char String
parseSymOrCall SymTab HashDefine
st =
do String
sym <- Parser Char String -> Parser Char String
forall a. Parser Char a -> Parser Char a
skip Parser Char String
parseSym
[String]
args <- TextParser [String] -> TextParser [String]
forall a. Parser Char a -> Parser Char a
parenthesis (TextParser [String] -> TextParser [String]
forall a. Parser Char a -> Parser Char a
forall (p :: * -> *) a. Commitment p => p a -> p a
commit (TextParser [String] -> TextParser [String])
-> TextParser [String] -> TextParser [String]
forall a b. (a -> b) -> a -> b
$ SymTab HashDefine -> Parser Char String
parseSymOrCall SymTab HashDefine
st Parser Char String -> Parser Char String -> TextParser [String]
forall (p :: * -> *) a sep. PolyParse p => p a -> p sep -> p [a]
`sepBy` Parser Char String -> Parser Char String
forall a. Parser Char a -> Parser Char a
skip (String -> Parser Char String
isWord String
","))
String -> Parser Char String
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Parser Char String) -> String -> Parser Char String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
convert String
sym [String]
args
Parser Char String -> Parser Char String -> Parser Char String
forall a. Parser Char a -> Parser Char a -> Parser Char a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
do String
sym <- Parser Char String -> Parser Char String
forall a. Parser Char a -> Parser Char a
skip Parser Char String
parseSym
String -> Parser Char String
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Parser Char String) -> String -> Parser Char String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
convert String
sym []
where
convert :: String -> [String] -> String
convert String
sym [String]
args =
case String -> SymTab HashDefine -> Maybe HashDefine
forall v. String -> SymTab v -> Maybe v
lookupST String
sym SymTab HashDefine
st of
Maybe HashDefine
Nothing -> String
sym
Just (a :: HashDefine
a@SymbolReplacement{}) -> SymTab HashDefine -> String -> String
recursivelyExpand SymTab HashDefine
st (HashDefine -> String
replacement HashDefine
a)
Just (a :: HashDefine
a@MacroExpansion{}) -> SymTab HashDefine -> String -> String
recursivelyExpand SymTab HashDefine
st (HashDefine -> [String] -> Bool -> String
expandMacro HashDefine
a [String]
args Bool
False)
Just (a :: HashDefine
a@AntiDefined{}) -> HashDefine -> String
name HashDefine
a
recursivelyExpand :: SymTab HashDefine -> String -> String
recursivelyExpand :: SymTab HashDefine -> String -> String
recursivelyExpand SymTab HashDefine
st String
inp =
case Parser Char String -> String -> (Either String String, String)
forall t a. Parser t a -> [t] -> (Either String a, [t])
runParser (SymTab HashDefine -> Parser Char String
parseSymOrCall SymTab HashDefine
st) String
inp of
(Left String
msg, String
_) -> String
inp
(Right String
s, String
_) -> String
s
parseSym :: TextParser String
parseSym :: Parser Char String
parseSym = Parser Char Char -> Parser Char String
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 -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`String
"'`_"))
Parser Char String -> Parser Char String -> Parser Char String
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
do String
xs <- Parser Char String
allAsString
String -> Parser Char String
forall a. String -> Parser Char a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Char String) -> String -> Parser Char String
forall a b. (a -> b) -> a -> b
$ String
"Expected an identifier, got \""String -> String -> String
forall a. [a] -> [a] -> [a]
++String
xsString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\""
notIdent :: Char -> Bool
notIdent :: Char -> Bool
notIdent Char
c = Bool -> Bool
not (Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
cChar -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`String
"'`_")
skip :: TextParser a -> TextParser a
skip :: forall a. Parser Char a -> Parser Char a
skip TextParser a
p = Parser Char Char -> Parser Char String
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 String -> 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
parenthesis :: TextParser a -> TextParser a
parenthesis :: forall a. Parser Char a -> Parser Char a
parenthesis TextParser a
p = do String -> Parser Char String
isWord String
"("
a
x <- TextParser a
p
String -> Parser Char String
isWord String
")"
a -> TextParser a
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
file :: SymTab HashDefine -> String -> String
file :: SymTab HashDefine -> String -> String
file SymTab HashDefine
st String
name =
case String
name of
(Char
'"':String
ns) -> String -> String
forall a. HasCallStack => [a] -> [a]
init String
ns
(Char
'<':String
ns) -> String -> String
forall a. HasCallStack => [a] -> [a]
init String
ns
String
_ -> let ex :: String
ex = SymTab HashDefine -> String -> String
recursivelyExpand SymTab HashDefine
st String
name in
if String
ex String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
name then String
name else SymTab HashDefine -> String -> String
file SymTab HashDefine
st String
ex