Handle inplace library deps and do a rename pass

3 files changed, 90 insertions, 74 deletions

diff --git a/CabalHelper/Main.hs b/CabalHelper/Main.hs
index 777ac7a..ef3447b 100644
--- a/CabalHelper/Main.hs
+++ b/CabalHelper/Main.hs
@@ -43,6 +43,7 @@ import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..),
                                            componentBuildInfo,
                                            externalPackageDeps,
                                            withComponentsLBI,
+                                           withLibLBI,
                                            inplacePackageId)
 
 import Distribution.Simple.GHC (componentGhcOptions)
@@ -88,7 +89,7 @@ usage = do
      ++"DIST_DIR ( version\n"
      ++"         | print-lbi\n"
      ++"         | write-autogen-files\n"
-     ++"         | ghc-options [--with-inplace]\n"
+     ++"         | ghc-options     [--with-inplace]\n"
      ++"         | ghc-src-options [--with-inplace]\n"
      ++"         | ghc-pkg-options [--with-inplace]\n"
      ++"         | entrypoints\n"
@@ -124,11 +125,8 @@ main = do
 
   let
       -- a =<< b $$ c   ==  (a =<< b) $$ c
-      -- a <$$> b $$ c  ==  a <$$> (b $$ c)
       infixr 2 $$
       ($$) = ($)
-      infixr 1 <$$>
-      (<$$>) = (<$>)
 
       collectCmdOptions :: [String] -> [[String]]
       collectCmdOptions =
@@ -157,30 +155,31 @@ main = do
       initialBuildSteps distdir pd lbi v
       return Nothing
 
-    "ghc-options":flags ->
-      Just . GmCabalHelperStrings <$$> componentsMap lbi v distdir $$
-      \c clbi bi -> let
+    "ghc-options":flags -> do
+      res <- componentsMap lbi v distdir $ \c clbi bi -> let
            outdir = componentOutDir lbi c
            (clbi', adopts) = case flags of
                                ["--with-inplace"] -> (clbi, mempty)
-                               [] -> removeInplaceDeps pd clbi
+                               [] -> removeInplaceDeps v lbi pd clbi
+
+
            opts = componentGhcOptions v lbi bi clbi' outdir
-           in
-              renderGhcOptions' lbi v $ opts `mappend` adopts
+         in renderGhcOptions' lbi v (opts `mappend` adopts)
+      return $ Just $ ChResponseStrings (res ++ [(ChSetupHsName, [])])
 
-    "ghc-src-options":flags ->
-      Just . GmCabalHelperStrings <$$> componentsMap lbi v distdir $$
-      \c clbi bi -> let
+    "ghc-src-options":flags -> do
+      res <- componentsMap lbi v distdir $ \c clbi bi -> let
            outdir = componentOutDir lbi c
            (clbi', adopts) = case flags of
                                ["--with-inplace"] -> (clbi, mempty)
-                               [] -> removeInplaceDeps pd clbi
+                               [] -> removeInplaceDeps v lbi pd clbi
            opts = componentGhcOptions v lbi bi clbi' outdir
            comp = compiler lbi
 
            opts' = mempty {
                -- Not really needed but "unexpected package db stack: []"
                ghcOptPackageDBs      = [GlobalPackageDB],
+
                ghcOptCppOptions      = ghcOptCppOptions opts,
                ghcOptCppIncludePath  = ghcOptCppIncludePath opts,
                ghcOptCppIncludes     = ghcOptCppIncludes opts,
@@ -188,17 +187,16 @@ main = do
                ghcOptSourcePathClear = ghcOptSourcePathClear opts,
                ghcOptSourcePath      = ghcOptSourcePath opts
               }
-            in
-              renderGhcOptions' lbi v $ opts `mappend` adopts
+         in renderGhcOptions' lbi v $ opts `mappend` adopts
+      return $ Just $ ChResponseStrings (res ++ [(ChSetupHsName, [])])
 
-    "ghc-pkg-options":flags ->
-      Just . GmCabalHelperStrings <$$> componentsMap lbi v distdir $$
-      \c clbi bi -> let
+    "ghc-pkg-options":flags -> do
+      res <- componentsMap lbi v distdir $ \c clbi bi -> let
            comp = compiler lbi
            outdir = componentOutDir lbi c
            (clbi', adopts) = case flags of
                                ["--with-inplace"] -> (clbi, mempty)
-                               [] -> removeInplaceDeps pd clbi
+                               [] -> removeInplaceDeps v lbi pd clbi
            opts = componentGhcOptions v lbi bi clbi' outdir
 
            opts' = mempty {
@@ -206,23 +204,23 @@ main = do
                        ghcOptPackages   = ghcOptPackages opts,
                        ghcOptHideAllPackages = ghcOptHideAllPackages opts
                    }
-           in
-             renderGhcOptions' lbi v $ opts' `mappend` adopts
+         in renderGhcOptions' lbi v $ opts' `mappend` adopts
+      return $ Just $ ChResponseStrings (res ++ [(ChSetupHsName, [])])
 
     "entrypoints":[] -> do
       eps <- componentsMap lbi v distdir $ \c clbi bi ->
                return $ componentEntrypoints c
       -- MUST append Setup component at the end otherwise CabalHelper gets
       -- confused
-      let eps' = eps ++ [(GmSetupHsName, Right [GmModuleName "Setup"])]
-      return $ Just $ GmCabalHelperEntrypoints eps'
+      let eps' = eps ++ [(ChSetupHsName, ChSetupEntrypoint)]
+      return $ Just $ ChResponseEntrypoints eps'
 
-    "source-dirs":[] ->
-      Just . GmCabalHelperStrings <$$> componentsMap lbi v distdir $$
-      \c clbi bi -> return $ hsSourceDirs bi
+    "source-dirs":[] -> do
+      res <- componentsMap lbi v distdir $$ \_ _ bi -> return $ hsSourceDirs bi
+      return $ Just $ ChResponseStrings (res ++ [(ChSetupHsName, [])])
 
     "print-lbi":[] ->
-      return $ Just $ GmCabalHelperLbi $ show lbi
+      return $ Just $ ChResponseLbi $ show lbi
 
     cmd:_ | not (cmd `elem` commands) ->
             errMsg ("Unknown command: " ++ cmd) >> usage >> exitFailure
@@ -236,6 +234,15 @@ getLibrary pd = unsafePerformIO $ do
   withLib pd (writeIORef lr)
   readIORef lr
 
+getLibraryClbi pd lbi = unsafePerformIO $ do
+  lr <- newIORef (error "getLibraryClbi: empty IORef")
+
+  withLibLBI pd lbi $ \ lib clbi ->
+      writeIORef lr (lib,clbi)
+
+  readIORef lr
+
+
 componentsMap :: LocalBuildInfo
               -> Verbosity
               -> FilePath
@@ -243,7 +250,7 @@ componentsMap :: LocalBuildInfo
                   -> ComponentLocalBuildInfo
                   -> BuildInfo
                   -> IO a)
-              -> IO [(GmComponentName, a)]
+              -> IO [(ChComponentName, a)]
 componentsMap lbi v distdir f = do
     let pd = localPkgDescr lbi
 
@@ -255,13 +262,14 @@ componentsMap lbi v distdir f = do
 
         l' <- readIORef lr
         r <- f c clbi bi
-        writeIORef lr $ (componentNameToGm name, r):l'
+        writeIORef lr $ (componentNameToCh name, r):l'
+
     reverse <$> readIORef lr
 
-componentNameToGm CLibName = GmLibName
-componentNameToGm (CExeName n) = GmExeName n
-componentNameToGm (CTestName n) = GmTestName n
-componentNameToGm (CBenchName n) = GmBenchName n
+componentNameToCh CLibName = ChLibName
+componentNameToCh (CExeName n) = ChExeName n
+componentNameToCh (CTestName n) = ChTestName n
+componentNameToCh (CBenchName n) = ChBenchName n
 
 componentNameFromComponent (CLib Library {}) = CLibName
 componentNameFromComponent (CExe Executable {..}) = CExeName exeName
@@ -277,24 +285,26 @@ componentOutDir lbi (CTest TestSuite { testInterface = TestSuiteLibV09 _ _, ..})
 componentOutDir lbi (CBench Benchmark { benchmarkInterface = BenchmarkExeV10 _ _, ..})=
     exeOutDir lbi benchmarkName
 
-gmModuleName :: C.ModuleName -> GmModuleName
-gmModuleName = GmModuleName . intercalate "." . components
+gmModuleName :: C.ModuleName -> ChModuleName
+gmModuleName = ChModuleName . intercalate "." . components
 
-componentEntrypoints :: Component -> Either FilePath [GmModuleName]
+componentEntrypoints :: Component -> ChEntrypoint
 componentEntrypoints (CLib Library {..})
-    = Right $ map gmModuleName $ exposedModules ++ (otherModules libBuildInfo)
+    = ChLibEntrypoint
+        (map gmModuleName exposedModules)
+        (map gmModuleName $ otherModules libBuildInfo)
 componentEntrypoints (CExe Executable {..})
-    = Left modulePath
-componentEntrypoints (CTest TestSuite { testInterface = TestSuiteExeV10 _ fp })
-    = Left fp
-componentEntrypoints (CTest TestSuite { testInterface = TestSuiteLibV09 _ mn })
-    = Right [gmModuleName mn]
+    = ChExeEntrypoint modulePath (map gmModuleName $ otherModules buildInfo)
+componentEntrypoints (CTest TestSuite { testInterface = TestSuiteExeV10 _ fp, ..})
+    = ChExeEntrypoint fp (map gmModuleName $ otherModules testBuildInfo)
+componentEntrypoints (CTest TestSuite { testInterface = TestSuiteLibV09 _ mn, ..})
+    = ChLibEntrypoint [gmModuleName mn] (map gmModuleName $ otherModules testBuildInfo)
 componentEntrypoints (CTest TestSuite {})
-    = Right []
-componentEntrypoints (CBench Benchmark { benchmarkInterface = BenchmarkExeV10 _  fp})
-    = Left fp
+    = ChLibEntrypoint [] []
+componentEntrypoints (CBench Benchmark { benchmarkInterface = BenchmarkExeV10 _  fp, ..})
+    = ChExeEntrypoint fp (map gmModuleName $ otherModules benchmarkBuildInfo)
 componentEntrypoints (CBench Benchmark {})
-    = Left []
+    = ChLibEntrypoint [] []
 
 exeOutDir :: LocalBuildInfo -> String -> FilePath
 exeOutDir lbi exeName =
@@ -309,26 +319,24 @@ exeOutDir lbi exeName =
   in targetDir
 
 
-removeInplaceDeps :: PackageDescription
+removeInplaceDeps :: Verbosity
+                  -> LocalBuildInfo
+                  -> PackageDescription
                   -> ComponentLocalBuildInfo
                   -> (ComponentLocalBuildInfo, GhcOptions)
-removeInplaceDeps pd clbi = let
+removeInplaceDeps v lbi pd clbi = let
+    (lib, libclbi) = getLibraryClbi pd lbi
+    libbi = libBuildInfo lib
+    liboutdir = componentOutDir lbi (CLib lib)
+    libopts = (componentGhcOptions v lbi libbi libclbi liboutdir) {
+                                    ghcOptPackageDBs = []
+                                  }
+
     (ideps, deps) = partition isInplaceDep (componentPackageDeps clbi)
     hasIdeps = not $ null ideps
     clbi' = clbi { componentPackageDeps = deps }
-    lib = getLibrary pd
-    src_dirs = hsSourceDirs (libBuildInfo lib)
-    adopts = mempty {
-               ghcOptSourcePath      =
-#if CABAL_MAJOR == 1 && CABAL_MINOR >= 22
-                   toNubListR src_dirs
-#else
-                   src_dirs
-#endif
-
-             }
 
-  in (clbi', if hasIdeps then adopts else mempty)
+  in (clbi', if hasIdeps then libopts else mempty)
 
  where
    isInplaceDep :: (InstalledPackageId, PackageId) -> Bool
diff --git a/CabalHelper/Types.hs b/CabalHelper/Types.hs
index 85cf2d2..add6dc1 100644
--- a/CabalHelper/Types.hs
+++ b/CabalHelper/Types.hs
@@ -14,27 +14,35 @@
 -- You should have received a copy of the GNU Affero General Public License
 -- along with this program.  If not, see <http://www.gnu.org/licenses/>.
 
+{-# LANGUAGE DeriveGeneric, DefaultSignatures #-}
 module CabalHelper.Types where
 
+import GHC.Generics
+
 newtype ChModuleName = ChModuleName String
-    deriving (Eq, Ord, Read, Show)
+    deriving (Eq, Ord, Read, Show, Generic)
 
 data ChComponentName = ChSetupHsName
                      | ChLibName
                      | ChExeName String
                      | ChTestName String
                      | ChBenchName String
-  deriving (Eq, Ord, Read, Show)
+  deriving (Eq, Ord, Read, Show, Generic)
 
-data Response
-    = ResponseStrings    [(ChComponentName, [String])]
-    | ResponseEntrypoints [(ChComponentName, ChEntrypoint)]
-    | ResponseLbi String
-  deriving (Eq, Ord, Read, Show)
+data ChResponse
+    = ChResponseStrings    [(ChComponentName, [String])]
+    | ChResponseEntrypoints [(ChComponentName, ChEntrypoint)]
+    | ChResponseLbi String
+  deriving (Eq, Ord, Read, Show, Generic)
 
-data ChEntrypoint = ChExeEntrypoint { chMainIs         :: FilePath
+data ChEntrypoint = ChSetupEntrypoint -- ^ Almost like 'ChExeEntrypoint' but
+                                      -- @main-is@ could either be @"Setup.hs"@
+                                      -- or @"Setup.lhs"@. Since we don't know
+                                      -- where the source directory is you have
+                                      -- to find these files.
+                  | ChLibEntrypoint { chExposedModules :: [ChModuleName]
                                     , chOtherModules   :: [ChModuleName]
                                     }
-                  | ChLibentrypoint { chExposedModules :: [ChModuleName]
+                  | ChExeEntrypoint { chMainIs         :: FilePath
                                     , chOtherModules   :: [ChModuleName]
-                                    } deriving (Eq, Ord, Read, Show)
+                                    } deriving (Eq, Ord, Read, Show, Generic)
diff --git a/CabalHelper/Wrapper.hs b/CabalHelper/Wrapper.hs
index 933cb2f..1334a9d 100644
--- a/CabalHelper/Wrapper.hs
+++ b/CabalHelper/Wrapper.hs
@@ -237,14 +237,14 @@ compile Options {..} Compile {..} = do
           , "-optP-DCABAL_MINOR=" ++ show mi
           ],
           maybeToList $ ("-package-conf="++) <$> packageDb,
-          map ("-i"++) $ cabalHelperSourceDir:maybeToList cabalSourceDir,
+          map ("-i"++) $ ".":maybeToList cabalSourceDir,
           concatMap (\p -> ["-package", p]) packageDeps,
-          [ "--make",  cabalHelperSourceDir </> "CabalHelper/Main.hs" ]
+          [ "--make",  "CabalHelper/Main.hs" ]
          ]
 
     -- TODO: touch exe after, ghc doesn't do that if the input files didn't
     -- actually change
-    rv <- callProcessStderr' Nothing ghcProgram ghc_opts
+    rv <- callProcessStderr' (Just cabalHelperSourceDir) ghcProgram ghc_opts
     return $ case rv of
                ExitSuccess -> Right exe
                e@(ExitFailure _) -> Left e