diff options
author | tomsmeding <tom.smeding@gmail.com> | 2019-11-18 18:35:40 +0100 |
---|---|---|
committer | tomsmeding <tom.smeding@gmail.com> | 2019-11-18 18:35:40 +0100 |
commit | 4746aa52f85f4dc3ce8e195f0a5fd8afe2d54378 (patch) | |
tree | 2bf667797ad0fe583091860f17c742d5de3c3f18 /Parser.hs | |
parent | 095970d60c7912d330c7c33501a1634c533eced1 (diff) |
Fix includes relative to lisp file
Diffstat (limited to 'Parser.hs')
-rw-r--r-- | Parser.hs | 32 |
1 files changed, 25 insertions, 7 deletions
@@ -1,26 +1,32 @@ +{-# LANGUAGE LambdaCase #-} module Parser(parseProgram, parseExpression) where +import qualified Control.Exception as E import Control.Monad import Control.Monad.Trans import Data.Char +import Data.Maybe +import System.FilePath +import System.IO.Error (isDoesNotExistError) import Text.Parsec import Text.Parsec.Pos import AST -type Parser = ParsecT String () IO +newtype ParserState = ParserState (Maybe FilePath) +type Parser = ParsecT String ParserState IO -parseProgram :: String -> IO (Either ParseError Program) -parseProgram = runParserT pProgram () "" +parseProgram :: Maybe FilePath -> String -> IO (Either ParseError Program) +parseProgram mpath = runParserT pProgram (ParserState mpath) (fromMaybe "" mpath) pProgram :: Parser Program pProgram = between pWhiteComment eof (liftM Program (many pValue)) parseExpression :: String -> IO (Either ParseError Value) -parseExpression = runParserT pExpression () "" +parseExpression = runParserT pExpression (ParserState Nothing) "" pExpression :: Parser Value pExpression = between pWhiteComment eof pValue @@ -61,10 +67,11 @@ pVEllipsis = symbol "..." >> return VEllipsis <?> "ellipsis" pPPC :: Parser Value pPPC = flip label "preprocessor command" $ do symbol "#include" - fname <- pString - src <- liftIO $ readFile fname + incfname <- pString + ParserState basefname <- getState + (fname, src) <- liftIO (readPPCinclude basefname incfname) stateBackup <- getParserState - void $ setParserState (State ("(do " ++ src ++ ")") (initialPos fname) ()) + void $ setParserState (State ("(do " ++ src ++ ")") (initialPos fname) (ParserState (Just fname))) result <- pValue <* eof void $ setParserState stateBackup return result @@ -91,3 +98,14 @@ pWhiteComment = do pComment = flip label "comment" $ do void $ char ';' void (manyTill anyChar (void endOfLine <|> eof)) + +readPPCinclude :: Maybe FilePath -> String -> IO (FilePath, String) +readPPCinclude mbase fname = + let searchDirs = [maybe "." takeDirectory mbase] + cands = map (</> fname) searchDirs + tryCand cand = E.tryJust (guard . isDoesNotExistError) (readFile cand) >>= \case + Left _ -> return Nothing + Right src -> return (Just (cand, src)) + in (catMaybes <$> sequence (map tryCand cands)) >>= \case + [] -> error $ "Cannot find #include'd file '" ++ fname ++ "'" + pair : _ -> return pair |