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

---
 Main.hs      | 10 +++++-----
 Parser.hs    | 32 +++++++++++++++++++++++++-------
 lisphs.cabal |  2 +-
 3 files changed, 31 insertions(+), 13 deletions(-)

diff --git a/Main.hs b/Main.hs
index b56edfe..ef98b62 100644
--- a/Main.hs
+++ b/Main.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase, TupleSections #-}
 module Main where
 
 import System.Environment
@@ -16,13 +17,12 @@ usage = do
 
 main :: IO ()
 main = do
-    clargs <- getArgs
-    source <- case clargs of
-        [] -> getContents
-        [fname] -> readFile fname
+    (mfname, source) <- getArgs >>= \case
+        [] -> (Nothing,) <$> getContents
+        [arg] -> (Just arg,) <$> readFile arg
         _ -> usage >> exitFailure
 
-    prog <- parseProgram source >>= either (die . show) return
+    prog <- parseProgram mfname source >>= either (die . show) return
     irprog <- either die return (compileProgram prog)
     let opt = optimise irprog
     -- print opt
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
diff --git a/lisphs.cabal b/lisphs.cabal
index 89ee3c4..83d844d 100644
--- a/lisphs.cabal
+++ b/lisphs.cabal
@@ -12,5 +12,5 @@ executable            lisp
     default-language: Haskell2010
     ghc-options:      -Wall -O2
     build-depends:    base >= 4 && < 5,
-                      containers, mtl, parsec
+                      containers, filepath, mtl, parsec
     other-modules:    AST, Compiler, Intermediate, Optimiser, Parser, VM
-- 
cgit v1.2.3-70-g09d2