Fix c2hs handling in Cabal

Cabal/Cabal.cabal

@@ -468,6 +468,9 @@ library
     Distribution.Version
     Language.Haskell.Extension
     Distribution.Compat.Binary
+  other-modules:
+    Distribution.C2Hs
+    Distribution.C2Hs.Lexer
 
   -- Parsec parser-related modules
   build-depends:

Cabal/ChangeLog.md

@@ -1,5 +1,6 @@
 # 3.1.0.0 (current development version)
   * TODO
+  * Fix dependency resolution for preprocessing `chs` files.
 
  ----
 

Cabal/Distribution/C2Hs.hs

@@ -0,0 +1,56 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+-- Based on https://github.com/gtk2hs/gtk2hs/blob/master/tools/src/Gtk2HsSetup.hs#L414
+module Distribution.C2Hs ( reorderC2Hs ) where
+
+import Prelude()
+import Distribution.Compat.Prelude
+import qualified Data.Map as M
+import qualified Data.Set as S
+import Distribution.C2Hs.Lexer
+import Distribution.ModuleName (ModuleName, components)
+import Distribution.Parsec (simpleParsec)
+import Distribution.Simple.Utils (dieNoVerbosity, findFileWithExtension, withUTF8FileContents)
+import System.FilePath (joinPath)
+
+reorderC2Hs :: [FilePath] -> [ModuleName] -> IO [ModuleName]
+reorderC2Hs dirs preMods = do
+
+  let findModule = findFileWithExtension [".chs"] dirs . joinPath . components
+
+  mFiles <- traverse findModule preMods
+
+  let preDeps = zip (fmap (ModDep []) preMods) mFiles
+
+  modDeps <- traverse extractDeps preDeps
+
+  let mods = reverse (sortTopological modDeps)
+
+  pure (moduleOriginal <$> mods)
+
+data ModDep = ModDep { moduleRequires :: [ModuleName]
+                     , moduleOriginal :: ModuleName
+                     }
+
+extractDeps :: (ModDep, Maybe FilePath) -> IO ModDep
+extractDeps (md, Nothing) = pure md
+extractDeps (md, (Just f)) = withUTF8FileContents f $ \con -> do
+  mods <- case getImports con of
+        Right ms -> case traverse simpleParsec ms of
+            Just ms' -> pure ms'
+            Nothing -> dieNoVerbosity ("Cannot parse module name in c2hs file " ++ f)
+        Left err -> dieNoVerbosity ("Cannot parse c2hs import in " ++ f ++ ": " ++ err)
+  pure (md { moduleRequires = mods })
+
+sortTopological :: [ModDep] -> [ModDep]
+sortTopological ms = fst $ foldl' visit (([]), S.empty) (moduleOriginal <$> ms)
+  where
+    set = M.fromList (fmap (\m -> (moduleOriginal m, m)) ms)
+    visit (out, visited) m
+      | m `S.member` visited = (out,visited)
+      | otherwise = case m `M.lookup` set of
+          Nothing -> (out, m `S.insert` visited)
+          Just md -> (md:out', visited')
+            where
+              (out',visited') = foldl' visit (out, m `S.insert` visited) (moduleRequires md)

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,7 +169,8 @@ 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 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

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_C2HS)
 	$(CABALBUILD) Cabal:libs
 
-exe : $(LEXER_HS)
+exe : $(LEXER_HS) $(LEXER_C2HS)
 	$(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)

boot/C2HsLexer.x

@@ -0,0 +1,90 @@
+{
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
+module Distribution.C2Hs.Lexer ( getImports ) where
+
+import Control.Applicative ((<$>))
+}
+
+%wrapper "monad"
+
+$module = [A-Za-z\.]
+
+tokens :-
+
+    $white+                      ;
+    <0> "--".*                   ;
+
+    <0> "{-"                     { \_ _ -> nested_comment }
+
+    <chs> "import"               { \_ _ -> alex Import }
+    <chs> "qualified"            ;
+    <chs> "#}"                   { begin 0 }
+    <0> "{#"                     { begin chs }
+    <chs> $module+               { tok (\_ s -> alex (Module s)) }
+
+    <0> [^\{]+                   ;
+    <0> $printable               ;
+    <chs> [^\#$module]+          ;
+
+{
+
+data Token = Import
+           | Module String
+           | End
+
+tok f (p,_,_,s) len = f p (take len s)
+
+alex :: a -> Alex a
+alex = pure
+
+alexEOF :: Alex Token
+alexEOF = pure End
+
+-- | Given a 'String' containing C2Hs, return a list of modules it @{#import#}@s.
+getImports :: String -> Either String [FilePath]
+getImports = fmap extractDeps . lexC
+
+-- from: https://github.com/simonmar/alex/blob/master/examples/haskell.x#L128
+nested_comment :: Alex Token
+nested_comment = go 1 =<< alexGetInput
+
+    where go :: Int -> AlexInput -> Alex Token
+          go 0 input = alexSetInput input *> alexMonadScan
+          go n input =
+            case alexGetByte input of
+                Nothing -> err input
+                Just (c, input') ->
+                    case c of
+                        45 ->
+                            case alexGetByte input' of
+                                Nothing -> err input'
+                                Just (125,input_) -> go (n-1) input_
+                                Just (_,input_) -> go n input_
+                        125 ->
+                            case alexGetByte input' of
+                                Nothing -> err input'
+                                Just (c',input_) -> go (addLevel c' $ n) input_
+                        _ -> go n input'
+
+          addLevel c' = if c' == 45 then (+1) else id
+
+          err (pos,_,_,_) =
+            let (AlexPn _ line col) = pos in
+                alexError ("Error in nested comment at line " ++ show line ++ ", column " ++ show col)
+
+extractDeps :: [Token] -> [FilePath]
+extractDeps []                   = []
+extractDeps (Import:Module s:xs) = s : extractDeps xs
+extractDeps (_:xs)               = extractDeps xs
+
+lexC :: String -> Either String [Token]
+lexC = flip runAlex loop
+
+loop :: Alex [Token]
+loop = do
+    tok' <- alexMonadScan
+    case tok' of
+        End -> pure []
+        _ -> (tok' :) <$> loop
+
+}