made preprocessor not reinclude files multiple times

examples/peano.pg

@@ -3,15 +3,11 @@
 -- import basic logic definitions from <logic.pg>
 
 @include logic.pg
-
+@include algebra.pg
-binop (A : *) := A -> A -> A;
 
 comp (A B C : *) (g : B -> C) (f : A -> B) (x : A) : C :=
   g (f x);
 
-assoc (A : *) (op : binop A) := forall (c a b : A),
-  eq A (op a (op b c)) (op (op a b) c);
-
 -- }}}
 
 -- {{{ Axioms

lib/Parser.hs

@@ -236,6 +236,4 @@ parseProgram :: Env -> Text -> Either String Env
 parseProgram initial input = first errorBundlePretty $ evalState (runParserT pProgram "" input) $ emptyBinders initial
 
 handleFile :: Env -> String -> ExceptT String IO Env
-handleFile initial filename = do
+handleFile initial filename = (toString `withExceptT` runPreprocessor filename) >>= liftEither . parseProgram initial
-    text <- toString `withExceptT` preprocess filename
-    liftEither $ parseProgram initial text

lib/Preprocessor.hs

@@ -1,6 +1,6 @@
 module Preprocessor where
 
-import Control.Monad.Except
+import qualified Data.Set as S
 import qualified Data.Text as T
 import System.FilePath
 
@@ -13,23 +13,32 @@ instance ToString PreprocessorError where
     toString = toString . toText
 
 type Result = Either PreprocessorError
-type ResultIO = ExceptT PreprocessorError IO
+type ResultStateIO = ExceptT PreprocessorError (StateT (S.Set FilePath) IO)
 
-concatMapM :: (Applicative f) => (a -> f Text) -> [a] -> f Text
+-- There's a clever way to do this with `foldM` or something, but I think this is still pretty elegant
-concatMapM _ [] = pure mempty
+handleLines :: FilePath -> [Text] -> ResultStateIO Text
-concatMapM f (x : xs) = ((<>) . (<> "\n") <$> f x) <*> concatMapM f xs
+handleLines _ [] = pure ""
+handleLines filename (line : rest) = do
+    line' <- preprocessLine (takeDirectory filename) line
+    rest' <- handleLines filename rest
+    pure $ line' <> "\n" <> rest'
 
-preprocess :: String -> ResultIO Text
+preprocess :: String -> ResultStateIO Text
-preprocess filename = do
+preprocess filename =
-    text <- decodeUtf8With lenientDecode <$> readFileBS filename
+    ifM (gets $ S.member filename) (pure "") $ do
-    result <- concatMapM (preprocessLine $ takeDirectory filename) (lines text)
+        modify $ S.insert filename
-    putStrLn $ "loading: " ++ filename
+        text <- decodeUtf8With lenientDecode <$> readFileBS filename
-    pure result
+        result <- handleLines filename $ lines text
+        putStrLn $ "loading: " ++ filename
+        pure result
 
 parseInclude :: Text -> Result Text
 parseInclude line = maybeToRight (ParseError line) $ T.stripPrefix "@include " line
 
-preprocessLine :: FilePath -> Text -> ResultIO Text
+preprocessLine :: FilePath -> Text -> ResultStateIO Text
 preprocessLine base line
-    | "@include " `T.isPrefixOf` line = liftEither (parseInclude line) >>= preprocess . normalise . (base </>) . toString
+    | "@include " `T.isPrefixOf` line = preprocess $ normalise $ base </> toString (fromRight "" $ parseInclude line)
     | otherwise = pure line
+
+runPreprocessor :: String -> ExceptT PreprocessorError IO Text
+runPreprocessor filename = liftIO (evalStateT (runExceptT (preprocess filename)) S.empty) >>= hoistEither