From 4746aa52f85f4dc3ce8e195f0a5fd8afe2d54378 Mon Sep 17 00:00:00 2001
From: tomsmeding <tom.smeding@gmail.com>
Date: Mon, 18 Nov 2019 18:35:40 +0100
Subject: Fix includes relative to lisp file

---
 Parser.hs | 32 +++++++++++++++++++++++++-------
 1 file changed, 25 insertions(+), 7 deletions(-)

(limited to 'Parser.hs')

diff --git a/Parser.hs b/Parser.hs
index 93d457c..d7f3872 100644
--- a/Parser.hs
+++ b/Parser.hs
@@ -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
-- 
cgit v1.2.3-70-g09d2