Fix c2hs handling in Cabal

Cabal/Cabal.cabal

@@ -470,6 +470,8 @@ library
     Distribution.Version
     Language.Haskell.Extension
     Distribution.Compat.Binary
+    Distribution.C2Hs
+    Distribution.C2Hs.Lexer
 
   -- Parsec parser-related modules
   build-depends:
@@ -603,6 +605,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,44 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+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/C2Hs/src/Codec/Archive/Types/Foreign.chs

@@ -0,0 +1,119 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric  #-}
+
+module Codec.Archive.Types.Foreign ( -- * Callbacks
+                                     ArchiveReadCallback
+                                   , ArchiveSkipCallback
+                                   , ArchiveSeekCallback
+                                   , ArchiveWriteCallback
+                                   , ArchiveCloseCallbackRaw
+                                   , ArchiveOpenCallbackRaw
+                                   , ArchiveSwitchCallbackRaw
+                                   , ArchivePassphraseCallback
+                                   -- * Abstract types
+                                   , Archive
+                                   , ArchiveEntry
+                                   , Stat
+                                   , LinkResolver
+                                   -- * Enum types
+                                   , ArchiveResult (..)
+                                   -- * Macros
+                                   , Flags (..)
+                                   , ArchiveFilter (..)
+                                   , ArchiveFormat (..)
+                                   , FileType (..)
+                                   , ArchiveCapabilities (..)
+                                   , ReadDiskFlags (..)
+                                   , TimeFlag (..)
+                                   , EntryACL (..)
+                                   -- * libarchive types
+                                   , LaInt64
+                                   , LaSSize
+                                   , Dev
+                                   ) where
+
+import           Control.DeepSeq    (NFData)
+import           Data.Bits          (Bits (..))
+import           Data.Int           (Int64)
+import           Data.Semigroup
+import           Foreign.C.String   (CString)
+import           Foreign.C.Types    (CInt, CSize)
+import           Foreign.Ptr        (Ptr)
+import           GHC.Generics       (Generic)
+import           System.Posix.Types (CMode)
+
+#include <archive.h>
+
+type LaInt64 = {# type la_int64_t #}
+type LaSSize = {# type la_ssize_t #}
+type Dev = {# type dev_t #}
+
+
+{# enum define ArchiveResult { ARCHIVE_OK as ArchiveOk
+                             , ARCHIVE_EOF as ArchiveEOF
+                             , ARCHIVE_RETRY as ArchiveRetry
+                             , ARCHIVE_WARN as ArchiveWarn
+                             , ARCHIVE_FAILED as ArchiveFailed
+                             , ARCHIVE_FATAL as ArchiveFatal
+                             } deriving (Eq, Show, Generic, NFData)
+    #}
+
+-- | Abstract type
+data Archive
+
+-- | Abstract type
+data ArchiveEntry
+
+data Stat
+
+data LinkResolver
+
+type ArchiveReadCallback a b = Ptr Archive -> Ptr a -> Ptr (Ptr b) -> IO LaSSize
+type ArchiveSkipCallback a = Ptr Archive -> Ptr a -> Int64 -> IO LaInt64
+type ArchiveSeekCallback a = Ptr Archive -> Ptr a -> Int64 -> CInt -> IO LaInt64
+type ArchiveWriteCallback a b = Ptr Archive -> Ptr a -> Ptr b -> CSize -> IO LaSSize
+type ArchiveOpenCallbackRaw a = Ptr Archive -> Ptr a -> IO CInt
+type ArchiveCloseCallbackRaw a = Ptr Archive -> Ptr a -> IO CInt
+type ArchiveSwitchCallbackRaw a b = Ptr Archive -> Ptr a -> Ptr b -> IO CInt
+type ArchivePassphraseCallback a = Ptr Archive -> Ptr a -> IO CString
+
+newtype ArchiveFormat = ArchiveFormat CInt
+    deriving (Eq)
+
+newtype FileType = FileType CMode
+    deriving (Eq)
+
+newtype Flags = Flags CInt
+
+newtype ReadDiskFlags = ReadDiskFlags CInt
+
+newtype TimeFlag = TimeFlag CInt
+
+newtype EntryACL = EntryACL CInt
+
+newtype ArchiveFilter = ArchiveFilter CInt
+
+newtype ArchiveCapabilities = ArchiveCapabilities CInt
+    deriving (Eq)
+
+instance Semigroup ArchiveCapabilities where
+    (<>) (ArchiveCapabilities x) (ArchiveCapabilities y) = ArchiveCapabilities (x .|. y)
+
+instance Monoid ArchiveCapabilities where
+    mempty = ArchiveCapabilities 0
+    mappend = (<>)
+
+instance Semigroup ReadDiskFlags where
+    (<>) (ReadDiskFlags x) (ReadDiskFlags y) = ReadDiskFlags (x .|. y)
+
+instance Semigroup Flags where
+    (<>) (Flags x) (Flags y) = Flags (x .|. y)
+
+instance Monoid Flags where
+    mempty = Flags 0
+    mappend = (<>)
+
+instance Semigroup EntryACL where
+    (<>) (EntryACL x) (EntryACL y) = EntryACL (x .|. y)
+
+-- TODO: `has` function for EntryACL

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/C2Hs/src"] ["Codec.Archive.Foreign.Archive", "Codec.Archive.Types.Foreign"] 
+                >>= (@?= ["Codec.Archive.Types.Foreign", "Codec.Archive.Foreign.Archive"])
+        , testCase "libarchive" $
+            reorderC2Hs normal ["tests/C2Hs/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,19 @@
+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"]
+        ]

Makefile

@@ -3,6 +3,7 @@
 .PHONY : cabal-install-dev cabal-install-prod
 
 LEXER_HS:=Cabal/Distribution/Fields/Lexer.hs
+LEXER_CHS:=Cabal/Distribution/C2Hs/Lexer.hs
 SPDX_LICENSE_HS:=Cabal/Distribution/SPDX/LicenseId.hs
 SPDX_EXCEPTION_HS:=Cabal/Distribution/SPDX/LicenseExceptionId.hs
 
@@ -13,21 +14,26 @@ CABALRUN   := cabal new-run --enable-tests
 
 all : exe lib
 
-lib : $(LEXER_HS)
+lib : $(LEXER_HS) $(LEXER_CHS)
 	$(CABALBUILD) Cabal:libs
 
-exe : $(LEXER_HS)
+exe : $(LEXER_HS) $(LEXER_CHS)
 	$(CABALBUILD) cabal-install:exes
 
 # source generation: Lexer
 
-lexer : $(LEXER_HS)
+lexer : $(LEXER_HS) $(LEXER_CHS)
 
 $(LEXER_HS) : boot/Lexer.x
 	alex --latin1 --ghc -o $@ $^
 	cat -s $@ > Lexer.tmp
 	mv Lexer.tmp $@
 
+$(LEXER_CHS) : boot/C2HsLexer.x
+	alex --latin1 --ghc -o $@ $^
+	cat -s $@ > C2HsLexer.tmp
+	mv C2HsLexer.tmp $@
+
 # source generation: SPDX
 
 spdx : $(SPDX_LICENSE_HS) $(SPDX_EXCEPTION_HS)