From 8156b93666d574f9e3012d29bb1e3f2dd28f7102 Mon Sep 17 00:00:00 2001
From: Alan Zimmerman <alan.zimm@gmail.com>
Date: Wed, 29 Nov 2017 17:47:38 +0200
Subject: Bring in hs-source-dirs for sub-dependencies

Instead of the sub-dependency.

Must still bring in the deps of the sub-dependency.
---
 src/CabalHelper/Runtime/Main.hs | 67 +++++++++++++++++++++++++++++------------
 1 file changed, 48 insertions(+), 19 deletions(-)

(limited to 'src/CabalHelper/Runtime/Main.hs')

diff --git a/src/CabalHelper/Runtime/Main.hs b/src/CabalHelper/Runtime/Main.hs
index ac357e2..2f0075b 100644
--- a/src/CabalHelper/Runtime/Main.hs
+++ b/src/CabalHelper/Runtime/Main.hs
@@ -112,6 +112,9 @@ import Distribution.Types.ModuleRenaming
 import Distribution.Types.UnitId
   ( DefUnitId
   )
+import Distribution.Utils.NubList
+    ( toNubListR
+    )
 import Distribution.Verbosity
   ( Verbosity
   , silent
@@ -455,19 +458,24 @@ componentsMap lbi _v _distdir f = do
 --                   -> IO [(ChComponentName, a)]
 componentOptions' (lbi, v, distdir) inplaceFlag flags rf f = do
   let pd = localPkgDescr lbi
-  componentsMap lbi v distdir $ \c clbi bi -> let
+  includeDirs <- componentsMap lbi v distdir $ \_c clbi bi -> do
+    return (componentUnitId clbi, (componentInternalDeps clbi, hsSourceDirs bi))
+  let includeDirMap = Map.fromList $ map snd includeDirs
+
+  -- putStrLn $ "componentGhcOptions':includeDirMap=" ++ show includeDirMap
+  componentsMap lbi v distdir $ \c clbi bi -> do
+         let
            outdir = componentOutDir lbi c
            (clbi', adopts) = case flags of
                                _ | not inplaceFlag -> (clbi, mempty)
                                ["--with-inplace"] -> (clbi, mempty)
-                               [] -> removeInplaceDeps v lbi pd clbi
+                               [] -> removeInplaceDeps v lbi pd clbi includeDirMap
            opts = componentGhcOptions normal lbi bi clbi' outdir
            opts' = f opts
 
-         in rf lbi v $ nubPackageFlags $ opts' `mappend` adopts
-         -- in rf lbi v $ nubPackageFlags $ adopts
-         -- in rf lbi v $ nubPackageFlags $ opts'
-         -- in rf lbi v $ nubPackageFlags $ mempty
+         -- putStrLn $ "componentGhcOptions':opts'=" ++ show opts'
+         -- putStrLn $ "************************componentGhcOptions':adopts=" ++ show (ghcOptSourcePath adopts)
+         rf lbi v $ nubPackageFlags $ opts' `mappend` adopts
 
 componentOptions :: (LocalBuildInfo, Verbosity, FilePath)
                  -> Bool
@@ -492,35 +500,56 @@ removeInplaceDeps :: Verbosity
                   -> LocalBuildInfo
                   -> PackageDescription
                   -> ComponentLocalBuildInfo
+                  -> Map.Map UnitId ([UnitId],[FilePath])
                   -> (ComponentLocalBuildInfo, GhcOptions)
-removeInplaceDeps _v lbi pd clbi = let
-    (ideps, deps) = partition (isInplaceDep lbi clbi) (componentPackageDeps clbi)
-    (_,     incs) = partition (isInplaceCompInc clbi) (componentIncludes clbi)
-    hasIdeps = not $ null ideps
+removeInplaceDeps _v lbi pd clbi includeDirs = let
+    removeInplace c =
+      let
+        (ideps, deps) = partition (isInplaceDep lbi c) (componentPackageDeps c)
+        (_,     incs) = partition (isInplaceCompInc c) (componentIncludes c)
+        hasIdeps = not $ null ideps
+        c' = c { componentPackageDeps  = deps
+               , componentInternalDeps = []
+               , componentIncludes     = incs }
+      in (hasIdeps,c')
+    (hasIdeps,clbi') = removeInplace clbi
     libopts =
       case (getLibraryClbi pd lbi,getExeClbi pd lbi) of
         (Just (lib, libclbi),_) | hasIdeps ->
           let
             libbi = libBuildInfo lib
             liboutdir = componentOutDir lbi (CLib lib)
+            (_,libclbi') = removeInplace libclbi
+            extraIncludes = recursiveIncludeDirs includeDirs (componentUnitId libclbi)
+            opts = (componentGhcOptions normal lbi libbi libclbi' liboutdir) {
+                      ghcOptPackageDBs = []
+                   }
           in
-            (componentGhcOptions normal lbi libbi libclbi liboutdir) {
-                ghcOptPackageDBs = []
-            }
+            opts { ghcOptSourcePath = ghcOptSourcePath opts <> toNubListR extraIncludes }
         (_,Just (exe,execlbi)) | hasIdeps ->
           let
             exebi = buildInfo exe
             exeoutdir = componentOutDir lbi (CExe exe)
+            (_,execlbi') = removeInplace execlbi
+            extraIncludes = recursiveIncludeDirs includeDirs (componentUnitId execlbi)
+            opts = (componentGhcOptions normal lbi exebi execlbi' exeoutdir) {
+                     ghcOptPackageDBs = []
+                   }
           in
-            (componentGhcOptions normal lbi exebi execlbi exeoutdir) {
-                ghcOptPackageDBs = []
-            }
+            opts { ghcOptSourcePath = ghcOptSourcePath opts <> toNubListR extraIncludes }
         _ -> mempty
-    clbi' = clbi { componentPackageDeps = deps
-                 , componentIncludes = incs }
   in (clbi', libopts)
   -- in error $ "removeInplaceDeps:(clbi')=" ++ show (clbi' )
- 
+
+-- TODO: Is this valid? It assumes a tree, will never return for a graph
+recursiveIncludeDirs :: Map.Map UnitId ([UnitId],[FilePath]) -> UnitId -> [FilePath]
+recursiveIncludeDirs includeDirs unit = go [] [unit]
+  where
+    go acc [] = acc
+    go acc (u:us) = case Map.lookup u includeDirs of
+      Nothing -> go acc us
+      Just (us',fps) -> go (acc++fps) (us++us')
+
 initialBuildStepsForAllComponents distdir pd lbi v =
   initialBuildSteps distdir pd lbi v
 
-- 
cgit v1.2.3