Fix c2hs handling in Cabal

Cabal/Cabal.cabal

@@ -473,6 +473,8 @@ library
     Distribution.Version
     Language.Haskell.Extension
     Distribution.Compat.Binary
+    Distribution.C2Hs
+    Distribution.C2Hs.Lexer
 
   -- Parsec parser-related modules
   build-depends:
@@ -606,6 +608,8 @@ test-suite unit-tests
     UnitTests.Distribution.Utils.ShortText
     UnitTests.Distribution.Version
     UnitTests.Distribution.PkgconfigVersion
+    UnitTests.Distribution.C2Hs.Lexer
+    UnitTests.Distribution.C2Hs
   main-is: UnitTests.hs
   build-depends:
     array,

Cabal/ChangeLog.md

@@ -2,6 +2,7 @@
   * `cabal check` verifies `cpp-options` more pedantically, allowing only
     options starting with `-D` and `-U`.
   * TODO
+  * Fix dependency resolution for preprocessing `chs` files.
 
  ----
 

Cabal/Distribution/C2Hs.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+-- | This module contains a function to order @.chs@ files based on their
+-- dependencies on one another thusly: it lexes the @.chs@ source files
+-- looking for @{\# import \#}@ declarations and then topologically sorts
+-- the modules. This ensures that a module's dependencies are preprocessed
+-- first.
+module Distribution.C2Hs ( reorderC2Hs ) where
+
+import Prelude()
+import Distribution.Compat.Graph
+import Distribution.Compat.Prelude
+import Distribution.C2Hs.Lexer
+import Distribution.ModuleName (ModuleName, toFilePath)
+import Distribution.Parsec (simpleParsec)
+import Distribution.Simple.Utils (warn, findFileWithExtension)
+import Distribution.Verbosity (Verbosity)
+
+-- | Given a list of 'ModuleName's, sort it according to @c2hs@ @{\#import\#}@
+-- declarations.
+reorderC2Hs :: Verbosity
+            -> [FilePath] -- ^ Source directories
+            -> [ModuleName] -- ^ Module names
+            -> IO [ModuleName] -- ^ Sorted modules
+reorderC2Hs v dirs preMods = do
+
+    chsFiles <- traverse findCHS preMods
+
+    modDeps <- traverse (extractDeps v) (zip preMods chsFiles)
+
+    pure $ fmap (\(N m _ _) -> m) (revTopSort $ fromDistinctList modDeps)
+
+        where findCHS = findFileWithExtension [".chs"] dirs . toFilePath
+
+
+-- | Given a 'ModuleName' and its corresponding filepath, return a 'Node'
+-- with its associated @c2hs@ dependencies
+extractDeps :: Verbosity -> (ModuleName, Maybe FilePath) -> IO (Node ModuleName ModuleName)
+-- If the 'FilePath' is 'Nothing', it's not a @.chs@ file
+extractDeps _ (m, Nothing) = pure (N m m [])
+extractDeps v (m, Just f) = do
+    con <- readFile f
+    mods <- case getImports con of
+        Right ms -> case traverse simpleParsec ms of
+            Just ms' -> pure ms'
+            Nothing -> do { warn v ("Cannot parse module name in c2hs file " ++ f) ; pure [] }
+        Left err -> do { warn v ("Cannot parse c2hs import in " ++ f ++ ": " ++ err) ; pure [] }
+    pure (N m m mods)

Cabal/Distribution/Simple/PreProcess.hs

@@ -33,6 +33,7 @@ import Prelude ()
 import Distribution.Compat.Prelude
 import Distribution.Compat.Stack
 
+import Distribution.C2Hs
 import Distribution.Simple.PreProcess.Unlit
 import Distribution.Backpack.DescribeUnitId
 import Distribution.Package
@@ -168,21 +169,24 @@ preprocessComponent pd comp lbi clbi isSrcDist verbosity handlers = do
   (CLib lib@Library{ libBuildInfo = bi }) -> do
     let dirs = hsSourceDirs bi ++ [autogenComponentModulesDir lbi clbi
                                   ,autogenPackageModulesDir lbi]
-    for_ (map ModuleName.toFilePath $ allLibModules lib clbi) $
+    mods <- reorderC2Hs verbosity dirs (allLibModules lib clbi)
+    for_ (map ModuleName.toFilePath mods) $
       pre dirs (componentBuildDir lbi clbi) (localHandlers bi)
   (CFLib flib@ForeignLib { foreignLibBuildInfo = bi, foreignLibName = nm }) -> do
     let nm' = unUnqualComponentName nm
     let flibDir = buildDir lbi </> nm' </> nm' ++ "-tmp"
         dirs    = hsSourceDirs bi ++ [autogenComponentModulesDir lbi clbi
                                      ,autogenPackageModulesDir lbi]
-    for_ (map ModuleName.toFilePath $ foreignLibModules flib) $
+    mods <- reorderC2Hs verbosity dirs (foreignLibModules flib)
+    for_ (map ModuleName.toFilePath mods) $
       pre dirs flibDir (localHandlers bi)
   (CExe exe@Executable { buildInfo = bi, exeName = nm }) -> do
     let nm' = unUnqualComponentName nm
     let exeDir = buildDir lbi </> nm' </> nm' ++ "-tmp"
         dirs   = hsSourceDirs bi ++ [autogenComponentModulesDir lbi clbi
                                     ,autogenPackageModulesDir lbi]
-    for_ (map ModuleName.toFilePath $ otherModules bi) $
+    mods <- reorderC2Hs verbosity dirs (otherModules bi)
+    for_ (map ModuleName.toFilePath mods) $
       pre dirs exeDir (localHandlers bi)
     pre (hsSourceDirs bi) exeDir (localHandlers bi) $
       dropExtensions (modulePath exe)

Cabal/tests/UnitTests.hs

@@ -13,6 +13,8 @@ import Distribution.Simple.Utils
 import Distribution.Verbosity
 import Distribution.Compat.Time
 
+import qualified UnitTests.Distribution.C2Hs
+import qualified UnitTests.Distribution.C2Hs.Lexer
 import qualified UnitTests.Distribution.Compat.CreatePipe
 import qualified UnitTests.Distribution.Compat.Time
 import qualified UnitTests.Distribution.Compat.Graph
@@ -37,7 +39,11 @@ tests mtimeChangeCalibrated =
                     else mtimeChangeCalibrated
   in
   testGroup "Unit Tests"
-    [ testGroup "Distribution.Compat.CreatePipe"
+    [ testGroup "Distribution.C2Hs"
+        UnitTests.Distribution.C2Hs.tests
+    , testGroup "Distribution.C2Hs.Lexer"
+        UnitTests.Distribution.C2Hs.Lexer.tests
+    , testGroup "Distribution.Compat.CreatePipe"
         UnitTests.Distribution.Compat.CreatePipe.tests
     , testGroup "Distribution.Compat.Time"
         (UnitTests.Distribution.Compat.Time.tests mtimeChange)

Cabal/tests/UnitTests/Distribution/C2Hs.hs

@@ -0,0 +1,18 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module UnitTests.Distribution.C2Hs ( tests ) where
+
+import Distribution.C2Hs
+import Distribution.Verbosity (normal)
+
+import Test.Tasty
+import Test.Tasty.HUnit
+
+tests :: [TestTree]
+tests = [ testCase "libarchive" $
+            reorderC2Hs normal ["tests/c2hsTestModules/src"] ["Codec.Archive.Foreign.Archive", "Codec.Archive.Types.Foreign"] 
+                >>= (@?= ["Codec.Archive.Types.Foreign", "Codec.Archive.Foreign.Archive"])
+        , testCase "libarchive" $
+            reorderC2Hs normal ["tests/c2hsTestModules/src"] ["Codec.Archive.Types.Foreign", "Codec.Archive.Foreign.Archive"] 
+                >>= (@?= ["Codec.Archive.Types.Foreign", "Codec.Archive.Foreign.Archive"])
+        ]

Cabal/tests/UnitTests/Distribution/C2Hs/Lexer.hs

@@ -0,0 +1,21 @@
+module UnitTests.Distribution.C2Hs.Lexer ( tests ) where
+
+import Distribution.C2Hs.Lexer
+
+import Test.Tasty
+import Test.Tasty.HUnit
+
+tests :: [TestTree]
+tests = [ testCase "simple import" $
+            getImports "{# import Data.Char #}" @?= Right ["Data.Char"]
+        , testCase "line comment" $
+            getImports "-- {# import Data.Char #}" @?= Right []
+        , testCase "nested block comment" $
+            getImports "{- nested {- comment -} -} {# import Data.Char #}" @?= Right ["Data.Char"]
+        , testCase "Not find spurious imports" $
+            getImports "import Data.Word\n{# import Data.Char #}" @?= Right ["Data.Char"]
+        , testCase "Work with qualified imports + spaces" $
+            getImports "{# import qualified   Data.Char #}" @?= Right ["Data.Char"]
+        , testCase "Error on bad block comments" $
+            getImports "{- {- block comment -} {# import Data.Char #}" @?= Left "Error in nested comment at line 1, column 46"
+        ]