module Hpp (parseDefinition, preprocess,
liftHpp, errorHpp, getConfig, setConfig, hppReadFile,
runErrHppIO) where
import Control.Arrow (second)
import Control.Exception (catch, IOException)
import Control.Monad ((<=<))
import Data.Char (isSpace)
import Data.Functor.Identity
import System.Directory (doesFileExist)
import System.FilePath ((</>))
import Text.Read (readMaybe)
import Hpp.Config
import Hpp.Env
import Hpp.Expansion
import Hpp.Expr
import Hpp.String
import Hpp.Tokens
import Hpp.Types
trigraphs :: [(Char, Char)]
trigraphs = [ ('=', '#')
, ('/', '\\')
, ('\'', '^')
, ('(', '[')
, (')', ']')
, ('!', '|')
, ('<', '{')
, ('>', '}')
, ('-', '~') ]
data TrigraphPrefix = TP0 | TP1 | TP2 deriving (Enum, Show)
trigraphReplacement :: String -> String
trigraphReplacement = go TP0
where go :: TrigraphPrefix -> String -> String
go n [] = replicate (fromEnum n) '?'
go TP2 ('?':xs) = '?' : go TP2 xs
go TP2 (x:xs) = case lookup x trigraphs of
Just x' -> x' : go TP0 xs
Nothing -> "??" ++ x : go TP0 xs
go i ('?':xs) = go (succ i) xs
go TP0 (x:xs) = x : go TP0 xs
go TP1 (x:xs) = '?' : x : go TP0 xs
lineSplicing :: [String] -> [String]
lineSplicing [] = []
lineSplicing [x] = [x]
lineSplicing ([]:t) = [] : lineSplicing t
lineSplicing (x:t@(y:xs))
| last x == '\\' = lineSplicing ((init x++y) : xs)
| otherwise = x : lineSplicing t
spliceApplications :: [String] -> [String]
spliceApplications = go Nothing
where go :: Maybe String -> [String] -> [String]
go prev [] = maybe [] (:[]) prev
go prev (l:ls)
| headIs '#' l = let p = maybe [] (:[]) prev
in p ++ l : go Nothing ls
go (Just prev) (l:ls)
| headOp opStarts l = go Nothing ((prev++l) : ls)
| otherwise = prev : go Nothing (l:ls)
go Nothing (l1:l2:ls)
| headOp opEnds $ reverse l1 = go Nothing ((l1++l2):ls)
go Nothing (l:ls) = go (Just l) ls
opEnds = [',','+','-','*','/','(','=','%','&','|','^']
opStarts = [',','+','-','*','/','(',')','=','%','&','|','^']
headOp ops xs = case dropWhile isSpace xs of
c:_ -> c `elem` ops
_ -> False
headIs x xs = case dropWhile isSpace xs of
(y:_) -> y == x
_ -> False
breakBlockCommentStart :: String -> Maybe (String, String)
breakBlockCommentStart = go id
where go _ [] = Nothing
go acc ('"' : ts) = skipLiteral (go . (acc .)) ts
go acc ('/' : '*' : t) = Just (acc [], t)
go acc (c:cs) = go (acc . (c:)) cs
breakBlockCommentEnd :: String -> Maybe String
breakBlockCommentEnd [] = Nothing
breakBlockCommentEnd (_:'"':cs) = skipLiteral (const breakBlockCommentEnd) cs
breakBlockCommentEnd ('*':'/':t) = Just (' ':t)
breakBlockCommentEnd (_:cs) = breakBlockCommentEnd cs
dropOneLineBlockComments :: String -> String
dropOneLineBlockComments [] = []
dropOneLineBlockComments (c:'"':cs) =
c : skipLiteral (\x y -> x [] ++ dropOneLineBlockComments y) cs
dropOneLineBlockComments ('/':'*':cs) = go cs
where go [] = "/*"
go ('*':'/':t) = ' ' : dropOneLineBlockComments t
go (_:t) = go t
dropOneLineBlockComments (c:cs) = c : dropOneLineBlockComments cs
dropLineComments :: String -> String
dropLineComments [] = []
dropLineComments ('/':'/':_) = []
dropLineComments (c:cs) = c : dropLineComments cs
removeMultilineComments :: Int -> [String] -> [String]
removeMultilineComments _ [] = []
removeMultilineComments lineNum (l:ls) =
case breakBlockCommentStart l of
Nothing -> l : removeMultilineComments (lineNum+1) ls
Just (pre,_) ->
case go 0 ls of
(numSkipped, []) -> pre : replicate (lineNum+numSkipped) []
(numSkipped, (l':ls')) ->
let lineNum' = lineNum + numSkipped
in (pre ++ l') : ("#line " ++ show (lineNum'+1))
: removeMultilineComments lineNum' ls'
where go :: Int -> [String] -> (Int, [String])
go numSkipped [] = (numSkipped, [])
go numSkipped (l':ls') =
case breakBlockCommentEnd l' of
Nothing -> go (numSkipped + 1) ls'
Just rst -> (numSkipped+1, rst : ls')
commentRemoval :: [String] -> [String]
commentRemoval = map dropLineComments
. removeMultilineComments 1
. map dropOneLineBlockComments
prepTokenSplices :: [Token] -> [Token]
prepTokenSplices = dropSpaces [] . mergeTokens []
where
mergeTokens acc [] = acc
mergeTokens acc (Important "#" : Important "#" : ts) =
mergeTokens (Important "##" : acc) (dropWhile (not . isImportant) ts)
mergeTokens acc (t:ts) = mergeTokens (t : acc) ts
dropSpaces acc [] = acc
dropSpaces acc (t@(Important "##") : ts) =
dropSpaces (t : acc) (dropWhile (not . isImportant) ts)
dropSpaces acc (t:ts) = dropSpaces (t : acc) ts
functionMacro :: [String] -> [Token] -> [([Scan],String)] -> [Scan]
functionMacro params body = paste
. subst body'
. zip params
where subst toks gamma = go toks
where go [] = []
go (p@(Important "##"):t@(Important s):ts) =
case lookupKey s gamma of
Nothing -> Rescan p : Rescan t : go ts
Just ((_,arg),_) ->
Rescan p : Rescan (Important arg) : go ts
go (t@(Important s):p@(Important "##"):ts) =
case lookupKey s gamma of
Nothing -> Rescan t : go (p:ts)
Just ((_,arg),_) -> Rescan (Important arg) : go (p:ts)
go (t@(Important "##"):ts) = Rescan t : go ts
go (t@(Important ('#':s)) : ts) =
case lookupKey s gamma of
Nothing -> Rescan t : go ts
Just ((_,arg),_) ->
Rescan (Important (stringify arg)) : go ts
go (t@(Important s) : ts) =
case lookupKey s gamma of
Nothing -> Rescan t : go ts
Just ((arg,_),_) -> arg ++ go ts
go (t:ts) = Rescan t : go ts
prepStringify [] = []
prepStringify (Important "#" : ts) =
case dropWhile (not . isImportant) ts of
(Important t : ts') -> Important ('#':t) : prepStringify ts'
_ -> Important "#" : ts
prepStringify (t:ts) = t : prepStringify ts
body' = prepStringify . prepTokenSplices $
dropWhile (not . isImportant) body
paste [] = []
paste (Rescan (Important s) : Rescan (Important "##")
: Rescan (Important t) : ts) =
paste (Rescan (Important (trimSpaces s ++ dropWhile isSpace t)) : ts)
paste (t:ts) = t : paste ts
errorHpp :: Error -> ErrHpp a
errorHpp e = do f <- liftHpp . fmap curFileName $ getConfig
ErrHpp . pure $ Left (f, e)
liftEither :: Either Error a -> ErrHpp a
liftEither = either errorHpp pure
liftHpp :: Hpp a -> ErrHpp a
liftHpp = ErrHpp . fmap Right
hppReadFile :: Int -> FilePath -> Hpp String
hppReadFile n file = ReadFile n file return
hppReadNext :: Int -> FilePath -> Hpp String
hppReadNext n file = ReadNext n file return
getConfig :: Hpp Config
getConfig = GetConfig return
setConfig :: Config -> Hpp ()
setConfig = flip SetConfig (return ())
withConfig :: Config -> ErrHpp a -> ErrHpp a
withConfig cfg m = do oldCfg <- liftHpp getConfig
liftHpp $ setConfig cfg
r <- m
liftHpp $ setConfig oldCfg
return r
includeCandidates :: [FilePath] -> String -> Maybe [FilePath]
includeCandidates searchPath nm =
case nm of
'<':nm' -> Just $ sysSearch (init nm')
'"':nm' -> let nm'' = init nm'
in Just $ nm'' : sysSearch nm''
_ -> Nothing
where sysSearch f = map (</> f) searchPath
searchForInclude :: [FilePath] -> String -> IO (Maybe FilePath)
searchForInclude paths = maybe (return Nothing) aux . includeCandidates paths
where aux [] = return Nothing
aux (f:fs) = do exists <- doesFileExist f
if exists then return (Just f) else aux fs
searchForNextInclude :: [FilePath] -> String -> IO (Maybe FilePath)
searchForNextInclude paths = maybe (return Nothing) (aux False)
. includeCandidates paths
where aux _ [] = return Nothing
aux n (f:fs) = do exists <- doesFileExist f
if exists
then if n
then return (Just f)
else aux True fs
else aux n fs
runHpp :: Config -> Hpp a -> IO (Either (FilePath,Error) a)
runHpp cfg = go
where go (Pure x) = return (Right x)
go (ReadFile ln file k) = searchForInclude (includePaths cfg) file
>>= readAux ln file k
go (ReadNext ln file k) = searchForNextInclude (includePaths cfg) file
>>= readAux ln file k
go (GetConfig k) = go (k cfg)
go (SetConfig cfg' k) = runHpp cfg' k
curFile = curFileName cfg
readAux ln file _ Nothing =
return $ Left (curFile, IncludeDoesNotExist ln file)
readAux ln file k (Just file') =
catch (Just <$> readFile file')
(\(_::IOException) -> return Nothing)
>>= maybe (return . Left $ (curFile, FailedInclude ln file))
(go . k)
parseDefinition :: [Token] -> Maybe (String, Macro)
parseDefinition toks =
case dropWhile (not . isImportant) toks of
(Important name:Important "(":rst) ->
let params = takeWhile (/= ")") $ filter (/= ",") (importants rst)
body = trimUnimportant . tail $ dropWhile (/= Important ")") toks
macro = Function (length params) (functionMacro params body)
in Just (name, macro)
(Important name:_) ->
let rhs = case dropWhile (/= Important name) toks of
[] -> [Important ""]
str@(_:t)
| all (not . isImportant) str -> [Important ""]
| otherwise -> trimUnimportant t
in Just (name, Object rhs)
_ -> Nothing
trimUnimportant :: [Token] -> [Token]
trimUnimportant = aux id . dropWhile (not .isImportant)
where aux _ [] = []
aux acc (t@(Important _) : ts) = acc (t : aux id ts)
aux acc (t@(Other _) : ts) = aux (acc . (t:)) ts
directive :: Config -> LineNum -> String
-> ErrHpp ((LineNum -> [String] -> Config -> Env
-> [String] -> ErrHpp r)
-> Env -> [String] -> ErrHpp r)
directive cfg ln s =
case importants toks of
"pragma":_ -> pure $ \k -> k ln' [] cfg
"define":_ -> case parseDefinition . tail $
dropWhile (/= Important "define") toks of
Nothing -> errorHpp $ BadMacroDefinition ln
Just def -> pure $ \k -> k ln' [] cfg . (def :)
["undef",name] -> pure $ \k -> k ln' [] cfg . deleteKey name
"include":_ -> includeAux hppReadFile . trimUnimportant . tail
$ dropWhile (/= Important "include") toks
"include_next":_ -> includeAux hppReadNext . trimUnimportant . tail
$ dropWhile (/= Important "include_next") toks
("line":_) ->
pure $ \k env lns ->
do (env',rst) <- liftEither . expandLine cfg ln env . tail
$ dropWhile (/= Important "line") toks
case dropWhile (not . isImportant) rst of
Important n:optFile ->
case readMaybe n of
Nothing -> errorHpp $ BadLineArgument ln n
Just ln'' ->
let cfg' = case optFile of
[] -> cfg
_ -> let f = unquote
. detokenize
. dropWhile (not . isImportant)
. tail
. dropWhile (not . isImportant)
$ rst
in cfg { curFileNameF = pure f }
in k ln'' [] cfg' env' lns
_ -> errorHpp $ BadLineArgument ln s
["ifdef", x] -> pure $ \k env lns ->
case lookupKey x env of
Nothing -> do lns' <- liftEither $ dropBranch lns
k ln [] cfg env lns'
Just _ -> liftEither (takeBranch lns) >>= k ln [] cfg env
["ifndef", x] -> pure $ \k env lns ->
case lookupKey x env of
Nothing -> liftEither (takeBranch lns)
>>= k ln [] cfg env
Just (_,env') -> do lns' <- liftEither $ dropBranch lns
k ln [] cfg env' lns'
["else"] -> pure $ \k env lns ->
liftEither (takeBranch lns) >>= k ln [] cfg env
"if":_ -> pure $ ifAux "if"
"elif":_ -> pure $ ifAux "elif"
["endif"] -> pure $ \k env -> k ln [] cfg env
"error":_ -> errorHpp . UserError ln . detokenize
. dropWhile (not . isImportant) . tail
$ dropWhile (/= Important "error") toks
"warning":_ -> pure $ \k env -> k ln' [] cfg env
_ -> errorHpp $ UnknownCommand ln s
where toks = tokenize s
ln' = ln + 1
toksAfterCommand cmd = tail $ dropWhile (/= Important cmd) toks
ifAux c k env lns =
do (env',ex) <- liftEither . expandLine cfg ln env . squashDefines env
$ toksAfterCommand c
let res = evalExpr <$> parseExpr ex
if maybe False (/= 0) res
then either errorHpp (k ln [] cfg env') (takeBranch lns)
else either errorHpp (k ln [] cfg env') (dropBranch lns)
includeAux readFun fileToks = pure $ \k env lns ->
do (env', fileName) <- liftEither $ expandLine cfg ln env fileToks
let fileName' = detokenize $ trimUnimportant fileName
cfg' =
cfg { curFileNameF = pure $ unquote fileName' }
(env'',inc) <- liftHpp (readFun ln fileName')
>>= withConfig cfg' . preprocess env'
k ln' [inc] cfg env'' lns
squashDefines :: Env -> [Token] -> [Token]
squashDefines _ [] = []
squashDefines env (Important "defined" : ts) = go ts
where go (t@(Other _) : ts') = t : go ts'
go (Important "(" : ts') = Important "(" : go ts'
go (Important t : ts') =
case lookupKey t env of
Nothing -> Important "0" : squashDefines env ts'
Just (_,env') -> Important "1" : squashDefines env' ts'
go [] = []
squashDefines env (t : ts) = t : squashDefines env ts
getCmd :: String -> Maybe (String,[Token])
getCmd = aux . dropWhile (not . isImportant) . tokenize
where aux (Important "#" : ts) =
let (Important cmd:toks) = dropWhile (not . isImportant) ts
in Just (cmd, toks)
aux _ = Nothing
takeConditional :: [String] -> (DList String -> [String] -> r) -> r
takeConditional lns0 k = go id lns0
where go acc [] = k acc []
go acc (ln:lns) =
case getCmd ln of
Nothing -> go (acc . (ln:)) lns
Just (cmd,_)
| cmd == "endif" -> k (acc . (ln:)) lns
| cmd `elem` ["if","ifdef","ifndef"] ->
takeConditional lns $
\acc' lns' -> go (acc . (ln:) . acc') lns'
| otherwise -> go (acc . (ln:)) lns
takeBranch :: [String] -> Either Error [String]
takeBranch = go id
where go _ [] = Left UnterminatedBranch
go acc (ln:lns) =
case getCmd ln of
Just (cmd,_)
| cmd `elem` ["if","ifdef","ifndef"] ->
takeConditional lns $
\acc' lns' -> go (acc . (ln:) . acc') lns'
| cmd == "endif" -> Right (acc [] ++ lns)
| cmd `elem` ["else","elif"] ->
case dropAllBranches lns of
Right lns' -> Right $ acc [] ++ lns'
Left err -> Left err
_ -> go (acc . (ln:)) lns
dropAllBranches :: [String] -> Either Error [String]
dropAllBranches = aux <=< dropBranch
where aux :: [String] -> Either Error [String]
aux [] = Left UnterminatedBranch
aux (ln:lns) = case getCmd ln of
Just ("endif",_) -> Right lns
_ -> dropAllBranches lns
dropBranch :: [String] -> Either Error [String]
dropBranch = go
where go [] = Left UnterminatedBranch
go (l:ls) = case getCmd l of
Just (cmd,_)
| cmd `elem` ["if","ifdef","ifndef"] ->
dropAllBranches ls >>= go
| cmd `elem` ["else","elif","endif"] -> Right (l:ls)
| otherwise -> go ls
Nothing -> go ls
macroExpansion :: Config
-> Env
-> [String]
-> ErrHpp (Env, [String])
macroExpansion cfg0 macros = go 1 cfg0 macros id
where go :: Int -> Config -> [(String, Macro)]
-> DList String -> [String]
-> ErrHpp (Env, [String])
go _ _ ms acc [] = return (ms, acc [])
go lineNum cfg ms acc (x:xs) =
case dropWhile isSpace x of
[] -> go (lineNum + 1) cfg ms (acc . (x:)) xs
('#':cmd) -> do k <- directive cfg lineNum cmd
k (\lineNum' newLines cfg' ms' remainingInput ->
go lineNum' cfg' ms' (acc . (newLines++))
remainingInput)
ms xs
_ -> do (ms',x') <- either errorHpp pure $
expandLine cfg lineNum ms (tokenize x)
go (lineNum+1) cfg ms' (acc . (detokenize x':)) xs
preprocess :: Env -> String -> ErrHpp (Env, String)
preprocess env inp =
do cfg <- liftHpp $ GetConfig return
let splicer = if spliceLongLines cfg then lineSplicing else id
decomment = if eraseCComments cfg then commentRemoval else id
appSplicer = if runIdentity (spliceApplicationsF cfg)
then spliceApplications else id
go = macroExpansion cfg env
. appSplicer . splicer . decomment
. map trigraphReplacement
fmap (second unlines) . go $ lines inp
runErrHppIO :: Config -> ErrHpp a -> IO a
runErrHppIO cfg = fmap (either err (either err id)) . runHpp cfg . runErrHpp
where err :: (FilePath,Error) -> a
err = error . show