Handle inplace library deps and do a rename pass

6 files changed, 122 insertions, 110 deletions

diff --git a/.travis.yml b/.travis.yml
index 63fa1e6..35d74d1 100644
--- a/.travis.yml
+++ b/.travis.yml
@@ -22,4 +22,5 @@ script:
   - if [ -n "$(ghc --version | awk '{ print $8 }' | sed -n '/^7.8/p')" ]; then export WERROR="--ghc-option=-Werror"; fi
   - cabal configure --enable-tests $WERROR
   - cabal build
+  - ./dist/build/cabal-helper-wrapper/cabal-helper-wrapper dist
 #  - cabal test
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
diff --git a/Distribution/Helper.hs b/Distribution/Helper.hs
index e97d656..cd1d30e 100644
--- a/Distribution/Helper.hs
+++ b/Distribution/Helper.hs
@@ -14,15 +14,16 @@
 -- 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 CPP, FlexibleContexts, ConstraintKinds, DeriveDataTypeable #-}
+{-# LANGUAGE CPP, FlexibleContexts, ConstraintKinds #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, DeriveGeneric #-}
+
 module Distribution.Helper (
     Programs(..)
 
   -- * Running Queries
   , Query
   , runQuery
-  , runKQuery
-  , runKQuery_
+  , runQuery'
 
   -- * Queries against Cabal\'s on disk state
 
@@ -62,6 +63,7 @@ import System.FilePath
 import System.Directory
 import System.Process
 import Text.Printf
+import GHC.Generics
 
 import Paths_cabal_helper (getLibexecDir)
 import CabalHelper.Types
@@ -71,7 +73,7 @@ data Programs = Programs {
       cabalProgram  :: FilePath,
       ghcProgram    :: FilePath,
       ghcPkgProgram :: FilePath
-    }
+    } deriving (Eq, Ord, Show, Read, Generic, Typeable)
 
 instance Default Programs where
     def = Programs "cabal" "ghc" "ghc-pkg"
@@ -89,6 +91,7 @@ data SomeLocalBuildInfo = SomeLocalBuildInfo {
 -- running all possible queries against it at once is cheap.
 newtype Query m a = Query { unQuery :: StateT (Maybe SomeLocalBuildInfo)
                                          (ReaderT (Programs, FilePath) m) a }
+    deriving (Functor, Applicative, Monad)
 
 type MonadQuery m = ( MonadIO m
                     , MonadState (Maybe SomeLocalBuildInfo) m
@@ -99,25 +102,17 @@ run r s action = flip runReaderT r (flip evalStateT s (unQuery action))
 -- | @runQuery query distdir@. Run a 'Query'. @distdir@ is where Cabal's
 -- @setup-config@ file is located.
 runQuery :: Monad m
-         => Query m a
+         => FilePath -- ^ Path to @dist/@
+         -> Query m a
+         -> m a
+runQuery fp action = run (def, fp) Nothing action
+
+runQuery' :: Monad m
+         => Programs
          -> FilePath -- ^ Path to @dist/@
+         -> Query m a
          -> m a
-runQuery action fp = run (def, fp) Nothing action
-
--- | Run a 'Query' as an Arrow by wrapping it in a 'Kleisli' constructor.
-runKQuery :: Monad m
-          => Kleisli (Query m) a b
-          -> FilePath -- ^ Path to @dist/@
-          -> a
-          -> m b
-runKQuery (Kleisli action) fp a = run (def, fp) Nothing (action a)
-
--- | Same as 'runKQuery' but pass unit as input to the arrow.
-runKQuery_ :: Monad m
-           => Kleisli (Query m) () b
-           -> FilePath -- ^ Path to @dist/@
-           -> m b
-runKQuery_ (Kleisli action) fp = run (def, fp) Nothing (action ())
+runQuery' progs fp action = run (progs, fp) Nothing action
 
 getSlbi :: MonadQuery m => m SomeLocalBuildInfo
 getSlbi = do
@@ -192,11 +187,11 @@ getSomeConfigState = ask >>= \(progs, distdir) -> do
                      , intercalate " " (map show $ distdir:args)
                      , " (read failed)"]
 
-  let [ Just (ResponseEntrypoints eps),
-        Just (ResponseStrings srcDirs),
-        Just (ResponseStrings ghcOpts),
-        Just (ResponseStrings ghcSrcOpts),
-        Just (ResponseStrings ghcPkgOpts) ] = res
+  let [ Just (ChResponseEntrypoints eps),
+        Just (ChResponseStrings srcDirs),
+        Just (ChResponseStrings ghcOpts),
+        Just (ChResponseStrings ghcSrcOpts),
+        Just (ChResponseStrings ghcPkgOpts) ] = res
 
   return $ SomeLocalBuildInfo eps srcDirs ghcOpts ghcSrcOpts ghcPkgOpts
 
diff --git a/cabal-helper.cabal b/cabal-helper.cabal
index fdb985e..15e79b8 100644
--- a/cabal-helper.cabal
+++ b/cabal-helper.cabal
@@ -1,35 +1,33 @@
 name:                cabal-helper
-version:             0.2.0.0
+version:             0.3.0.0
 synopsis:            Simple interface to Cabal's configuration state used by ghc-mod
 description:
     @cabal-helper@ provides a library which wraps the internal use of executables
     to lift the restrictions imposed by linking against versions of GHC before
     @7.10@.
-
+    .
     @cabal-helper@ uses a wrapper executable to compile the actual cabal-helper
     executable at runtime while linking against an arbitrary version of
     Cabal. This runtime-compiled helper executable is then used to extract
     various bits and peices from Cabal\'s on disk state (dist/setup-config)
     written by it's configure command.
-
+    .
     In addition to this the wrapper executable also supports installing any
     version of Cabal from hackage in case it cannot be found in any available
     package database. The wrapper installs these instances of the Cabal library
     into a private package database so as to not interfere with the user's
     packages.
-
+    .
     Furthermore the wrapper supports one special case namely reading a state
     file for Cabal itself. This is needed as Cabal compiles it's Setup.hs using
     itself and not using any version of Cabal installed in any package database.
 
-    Currently @cabal-helper@ supports @Cabal >= 1.16@.
-
 license:             AGPL-3
 license-file:        LICENSE
 author:              Daniel Gröber <dxld@darkboxed.org>
 maintainer:          dxld@darkboxed.org
 category:            Distribution
-build-type:          Simple
+build-type:          Custom
 cabal-version:       >=1.10
 extra-source-files:  CabalHelper/Main.hs
 
@@ -39,15 +37,17 @@ source-repository head
 
 library
   exposed-modules:     Distribution.Helper
-  build-depends:       base >= 4.5 && < 5
+  Other-Modules:       Paths_cabal_helper
+                     , CabalHelper.Types
   default-language:    Haskell2010
-  Build-Depends:       base
+  Build-Depends:       base >= 4.5 && < 5
                      , data-default
                      , directory
                      , filepath
                      , transformers
                      , mtl
                      , process
+                     , ghc-prim
 
 Executable cabal-helper-wrapper
   Default-Language:    Haskell2010
@@ -62,7 +62,7 @@ Executable cabal-helper-wrapper
   X-Install-Target:    $libexecdir
   Build-Depends:       base >= 4.5 && < 5
                      , bytestring
-                     , Cabal
+                     , Cabal >= 1.16 && <= 1.22
                      , directory
                      , filepath
                      , process