module Hpp (parseDefinition, preprocess,
hppReadFile, hppIO, HppCaps, hppFileContents) where
import Control.Arrow (first)
import Control.Monad (unless)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.State.Strict (StateT, evalStateT)
import Data.Char (isSpace)
import Data.IORef
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import Data.String (fromString)
import Hpp.Config (Config, curFileNameF, curFileName, includePaths,
eraseCComments, spliceLongLines, inhibitLinemarkers,
replaceTrigraphs)
import Hpp.Env (deleteKey, insertPair, lookupKey)
import Hpp.Expansion (expandLine)
import Hpp.Expr (evalExpr, parseExpr)
import Hpp.Parser (Parser, ParserT, replace, await, awaitJust, droppingWhile,
precede, takingWhile, insertInputSegment, onElements,
evalParse, onInputSegment)
import Hpp.StringSig
import Hpp.Tokens (Token(..), importants, isImportant, newLine, trimUnimportant,
detokenize, notImportant, tokenize, skipLiteral)
import Hpp.Types
import System.Directory (doesFileExist)
import System.FilePath ((</>))
import Text.Read (readMaybe)
import Prelude hiding (String)
import qualified Prelude as P
trigraphs :: [(Char, Char)]
trigraphs = [ ('=', '#')
, ('/', '\\')
, ('\'', '^')
, ('(', '[')
, (')', ']')
, ('!', '|')
, ('<', '{')
, ('>', '}')
, ('-', '~') ]
trigraphReplacement :: Stringy s => s -> s
trigraphReplacement s = aux (breakOn [("??", ())] s)
where aux Nothing = s
aux (Just (_, pre, pos)) =
case uncons pos of
Nothing -> pre <> "??"
Just (c,t) ->
case lookup c trigraphs of
Just c' -> snoc pre c' <> trigraphReplacement t
Nothing -> snoc pre '?' <> trigraphReplacement (cons '?' pos)
lineSplicing :: Stringy s => [s] -> [s]
lineSplicing = go id
where go acc [] = [acc mempty]
go acc (ln:lns) = case unsnoc ln of
Nothing -> acc mempty : go id lns
Just (ini, '\\') -> go (acc . (ini<>)) lns
Just _ -> acc ln : go id lns
breakBlockCommentStart :: Stringy s => s -> Maybe (s, s)
breakBlockCommentStart s =
case breakCharOrSub '"' "/*" s of
NoMatch -> Nothing
CharMatch pre pos -> let (lit, rest) = skipLiteral pos
in first ((pre <> lit) <>) <$>
breakBlockCommentStart rest
SubMatch pre pos -> Just (pre, pos)
breakBlockCommentEnd :: Stringy s => s -> Maybe s
breakBlockCommentEnd s =
case breakCharOrSub '"' "*/" s of
NoMatch -> Nothing
CharMatch _ pos -> let (_, rest) = skipLiteral pos
in breakBlockCommentEnd rest
SubMatch _ pos -> Just pos
dropOneLineBlockComments :: Stringy s => s -> s
dropOneLineBlockComments s =
case breakCharOrSub '"' "/*"s of
NoMatch -> s
CharMatch pre pos ->
let (lit,rest) = skipLiteral pos
in snoc pre '"' <> lit <> dropOneLineBlockComments rest
SubMatch pre pos ->
case breakOn [("*/", ())] pos of
Nothing -> pre <> "/*"
Just (_,_,pos') -> snoc pre ' ' <> dropOneLineBlockComments pos'
removeMultilineComments :: Stringy s => Int -> [s] -> [s]
removeMultilineComments !lineStart = goStart lineStart
where goStart _ [] = []
goStart !curLine (ln:lns) =
case breakBlockCommentStart ln of
Nothing -> ln : goStart (curLine+1) lns
Just (pre,_) -> goEnd (curLine+1) pre lns
goEnd _ _ [] = error "Unmatched /*"
goEnd !curLine pre (ln:lns) =
case breakBlockCommentEnd ln of
Nothing -> goEnd (curLine+1) pre lns
Just pos
| sall isSpace (pre<>pos) ->
("#line "<> fromString (show (curLine+1))) : goStart (curLine + 1) lns
| otherwise -> (pre<>pos)
: ("#line "<> fromString (show (curLine+1)))
: goStart (curLine+1) lns
commentRemoval :: Stringy s => [s] -> [s]
commentRemoval = removeMultilineComments 1 . map dropOneLineBlockComments
prepTOKENSplices :: [TOKEN] -> [TOKEN]
prepTOKENSplices = map (fmap copy) . 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 params' = map copy params
subst toks gamma = go toks
where go [] = []
go (p@(Important "##"):t@(Important s):ts) =
case lookup 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 lookup 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 lookup s gamma of
Nothing -> Rescan t : go ts
Just (_,arg) ->
Rescan (Important (stringify arg)) : go ts
go (t@(Important s) : ts) =
case lookup 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 (cons '#' 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 <> sdropWhile isSpace t)) : ts)
paste (t:ts) = t : paste ts
modifyState :: (Monad m, HasHppState m) => (HppState -> HppState) -> m ()
modifyState f = getState >>= setState . f
streamNewFile :: (Monad m, HasHppState m)
=> FilePath -> [[TOKEN]] -> Parser m [TOKEN] ()
streamNewFile fp s =
do (oldCfg,oldLine) <- do st <- getState
let cfg = hppConfig st
cfg' = cfg { curFileNameF = pure fp }
ln = hppLineNum st
setState (st {hppConfig = cfg', hppLineNum = 1})
return (cfg, ln)
insertInputSegment
s (modifyState (setL lineNum oldLine . setL config oldCfg))
includeCandidates :: [FilePath] -> P.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] -> P.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] -> P.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 :: forall m a src. (MonadIO m, HasHppState m)
=> (FilePath -> m src)
-> (src -> m ())
-> HppT src m a
-> m (Either (FilePath,Error) a)
runHpp source sink m = runHppT m >>= go
where go :: FreeF (HppF src) a (HppT src m a)
-> m (Either (FilePath, Error) a)
go (PureF x) = return $ Right x
go (FreeF s) = case s of
ReadFile ln file k ->
(includePaths <$> use config)
>>= liftIO . flip searchForInclude file
>>= readAux ln file k
ReadNext ln file k ->
(includePaths <$> use config)
>>= liftIO . flip searchForNextInclude file
>>= readAux ln file k
WriteOutput output k -> sink output >> runHppT k >>= go
readAux ln file _ Nothing =
Left . (, IncludeDoesNotExist ln file) . curFileName <$> use config
readAux _ln _file k (Just file') =
source file' >>= runHppT . k >>= go
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 (copy name, Object (map (fmap copy) rhs))
_ -> Nothing
takeLine :: (Monad m, HasError m, HasHppState m) => Parser m [TOKEN] [TOKEN]
takeLine = (onElements $ do
ln <- takingWhile (not . newLine)
eat <- awaitJust "takeLine"
case eat of
Other "\n" -> return ()
wat -> error $ "Expected newline: "++show wat++" after "++show ln
return ln)
<* (lineNum %= (+1))
dropLine :: (Monad m, HasError m, HasHppState m) => Parser m [TOKEN] ()
dropLine = do onElements $ do
droppingWhile (not . newLine)
eat <- awaitJust "dropLine"
case eat of
Other "\n" -> return ()
wat -> error $ "Expected dropped newline: "++show wat
lineNum %= (+1)
expandLineP :: (Monad m, HasHppState m, HasEnv m, HasError m)
=> Parser m [TOKEN] [TOKEN]
expandLineP =
do st <- getState
let ln = hppLineNum st
cfg = hppConfig st
expandLine cfg ln
hppReadFile :: Monad m => Int -> FilePath -> HppT src m src
hppReadFile n file = HppT (pure (FreeF (ReadFile n file return)))
hppReadNext :: Monad m => Int -> FilePath -> HppT src m src
hppReadNext n file = HppT (pure (FreeF (ReadNext n file return)))
directive :: forall m. (Monad m, HppCaps m)
=> HppT [String] (Parser m [TOKEN]) Bool
directive = lift (onElements (awaitJust "directive")) >>= aux
where aux :: TOKEN -> HppT [String] (Parser m [TOKEN]) Bool
aux (Important cmd) = case cmd of
"pragma" -> True <$ lift dropLine
"define" -> True <$
(lift $ fmap parseDefinition takeLine >>= \case
Nothing -> use lineNum >>=
throwError . BadMacroDefinition
Just def -> env %= insertPair def)
"undef" -> do name <- lift . onElements $ do
droppingWhile (not . isImportant)
Important name <- awaitJust "undef"
return name
lift dropLine
env %= deleteKey name
return True
"include" -> True <$ includeAux hppReadFile
"include_next" -> True <$ includeAux hppReadNext
"line" -> do lift (onElements droppingSpaces)
toks <- lift (init <$> expandLineP)
case toks of
Important (toChars -> n):optFile ->
case readMaybe n of
Nothing -> use lineNum >>=
throwError . flip BadLineArgument n
Just ln' -> do
unless (null optFile) $ do
let fn = toChars . unquote . detokenize
. dropWhile (not . isImportant)
$ optFile
config %= (\cfg -> cfg { curFileNameF = pure fn })
lineNum .= ln'
return True
_ -> use lineNum >>=
throwError
. flip BadLineArgument (toChars (detokenize toks))
"ifdef" ->
do toks <- lift (onElements droppingSpaces >> takeLine)
ln <- use lineNum
case takeWhile isImportant toks of
[Important t] ->
lookupMacro t >>= \case
Nothing ->
lift (dropBranchLine ln >>= replace . fst)
Just _ ->
lift (onInputSegment (takeBranchFun ln))
_ -> throwError . UnknownCommand ln $
"ifdef "++ toChars (detokenize toks)
return True
"ifndef" ->
do toks <- lift (onElements droppingSpaces >> takeLine)
ln <- use lineNum
case takeWhile isImportant toks of
[Important t] ->
lookupMacro t >>= \case
Nothing -> lift (onInputSegment (takeBranchFun ln))
Just _ -> lift (dropBranchLine ln >>= replace . fst)
_ -> throwError . UnknownCommand ln $
"ifndef "++ toChars (detokenize toks)
return True
"else" -> True <$ lift dropLine
"if" -> True <$ ifAux
"elif" -> True <$ ifAux
"endif" -> True <$ lift dropLine
"error" -> do toks <- lift (onElements droppingSpaces >> takeLine)
ln <- subtract 1 <$> use lineNum
curFile <- curFileName <$> use config
let tokStr = toChars (detokenize toks)
throwError $ UserError ln (tokStr++" ("++curFile++")")
"warning" -> True <$ lift dropLine
_ -> return False
aux _ = error "Impossible unimportant directive"
includeAux :: (LineNum -> FilePath -> HppT src (Parser m [TOKEN]) [String])
-> HppT src (Parser m [TOKEN]) ()
includeAux readFun =
do fileName <- lift (toChars . detokenize . trimUnimportant . init
<$> expandLineP)
ln <- use lineNum
src <- prepareInput <*> readFun ln fileName
lineNum .= ln+1
lift (streamNewFile (unquote fileName) src)
ifAux =
do toks <- lift (onElements droppingSpaces >> takeLine)
e <- use env
ln <- use lineNum
lineNum .= ln 1
ex <- lift (lift (evalParse expandLineP [squashDefines e toks]))
let res = evalExpr <$> parseExpr (map (fmap toChars) ex)
lineNum .= ln
if maybe False (/= 0) res
then lift (onInputSegment (takeBranchFun ln))
else lift (dropBranchLine ln >>= replace . fst)
squashDefines :: Env -> [TOKEN] -> [TOKEN]
squashDefines _ [] = []
squashDefines env' (Important "defined" : ts) = go ts
where go (t@(Other _) : ts') = t : go ts'
go (t@(Important "(") : ts') = t : go ts'
go (Important t : ts') =
case lookupKey t env' of
Nothing -> Important "0" : squashDefines env' ts'
Just _ -> Important "1" : squashDefines env' ts'
go [] = []
squashDefines env' (t : ts) = t : squashDefines env' ts
getCmd :: [TOKEN] -> Maybe String
getCmd = aux . dropWhile notImportant
where aux (Important "#" : ts) = case dropWhile notImportant ts of
(Important cmd:_) -> Just cmd
_ -> Nothing
aux _ = Nothing
droppingSpaces ::(Monad m) => ParserT m src TOKEN ()
droppingSpaces = droppingWhile notImportant
dropBranchFun :: [[TOKEN]] -> (Int, [[TOKEN]])
dropBranchFun = go (1::Int) 0
where go _ !n [] = (n,[])
go !nesting !n (ln:lns) =
case getCmd ln of
Just cmd
| cmd == "endif" -> if nesting == 1
then (n, ln:lns)
else go (nesting1) (n+1) lns
| cmd `elem` ["if","ifdef","ifndef"] ->
go (nesting+1) (n+1) lns
| cmd `elem` ["else","elif"] -> if nesting == 1
then (n, ln : lns)
else go nesting (n+1) lns
_ -> go nesting (n+1) lns
takeBranchFun :: LineNum -> [[TOKEN]] -> [[TOKEN]]
takeBranchFun = go (1::Int)
where go _ _ [] = []
go 0 !n lns = yieldLineNum n : lns
go !nesting !n (ln:lns) =
case getCmd ln of
Just cmd
| cmd `elem` ["if","ifdef","ifndef"] ->
ln : go (nesting+1) (n+1) lns
| cmd == "endif" -> ln : go (nesting 1) (n + 1) lns
| nesting == 1 && cmd `elem` ["else","elif"] ->
let (numSkipped, lns') = dropBranchFun lns
in go 1 (n+1+numSkipped) lns'
_ -> ln : go nesting (n+1) lns
yieldLineNum :: LineNum -> [TOKEN]
yieldLineNum !ln = [Important ("#line " <> fromString (show ln)), Other "\n"]
dropBranchLine :: (HasError m, Monad m)
=> LineNum -> Parser m [TOKEN] ([TOKEN], LineNum)
dropBranchLine !ln = do (el, numSkipped) <- dropBranch
let ln' = ln + numSkipped
return (yieldLineNum ln' ++ fromMaybe [] el, ln')
dropBranch :: (HasError m, Monad m) => Parser m [TOKEN] (Maybe [TOKEN], Int)
dropBranch = go (1::Int) 0
where go !nesting !n =
do ln <- awaitJust "dropBranch"
case getCmd ln of
Just cmd
| cmd == "endif" -> if nesting == 1
then return (Nothing, n+1)
else go (nesting1) (n+1)
| cmd `elem` ["if","ifdef","ifndef"] ->
go (nesting+1) (n+1)
| cmd `elem` ["else", "elif"] -> if nesting == 1
then return (Just ln, n+1)
else go nesting (n+1)
_ -> go nesting (n+1)
macroExpansion :: (Monad m, HppCaps m)
=> HppT [String] (Parser m [TOKEN]) (Maybe [TOKEN])
macroExpansion = do
lift await >>= \case
Nothing -> return Nothing
Just ln ->
case dropWhile notImportant ln of
[] -> Just ln <$ (lineNum %= (+1))
Important "#":rst -> do lift (replace (dropWhile notImportant rst))
processed <- directive
if processed
then macroExpansion
else Just ln <$ lift takeLine
_ -> lift (replace ln >> (Just <$> expandLineP)) <* (lineNum %= (+1))
type HppCaps t = (HasError t, HasHppState t, HasEnv t)
parseStreamHpp :: Monad m
=> HppT t (Parser m i) (Maybe t) -> HppT t (Parser m i) ()
parseStreamHpp m = go
where go = m >>= \case
Nothing -> return ()
Just o -> writeOutput o >> go
normalCPP :: [String] -> [[TOKEN]]
normalCPP = map ((++ [Other "\n"]) . tokenize)
. lineSplicing
. removeMultilineComments 1
. map (dropOneLineBlockComments . trigraphReplacement)
haskellCPP :: [String] -> [[TOKEN]]
haskellCPP = map ((++[Other "\n"]) . tokenize)
. lineSplicing
. commentRemoval
genericConfig :: Config -> [String] -> [[TOKEN]]
genericConfig cfg = map ((++ [Other "\n"]) . tokenize)
. (if spliceLongLines cfg then lineSplicing else id)
. (if eraseCComments cfg then commentRemoval else id)
. (if replaceTrigraphs cfg then map trigraphReplacement else id)
prepareInput :: (Monad m, HppCaps m) => m ([String] -> [[TOKEN]])
prepareInput =
do cfg <- getL config <$> getState
case () of
_ | eraseCComments cfg && spliceLongLines cfg
&& not (inhibitLinemarkers cfg) -> pure normalCPP
_ | (eraseCComments cfg && spliceLongLines cfg
&& (not (replaceTrigraphs cfg))) ->
pure haskellCPP
_ | otherwise -> pure (genericConfig cfg)
preprocess :: (Monad m, HppCaps m)
=> [String] -> HppT [String] (Parser m [TOKEN]) ()
preprocess src =
do cfg <- getL config <$> getState
prep <- prepareInput
let prepOutput = if inhibitLinemarkers cfg then aux else pure
lift (precede (prep src))
parseStreamHpp (fmap (prepOutput . detokenize) <$> macroExpansion)
where aux xs | sIsPrefixOf "#line" xs = []
| otherwise = [xs]
dischargeHppCaps :: Monad m
=> Config -> Env
-> Parser (StateT HppState (ExceptT Error m))
i
(Either (a, Error) b)
-> m (Maybe Error)
dischargeHppCaps cfg env' m =
runExceptT
(evalStateT
(evalParse (m >>= either (throwError . snd) return) [])
initialState)
>>= return . either Just (const Nothing)
where initialState = setL env env' $ emptyHppState cfg
hppIO' :: Config -> Env -> ([String] -> IO ()) -> [String] -> IO (Maybe Error)
hppIO' cfg env' snk src =
dischargeHppCaps cfg env' $
runHpp (liftIO . readLines) (liftIO . snk) (preprocess src)
hppIO :: Config -> Env -> ([String] -> IO ()) -> [String] -> IO ()
hppIO cfg env' snk = fmap (maybe () (error . show)) . hppIO' cfg env' snk
hppFileContents :: Config -> Env -> FilePath -> [String] -> IO (Either Error [String])
hppFileContents cfg env' fileName src = do
r <- newIORef id
let snk xs = modifyIORef r (. (xs++))
hppIO' (cfg {curFileNameF = pure fileName}) env' snk src >>= \case
Nothing -> Right . ($ []) <$> readIORef r
Just e -> return (Left e)