Simplify Setup.hs by renaming int. exe into place

Setup.hs

@@ -1,14 +1,19 @@
 #!/usr/bin/env runhaskell
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
 import Distribution.Simple
+import Distribution.Simple.Utils
 import Distribution.Simple.Setup
 import Distribution.Simple.Install
 import Distribution.Simple.Program
 import Distribution.Simple.Register
-import Distribution.Simple.InstallDirs as ID
+import Distribution.Simple.BuildPaths
+import qualified Distribution.Simple.InstallDirs as ID
 import Distribution.Simple.LocalBuildInfo
 import Distribution.PackageDescription
 
+import qualified Data.Map as M
+import Data.Map (Map)
+
 import Control.Arrow
 import Control.Applicative
 import Control.Monad
@@ -19,38 +24,131 @@ import Data.Monoid
 import System.Process
 import System.Exit
 import System.FilePath
-
+import System.Directory (renameFile)
-import SetupCompat
 
 main :: IO ()
 main = defaultMainWithHooks $ simpleUserHooks {
+   instHook = inst,
+   copyHook = copy,
+
    confHook = \(gpd, hbi) cf ->
               xBuildDependsLike <$> (confHook simpleUserHooks) (gpd, hbi) cf
+
+ , buildHook = \pd lbi hooks flags -> (buildHook simpleUserHooks) pd (patchLibexecdir lbi) hooks flags
  , hookedPrograms = [ simpleProgram "shelltest" ]
  }
 
+patchLibexecdir :: LocalBuildInfo -> LocalBuildInfo
+patchLibexecdir lbi = let
+    idirtpl     = installDirTemplates lbi
+    libexecdir' = toPathTemplate $ fromPathTemplate (libexecdir idirtpl) </> "$abi/$pkgid"
+    lbi' = lbi { installDirTemplates = idirtpl { libexecdir = libexecdir' } }
+  in
+    lbi'
+
+
 xBuildDependsLike :: LocalBuildInfo -> LocalBuildInfo
 xBuildDependsLike lbi =
   let
       cc = componentsConfigs lbi
       pd = localPkgDescr lbi
       deps = dependsMap lbi
-  in setComponentsConfigs lbi
+  in lbi {
+          componentsConfigs =
               [ (cn, updateClbi deps comp clbi, cdeps)
               | (cn, clbi, cdeps) <- cc
               , let comp = getComponent pd cn
               ]
-
+         }
  where
    updateClbi deps comp clbi = setUnionDeps (otherDeps deps comp) clbi
 
-   dependsMap ::
+--   dependsMap ::
-    LocalBuildInfo -> [(ComponentName, Deps)]
+--    LocalBuildInfo -> [(ComponentName, ([(UnitId, PackageId)], Map PackageName ModuleRenaming))]
    dependsMap lbi =
-       second getDeps <$> allComponentsInBuildOrder lbi
+       second (componentPackageDeps &&& componentPackageRenaming)
+           <$> allComponentsInBuildOrder lbi
 
-   otherDeps :: [(ComponentName, Deps)] -> Component -> Deps
+--   otherDeps :: [(ComponentName, ([(UnitId, PackageId)], Map PackageName ModuleRenaming))] -> Component -> ([(UnitId, PackageId)], Map PackageName ModuleRenaming)
-   otherDeps deps comp = fromMaybe noDeps $
+   otherDeps deps comp = fromMaybe ([], M.empty) $
        flip lookup deps =<< read <$> lookup "x-build-depends-like" fields
       where
         fields = customFieldsBI (componentBuildInfo comp)
+
+   setComponentPackageRenaming clbi cprn =
+     clbi { componentPackageRenaming =
+                componentPackageRenaming clbi `M.union` cprn }
+
+--   setUnionDeps :: ([(UnitId, PackageId)], Map PackageName ModuleRenaming) -> ComponentLocalBuildInfo -> ComponentLocalBuildInfo
+   setUnionDeps (deps, rns) clbi = let
+      clbi' = setComponentPackageRenaming clbi rns
+      cpdeps = componentPackageDeps clbi
+    in
+      clbi' {
+          componentPackageDeps = cpdeps `union` deps
+      }
+
+
+-- mostly copypasta from 'defaultInstallHook'
+inst ::
+    PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO ()
+inst pd lbi _uf ifl = do
+  let copyFlags = defaultCopyFlags {
+                      copyDistPref   = installDistPref ifl,
+                      copyDest       = toFlag NoCopyDest,
+                      copyVerbosity  = installVerbosity ifl
+                  }
+  xInstallTarget pd lbi copyFlags (\pd' lbi' -> install pd' lbi' copyFlags)
+  let registerFlags = defaultRegisterFlags {
+                          regDistPref  = installDistPref ifl,
+                          regInPlace   = installInPlace ifl,
+                          regPackageDB = installPackageDB ifl,
+                          regVerbosity = installVerbosity ifl
+                      }
+  when (hasLibs pd) $ register pd lbi registerFlags
+
+copy :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO ()
+copy pd lbi _uh cf =
+    xInstallTarget pd lbi cf (\pd' lbi' -> install pd' lbi' cf)
+
+xInstallTarget :: PackageDescription
+               -> LocalBuildInfo
+               -> CopyFlags
+               -> (PackageDescription -> LocalBuildInfo -> IO ())
+               -> IO ()
+xInstallTarget pd lbi cf fn = do
+  let (extended, regular) = partition isInternal (executables pd)
+
+  let pd_regular = pd { executables = regular }
+
+  _ <- flip mapM extended $ \exe -> do
+    let pd_extended = onlyExePackageDesc [exe] pd
+    fn pd_extended lbi
+
+    let lbi' = patchLibexecdir lbi
+        copydest  = fromFlag (copyDest cf)
+        verbosity = fromFlag (copyVerbosity cf)
+        InstallDirs { bindir, libexecdir } = absoluteInstallDirs pd lbi' copydest
+        progprefix = substPathTemplate (packageId pd) lbi (progPrefix lbi)
+        progsuffix = substPathTemplate (packageId pd) lbi (progSuffix lbi)
+        fixedExeBaseName = progprefix ++ exeName exe ++ progsuffix
+
+        fixedExeFileName = bindir </> fixedExeBaseName <.> exeExtension
+        newExeFileName   = libexecdir </> fixedExeBaseName <.> exeExtension
+
+    when (exeName exe == "ghc-mod-real") $ do
+        createDirectoryIfMissingVerbose verbosity True libexecdir
+        renameFile fixedExeFileName newExeFileName
+
+  fn pd_regular lbi
+
+ where
+   isInternal :: Executable -> Bool
+   isInternal exe =
+    fromMaybe False $ (=="True") <$> lookup "x-internal" (customFieldsBI $ buildInfo exe)
+
+onlyExePackageDesc :: [Executable] -> PackageDescription -> PackageDescription
+onlyExePackageDesc exes pd = emptyPackageDescription {
+                     package = package pd
+                   , executables = exes
+                   }

SetupCompat.hs

@@ -1,195 +0,0 @@
-{-# LANGUAGE TemplateHaskell, RecordWildCards, StandaloneDeriving #-}
-module SetupCompat where
-
-import Control.Arrow
-import Control.Monad.Trans.State
-import Data.List
-import Data.Maybe
-import Data.Functor
-import Data.Function
-import Distribution.Simple.LocalBuildInfo
-import Distribution.PackageDescription
-
-import Distribution.Simple
-import Distribution.Simple.Setup
-import Distribution.Simple.Install
-
-import qualified Data.Map as M
-import Data.Map (Map)
-
-
-import NotCPP.Declarations
-import Language.Haskell.TH
-
--- $(ifdefD "componentsConfigs" [d| deriving instance (Ord ComponentName) |] )
-
-$(ifD [d|
-
- showComponentName :: ComponentName -> String
- showComponentName CLibName          = "library"
- showComponentName (CExeName   name) = "executable '" ++ name ++ "'"
- showComponentName (CTestName  name) = "test suite '" ++ name ++ "'"
- showComponentName (CBenchName name) = "benchmark '" ++ name ++ "'"
-
- |])
-
-$(ifelsedefD "componentsConfigs" [d|
-
- setComponentsConfigs
-    :: LocalBuildInfo
-    -> [(ComponentName, ComponentLocalBuildInfo, [ComponentName])]
-    -> LocalBuildInfo
- setComponentsConfigs lbi cs = $(recUpdE' (nE "lbi") (mkName "componentsConfigs") (VarE $ mkName "cs"))
-
- |] [d|
-
- setComponentsConfigs
-    :: LocalBuildInfo
-    -> [(ComponentName, ComponentLocalBuildInfo, a)]
-    -> LocalBuildInfo
- setComponentsConfigs lbi cs = flip execState lbi $ mapM setClbis gcs
-  where
-   gcs = groupBy (sameKind `on` fst3) $ sortBy (compare `on` showComponentName . fst3) cs
-
-   fst3 (x,_,_) = x
-
-   sameKind CLibName CLibName = True
-   sameKind (CExeName _) (CExeName _) = True
-   sameKind (CTestName _) (CTestName _) = True
-   sameKind (CBenchName _) (CBenchName _) = True
-   sameKind _ _ = False
-
-   setClbis [(CLibName, clbi, _)] =
-       get >>= \lbi ->
-           put $ $(recUpdE' (nE "lbi") (mkName "libraryConfig") (AppE (ConE (mkName "Just")) (VarE (mkName "clbi"))))
-
-   setClbis cs@((CExeName _, _, _):_) =
-       let cfg = (\((CExeName n), clbi, _) -> (n, clbi)) <$> cs in
-       get >>= \lbi ->
-           put $ $(recUpdE' (nE "lbi") (mkName "executableConfigs") (VarE $ mkName "cfg"))
-
-   setClbis cs@((CTestName _, _, _):_) =
-       let cfg = (\((CTestName n), clbi, _) -> (n, clbi)) <$> cs in
-       get >>= \lbi ->
-           put $ $(recUpdE' (nE "lbi") (mkName "testSuiteConfigs") (VarE $ mkName "cfg"))
-
-   setClbis cs@((CBenchName _, _, _):_) =
-       let cfg = (\((CBenchName n), clbi, _) -> (n, clbi)) <$> cs in
-       get >>= \lbi ->
-           put $ $(recUpdE' (nE "lbi") (mkName "benchmarkConfigs") (VarE $ mkName "cfg"))
-
- |])
-
-
-$(ifD [d|
-
- componentsConfigs ::
-    LocalBuildInfo -> [(ComponentName, ComponentLocalBuildInfo, [ComponentName])]
- componentsConfigs LocalBuildInfo {..} =
-    (maybe [] (\c -> [(CLibName, c, [])]) $(nE "libraryConfig"))
-    ++ ((\(n, clbi) -> (CExeName n, clbi, [])) <$> $(nE "executableConfigs"))
-    ++ ((\(n, clbi) -> (CTestName n, clbi, [])) <$> $(nE "testSuiteConfigs"))
-    ++ ((\(n, clbi) -> (CBenchName n, clbi, [])) <$> $(nE "benchmarkConfigs"))
-
- getComponent :: PackageDescription -> ComponentName -> Component
- getComponent pkg cname =
-    case lookupComponent pkg cname of
-      Just cpnt -> cpnt
-      Nothing   -> missingComponent
-  where
-    missingComponent =
-      error $ "internal error: the package description contains no "
-           ++ "component corresponding to " ++ show cname
-
- lookupComponent :: PackageDescription -> ComponentName -> Maybe Component
- lookupComponent pkg CLibName =
-    fmap CLib $ library pkg
- lookupComponent pkg (CExeName name) =
-    fmap CExe $ find ((name ==) . exeName) (executables pkg)
- lookupComponent pkg (CTestName name) =
-    fmap CTest $ find ((name ==) . testName) (testSuites pkg)
- lookupComponent pkg (CBenchName name) =
-    fmap CBench $ find ((name ==) . benchmarkName) (benchmarks pkg)
-
--- We're lying here can't be bothered to order these
- allComponentsInBuildOrder :: LocalBuildInfo
-                          -> [(ComponentName, ComponentLocalBuildInfo)]
- allComponentsInBuildOrder lbi =
-      [ (cname, clbi) | (cname, clbi, _) <- componentsConfigs lbi ]
-
- getComponentLocalBuildInfo :: LocalBuildInfo -> ComponentName -> ComponentLocalBuildInfo
- getComponentLocalBuildInfo lbi cname =
-    case [ clbi
-         | (cname', clbi, _) <- componentsConfigs lbi
-         , cname == cname' ] of
-      [clbi] -> clbi
-      _      -> missingComponent
-  where
-    missingComponent =
-      error $ "internal error: there is no configuration data "
-           ++ "for component " ++ show cname
-
- componentBuildInfo :: Component -> BuildInfo
- componentBuildInfo =
-   foldComponent libBuildInfo buildInfo testBuildInfo benchmarkBuildInfo
-
- |])
-
-
-$(ifelsedefD "componentPackageRenaming" [d|
- -- M.Map PackageName
- newtype Deps = Deps  { unDeps :: ([(InstalledPackageId, PackageId)], Map PackageName $(cT "ModuleRenaming")) }
--- $(return $ TySynD $(mkName "Deps") [] [t| |] )
-
- noDeps = Deps ([], M.empty)
-
- getDeps :: ComponentLocalBuildInfo -> Deps
- getDeps = componentPackageDeps &&& $(nE "componentPackageRenaming") >>> Deps
-
- setUnionDeps :: Deps -> ComponentLocalBuildInfo -> ComponentLocalBuildInfo
- setUnionDeps (Deps (deps, rns)) clbi = let
-         clbi' = setComponentPackageRenaming clbi rns
-         cpdeps = componentPackageDeps clbi
-       in
-         clbi' {
-           componentPackageDeps = cpdeps `union` deps
-         }
-
- setComponentPackageRenaming clbi cprn =
-     -- [| clbi { componentPackageRenaming = componentPackageRenaming clbi `M.union` cprn } |]
-     $(recUpdE'
-       (nE "clbi")
-       (mkName "componentPackageRenaming")
-       (InfixE
-        (Just
-         (AppE
-          (VarE
-           (mkName "componentPackageRenaming"))
-          (VarE (mkName "clbi"))
-         ))
-        (VarE (mkName "M.union"))
-        (Just (VarE (mkName "cprn")))
-       )
-      )
-
- |] [d|
-
- newtype Deps = Deps { unDeps :: [(InstalledPackageId, PackageId)] }
-
- noDeps = Deps []
-
- getDeps :: ComponentLocalBuildInfo -> Deps
- getDeps lbi = Deps $ componentPackageDeps lbi
-
- setUnionDeps :: Deps -> ComponentLocalBuildInfo -> ComponentLocalBuildInfo
- setUnionDeps (Deps deps) clbi = let
-         cpdeps = componentPackageDeps clbi
-       in
-         clbi {
-           componentPackageDeps = cpdeps `union` deps
-         }
-
-
--- setComponentPackageRenaming clbi _cprn = clbi
-
- |])

ghc-mod.cabal

@@ -25,13 +25,12 @@ Description:
   For more information, please see its home page.
 
 Category:               GHC, Development
-Cabal-Version:          >= 1.14
+Cabal-Version:          >= 1.24
 Build-Type:             Custom
 Data-Files:             elisp/Makefile
                         elisp/*.el
 Data-Files:             LICENSE COPYING.BSD3 COPYING.AGPL3
 Extra-Source-Files:     ChangeLog
-                        SetupCompat.hs
                         NotCPP/*.hs
                         NotCPP/COPYING
                         core/Language/Haskell/GhcMod/Monad/Compat.hs_h
@@ -96,9 +95,10 @@ Extra-Source-Files:     ChangeLog
 
 Custom-Setup
   Setup-Depends:         base
-                       , Cabal < 1.25
+                       , Cabal >= 1.24 && < 1.25
                        , containers
                        , filepath
+                       , directory
                        , process
                        , template-haskell
                        , transformers