Factor out cabal-helper into a package

Language/Haskell/GhcMod/CabalHelper.hs

@@ -15,21 +15,18 @@
 -- along with this program.  If not, see <http://www.gnu.org/licenses/>.
 
 module Language.Haskell.GhcMod.CabalHelper (
-    CabalHelper(..)
-  , getComponents
-  , getGhcOptions
+    getComponents
   , getGhcPkgOptions
-  , cabalHelper
   ) where
 
 import Control.Applicative
-import Control.Arrow
 import Control.Monad
 import Data.Monoid
-import Data.List
-import Language.Haskell.GhcMod.Types
+import Distribution.Helper
+import qualified Language.Haskell.GhcMod.Types as T
+import Language.Haskell.GhcMod.Types hiding (ghcProgram, ghcPkgProgram,
+                                             cabalProgram)
 import Language.Haskell.GhcMod.Monad.Types
-import Language.Haskell.GhcMod.Error as E
 import Language.Haskell.GhcMod.Utils
 import Language.Haskell.GhcMod.World
 import Language.Haskell.GhcMod.PathsAndFiles
@@ -37,26 +34,42 @@ import System.FilePath
 
 -- | Only package related GHC options, sufficient for things that don't need to
 -- access home modules
-getGhcPkgOptions :: (MonadIO m, GmEnv m) => m [(GmComponentName, [GHCOption])]
-getGhcPkgOptions = chGhcPkgOptions `liftM` cabalHelper
+getGhcPkgOptions :: (MonadIO m, GmEnv m) => m [(ChComponentName, [GHCOption])]
+getGhcPkgOptions = do
+  Cradle {..} <- cradle
+  let distdir = cradleRootDir </> "dist"
+  runQuery distdir ghcPkgOptions
 
-getGhcOptions :: (MonadIO m, GmEnv m) => m [(GmComponentName, [GHCOption])]
-getGhcOptions = chGhcOptions `liftM` cabalHelper
+helperProgs :: Options -> Programs
+helperProgs opts = Programs {
+                            cabalProgram  = T.cabalProgram opts,
+                            ghcProgram    = T.ghcProgram opts,
+                            ghcPkgProgram = T.ghcPkgProgram opts
+                          }
 
 -- | Primary interface to cabal-helper and intended single entrypoint to
 -- constructing 'GmComponent's
 --
 -- The Component\'s 'gmcHomeModuleGraph' will be empty and has to be resolved by
 -- 'resolveGmComponents'.
-getComponents :: (MonadIO m, GmEnv m)
-    => m [GmComponent (Either FilePath [ModuleName])]
-getComponents = cabalHelper >>= \CabalHelper {..} -> return $ let
-  ([(scn, sep)], eps) = partition ((GmSetupHsName ==) . fst) chEntrypoints
-  sc = GmComponent scn [] [] sep sep ["."] mempty
-  cs = flip map (zip4 eps chGhcOptions chGhcSrcOptions chSourceDirs) $
-      \((cn, ep), (_, opts), (_, srcOpts), (_, srcDirs)) ->
+getComponents :: (MonadIO m, GmEnv m) => m [GmComponent ChEntrypoint]
+getComponents = withCabal $ do
+    Cradle {..} <- cradle
+    let distdir = cradleRootDir </> "dist"
+    opt <- options
+
+    runQuery' (helperProgs opt) distdir $ do
+      q <- liftM4 join4 ghcOptions ghcSrcOptions entrypoints sourceDirs
+      return $ flip map q $ \(cn, (opts, (srcOpts, (ep, srcDirs)))) ->
           GmComponent cn opts srcOpts ep ep srcDirs mempty
-  in sc:cs
+ where
+   join4 a b c = join' a . join' b . join' c
+   join' :: Eq a => [(a,b)] -> [(a,c)] -> [(a,(b,c))]
+   join' lb lc = [ (a, (b, c))
+                | (a, b) <- lb
+                , (a', c) <- lc
+                , a == a'
+                ]
 
 withCabal :: (MonadIO m, GmEnv m) => m a -> m a
 withCabal action = do
@@ -65,58 +78,11 @@ withCabal action = do
     liftIO $ whenM (isSetupConfigOutOfDate <$> getCurrentWorld crdl) $
         withDirectory_ (cradleRootDir crdl) $ do
             let progOpts =
-                    [ "--with-ghc=" ++ ghcProgram opts ]
+                    [ "--with-ghc=" ++ T.ghcProgram opts ]
                     -- Only pass ghc-pkg if it was actually set otherwise we
                     -- might break cabal's guessing logic
-                    ++ if ghcPkgProgram opts /= ghcPkgProgram defaultOptions
-                         then [ "--with-ghc-pkg=" ++ ghcPkgProgram opts ]
+                    ++ if T.ghcPkgProgram opts /= T.ghcPkgProgram defaultOptions
+                         then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram opts ]
                          else []
-            void $ readProcess (cabalProgram opts) ("configure":progOpts) ""
+            void $ readProcess (T.cabalProgram opts) ("configure":progOpts) ""
     action
-
-data CabalHelper = CabalHelper {
-      chEntrypoints   :: [(GmComponentName, Either FilePath [ModuleName])],
-      chSourceDirs    :: [(GmComponentName, [String])],
-      chGhcOptions    :: [(GmComponentName, [String])],
-      chGhcSrcOptions :: [(GmComponentName, [String])],
-      chGhcPkgOptions :: [(GmComponentName, [String])]
-    } deriving (Show)
-
-cabalHelper :: (MonadIO m, GmEnv m) => m CabalHelper
-cabalHelper = withCabal $ do
-  Cradle {..} <- cradle
-  Options {..} <- options
-  let progArgs = [ "--with-ghc="     ++ ghcProgram
-                 , "--with-ghc-pkg=" ++ ghcPkgProgram
-                 , "--with-cabal="   ++ cabalProgram
-                 ]
-
-  let args = [ "entrypoints"
-             , "source-dirs"
-             , "ghc-options"
-             , "ghc-src-options"
-             , "ghc-pkg-options"
-             ] ++ progArgs
-
-      distdir = cradleRootDir </> "dist"
-
-  res <- liftIO $ do
-    exe  <- findLibexecExe "cabal-helper-wrapper"
-    hexe <- readProcess exe ([distdir, "print-exe"] ++ progArgs) ""
-
-    cached cradleRootDir (cabalHelperCache hexe args) $ do
-        out <- readProcess exe (distdir:args) ""
-        evaluate (read out) `E.catch`
-            \(SomeException _) -> error "cabalHelper: read failed"
-
-  let [ Just (GmCabalHelperEntrypoints eps),
-        Just (GmCabalHelperStrings srcDirs),
-        Just (GmCabalHelperStrings ghcOpts),
-        Just (GmCabalHelperStrings ghcSrcOpts),
-        Just (GmCabalHelperStrings ghcPkgOpts) ] = res
-      eps' = map (second $ fmap $ map md) eps
-
-  return $ CabalHelper eps' srcDirs ghcOpts ghcSrcOpts ghcPkgOpts
-
- where
-   md (GmModuleName mn) = mkModuleName mn

Language/Haskell/GhcMod/Monad/Types.hs

@@ -103,6 +103,7 @@ import Data.Map (Map, empty)
 import Data.Maybe
 import Data.Monoid
 import Data.IORef
+import Distribution.Helper
 
 import MonadUtils (MonadIO(..))
 
@@ -128,7 +129,7 @@ data GmGhcSession = GmGhcSession {
 
 data GhcModState = GhcModState {
       gmGhcSession   :: !(Maybe GmGhcSession)
-    , gmComponents   :: !(Map GmComponentName (GmComponent (Set ModulePath)))
+    , gmComponents   :: !(Map ChComponentName (GmComponent (Set ModulePath)))
     , gmCompilerMode :: !CompilerMode
     }
 

Language/Haskell/GhcMod/PathsAndFiles.hs

@@ -23,7 +23,9 @@ import Control.Monad.Trans.Maybe
 import Data.List
 import Data.Char
 import Data.Maybe
+import Data.Version
 import Data.Traversable (traverse)
+import Distribution.Helper
 import System.Directory
 import System.FilePath
 import System.IO.Unsafe
@@ -233,11 +235,11 @@ cabalBuildPlatform = dropWhileEnd isSpace $ unsafePerformIO $
 packageCache :: String
 packageCache = "package.cache"
 
-cabalHelperCache ::
-    FilePath -> [String] -> Cached [String] [Maybe GmCabalHelperResponse]
-cabalHelperCache cabalHelperExe cmds = Cached {
-    inputFiles = [cabalHelperExe, setupConfigPath],
-    inputData  = cmds,
+cabalHelperCache :: Version -> [String]
+                 -> Cached (Version, [String]) [GmComponent ChEntrypoint]
+cabalHelperCache cabalHelperVer cmds = Cached {
+    inputFiles = [setupConfigPath],
+    inputData  = (cabalHelperVer, cmds),
     cacheFile  = setupConfigPath <.> "ghc-mod.cabal-helper"
   }
 

Language/Haskell/GhcMod/Pretty.hs

@@ -19,6 +19,7 @@ module Language.Haskell.GhcMod.Pretty where
 import Control.Arrow hiding ((<+>))
 import Data.Char
 import Data.List
+import Distribution.Helper
 import Text.PrettyPrint
 
 import Language.Haskell.GhcMod.Types
@@ -29,12 +30,12 @@ docStyle = style { ribbonsPerLine = 1.2 }
 gmRenderDoc :: Doc -> String
 gmRenderDoc = renderStyle docStyle
 
-gmComponentNameDoc :: GmComponentName -> Doc
-gmComponentNameDoc GmSetupHsName   = text $ "Setup.hs"
-gmComponentNameDoc GmLibName       = text $ "library"
-gmComponentNameDoc (GmExeName n)   = text $ "exe:" ++ n
-gmComponentNameDoc (GmTestName n)  = text $ "test:" ++ n
-gmComponentNameDoc (GmBenchName n) = text $ "bench:" ++ n
+gmComponentNameDoc :: ChComponentName -> Doc
+gmComponentNameDoc ChSetupHsName   = text $ "Setup.hs"
+gmComponentNameDoc ChLibName       = text $ "library"
+gmComponentNameDoc (ChExeName n)   = text $ "exe:" ++ n
+gmComponentNameDoc (ChTestName n)  = text $ "test:" ++ n
+gmComponentNameDoc (ChBenchName n) = text $ "bench:" ++ n
 
 gmLogLevelDoc :: GmLogLevel -> Doc
 gmLogLevelDoc GmPanic     = text "PANIC"

Language/Haskell/GhcMod/Target.hs

@@ -46,6 +46,7 @@ import Data.Map (Map)
 import qualified Data.Map  as Map
 import Data.Set (Set)
 import qualified Data.Set as Set
+import Distribution.Helper
 
 import System.Directory
 import System.FilePath
@@ -185,9 +186,9 @@ targetGhcOptions crdl sefnmn = do
             let cn = pickComponent candidates
             return $ gmcGhcOpts $ fromJust $ Map.lookup cn mcs
 
-moduleComponents :: Map GmComponentName (GmComponent (Set ModulePath))
+moduleComponents :: Map ChComponentName (GmComponent (Set ModulePath))
                  -> Either FilePath ModuleName
-                 -> Set GmComponentName
+                 -> Set ChComponentName
 moduleComponents m efnmn =
     foldr' Set.empty m $ \c s ->
         let
@@ -203,10 +204,9 @@ moduleComponents m efnmn =
 
    foldr' b as f = Map.foldr f b as
 
-pickComponent :: Set GmComponentName -> GmComponentName
+pickComponent :: Set ChComponentName -> ChComponentName
 pickComponent scn = Set.findMin scn
 
-
 packageGhcOptions :: (MonadIO m, GmEnv m) => m [GHCOption]
 packageGhcOptions = do
     crdl <- cradle
@@ -223,14 +223,16 @@ sandboxOpts crdl = return $ ["-i" ++ d | d <- [wdir,rdir]] ++ pkgOpts
 
 resolveGmComponent :: (IOish m, GmLog m, GmEnv m)
     => Maybe [Either FilePath ModuleName] -- ^ Updated modules
-    -> GmComponent (Either FilePath [ModuleName])
+    -> GmComponent ChEntrypoint
     -> m (GmComponent (Set ModulePath))
 resolveGmComponent mums c@GmComponent {..} =
   withLightHscEnv gmcGhcSrcOpts $ \env -> do
     let srcDirs = gmcSourceDirs
         mg = gmcHomeModuleGraph
 
-    let eps = either (return . Left) (map Right) gmcEntrypoints
+    Cradle { cradleRootDir } <- cradle
+
+    eps <- liftIO $ resolveChEntrypoints cradleRootDir gmcEntrypoints
     simp <- liftIO $ resolveEntrypoints env srcDirs eps
     sump <- liftIO $ case mums of
         Nothing -> return simp
@@ -263,11 +265,30 @@ resolveEntrypoints env srcDirs ms =
    findFile' dirs file =
        mconcat <$> mapM (mightExist . (</>file)) dirs
 
+resolveChEntrypoints ::
+  FilePath -> ChEntrypoint -> IO [Either FilePath ModuleName]
+resolveChEntrypoints _ (ChLibEntrypoint em om) =
+    return $ map (Right . chModToMod) (em ++ om)
+
+resolveChEntrypoints _ (ChExeEntrypoint main om) =
+    return $ [Left main] ++ map (Right . chModToMod) om
+
+resolveChEntrypoints srcDir ChSetupEntrypoint = do
+  shs <- doesFileExist (srcDir </> "Setup.hs")
+  slhs <- doesFileExist (srcDir </> "Setup.lhs")
+  return $ case (shs, slhs) of
+    (True, _) -> [Left "Setup.hs"]
+    (_, True) -> [Left "Setup.lhs"]
+    (False, False) -> []
+
+chModToMod :: ChModuleName -> ModuleName
+chModToMod (ChModuleName mn) = mkModuleName mn
+
 resolveGmComponents :: (IOish m, GmState m, GmLog m, GmEnv m)
                     => Maybe [Either FilePath ModuleName]
                         -- ^ Updated modules
-                    -> [GmComponent (Either FilePath [ModuleName])]
-                    -> m (Map GmComponentName (GmComponent (Set ModulePath)))
+                    -> [GmComponent ChEntrypoint]
+                    -> m (Map ChComponentName (GmComponent (Set ModulePath)))
 resolveGmComponents mumns cs = do
     s <- gmsGet
     m' <- foldrM' (gmComponents s) cs $ \c m -> do

Language/Haskell/GhcMod/Types.hs

@@ -2,7 +2,6 @@
 {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-}
 module Language.Haskell.GhcMod.Types (
     module Language.Haskell.GhcMod.Types
-  , module CabalHelper.Types
   , ModuleName
   , mkModuleName
   , moduleNameString
@@ -18,13 +17,12 @@ import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.Monoid
 import Data.Typeable (Typeable)
+import Distribution.Helper
 import Exception (ExceptionMonad)
 import MonadUtils (MonadIO)
 import GHC (ModuleName, moduleNameString, mkModuleName)
 import PackageConfig (PackageConfig)
 
-import CabalHelper.Types
-
 -- | A constraint alias (-XConstraintKinds) to make functions dealing with
 -- 'GhcModT' somewhat cleaner.
 --
@@ -168,10 +166,10 @@ instance Monoid GmModuleGraph where
         GmModuleGraph (a <> a') (b <> b') (Map.unionWith Set.union c c')
 
 data GmComponent eps = GmComponent {
-      gmcName            :: GmComponentName,
+      gmcName            :: ChComponentName,
       gmcGhcOpts         :: [GHCOption],
       gmcGhcSrcOpts      :: [GHCOption],
-      gmcRawEntrypoints  :: Either FilePath [ModuleName],
+      gmcRawEntrypoints  :: ChEntrypoint,
       gmcEntrypoints     :: eps,
       gmcSourceDirs      :: [FilePath],
       gmcHomeModuleGraph :: GmModuleGraph
@@ -204,10 +202,10 @@ data GhcModError
     | GMECabalFlags GhcModError
     -- ^ Retrieval of the cabal configuration flags failed.
 
-    | GMECabalComponent GmComponentName
+    | GMECabalComponent ChComponentName
     -- ^ Cabal component could not be found
 
-    | GMECabalCompAssignment [(Either FilePath ModuleName, Set GmComponentName)]
+    | GMECabalCompAssignment [(Either FilePath ModuleName, Set ChComponentName)]
     -- ^ Could not find a consistent component assignment for modules
 
     | GMEProcess String [String] (Either (String, String, Int) GhcModError)