Fix CPP pragma parsing

CHANGELOG.md

@@ -14,4 +14,7 @@ Changelog](https://keepachangelog.com/en/1.0.0/), and this project adheres to
 - The `snack run` function to accept arguments that will be passed to the built
   executable.
 
+### Fixed
+- The module import parsing when the CPP extension is enabled.
+
 [Unreleased]: https://github.com/nmattia/snack/compare/51987daf76cffc31289e6913174dfb46b93df36b...HEAD

snack-lib/Imports.hs

@@ -1,13 +1,18 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MagicHash #-}
 
+module Main (main) where
+
 import Control.Monad.IO.Class
 import Data.Semigroup
 import System.Environment
+import Control.Exception
 import qualified DriverPipeline
 import qualified DynFlags
 import qualified FastString
 import qualified GHC
+import qualified ErrUtils
+import qualified Bag
 import qualified GHC.IO.Handle.Text as Handle
 import qualified HsImpExp
 import qualified HsSyn
@@ -19,6 +24,7 @@ import qualified Parser
 import qualified SrcLoc
 import qualified StringBuffer
 import qualified System.Process as Process
+import System.IO (stderr)
 
 main :: IO ()
 main = do
@@ -33,26 +39,39 @@ main = do
     libdir <- filter (/= '\n') <$> Handle.hGetContents ho1
     _ <- Process.waitForProcess hdl
 
-    -- Read the file that we want to parse
-    str <- readFile fp
-
     -- Some gymnastics to make the parser happy
     res <- GHC.runGhc (Just libdir)
       $ do
 
+        -- Without this line GHC parsing fails with the following error
+        -- message:
+        --    <command line>: unknown package: rts
+        _ <- GHC.setSessionDynFlags =<< GHC.getSessionDynFlags
+
         hsc_env <- GHC.getSession
+
         -- XXX: We need to preprocess the file so that all extensions are
         -- loaded
-        (dflags, _) <- liftIO $ DriverPipeline.preprocess hsc_env (fp, Nothing)
-        hsc_env <- GHC.setSession hsc_env { HscTypes.hsc_dflags = dflags }
+        (dflags, fp2) <- liftIO $
+          DriverPipeline.preprocess hsc_env (fp, Nothing)
+        _ <- GHC.setSessionDynFlags dflags
+
+        -- Read the file that we want to parse
+        str <- liftIO $ readFile fp2
 
-        runParser fp str (Parser.parseModule) >>= \case
+        runParser fp2 str Parser.parseModule >>= \case
           Lexer.POk _ (SrcLoc.L _ res) -> pure res
-          Lexer.PFailed _ e -> fail $ unlines
-            [ "Could not parse module: "
-            , fp
-            , " because " <> Outputable.showSDocUnsafe e
-            ]
+          Lexer.PFailed spn e -> liftIO $ do
+            Handle.hPutStrLn stderr $ unlines
+              [ "Could not parse module: "
+              , fp2
+              , " (originally " <> fp <> ")"
+              , " because " <> Outputable.showSDocUnsafe e
+              , " src span "
+              , show spn
+              ]
+            throwIO $ HscTypes.mkSrcErr $
+              Bag.unitBag $ ErrUtils.mkPlainErrMsg dflags spn e
 
     -- Extract the imports from the parsed module
     let imports' =

snack-lib/modules.nix

@@ -56,7 +56,7 @@ rec {
       ghc = haskellPackages.ghcWithPackages (ps: [ ps.ghc ]);
       importParser = runCommand "import-parser"
         { buildInputs = [ ghc ];
-        } "ghc -package ghc ${./Imports.hs} -o $out" ;
+        } "ghc -Wall -Werror -package ghc ${./Imports.hs} -o $out" ;
     # XXX: this command needs ghc in the environment so that it can call "ghc
     # --print-libdir"...
     in runCommand "dependencies-json"

tests/cpp/Main.hs

@@ -0,0 +1,6 @@
+{-# LANGUAGE CPP #-}
+
+module Main where
+
+main :: IO ()
+main = putStrLn "hello"

tests/cpp/golden

@@ -0,0 +1 @@
+hello

tests/cpp/snack.nix

@@ -0,0 +1,3 @@
+{ main = "Main";
+  src = ./.;
+}

tests/cpp/test

@@ -0,0 +1,18 @@
+#!/usr/bin/env bash
+# vim: ft=sh sw=2 et
+
+set -euo pipefail
+
+test() {
+  $SNACK build
+  $SNACK run | diff golden -
+
+  TMP_FILE=$(mktemp)
+
+  capture_io "$TMP_FILE" main | $SNACK ghci
+
+  diff golden $TMP_FILE
+  rm $TMP_FILE
+}
+
+SNACK="snack -j4" test