Initial commit

1 files changed, 278 insertions, 0 deletions

diff --git a/Distribution/Helper.hs b/Distribution/Helper.hs
new file mode 100644
index 0000000..84a23aa
--- /dev/null
+++ b/Distribution/Helper.hs
@@ -0,0 +1,278 @@
+-- ghc-mod: Making Haskell development *more* fun
+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>
+--
+-- This program is free software: you can redistribute it and/or modify
+-- it under the terms of the GNU Affero General Public License as published by
+-- the Free Software Foundation, either version 3 of the License, or
+-- (at your option) any later version.
+--
+-- This program is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+-- GNU Affero General Public License for more details.
+--
+-- 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 #-}
+module Distribution.Helper (
+    Programs(..)
+
+  -- * Running Queries
+  , Query
+  , runQuery
+  , runKQuery
+  , runKQuery_
+
+  -- * Queries against Cabal\'s on disk state
+
+  , entrypoints
+  , sourceDirs
+  , ghcOptions
+  , ghcSrcOptions
+  , ghcPkgOptions
+
+  -- * Managing @dist/@
+  , reconfigure
+  , writeAutogenFiles
+
+  -- * $libexec related error handling
+  , LibexecNotFoundError(..)
+  , libexecNotFoundError
+  ) where
+
+import Control.Applicative
+import Control.Arrow
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.State.Strict
+import Control.Monad.Reader
+import Control.Exception
+import Data.Monoid
+import Data.List
+import Data.Default
+import Data.Typeable
+import System.Environment
+import System.FilePath
+import System.Directory
+import System.Process
+import Text.Printf
+
+import Paths_cabal_helper (getLibexecDir)
+import CabalHelper.Types
+
+-- | Paths or names of various programs we need.
+data Programs = Programs {
+      cabalProgram  :: FilePath,
+      ghcProgram    :: FilePath,
+      ghcPkgProgram :: FilePath
+    }
+
+instance Default Programs where
+    def = Programs "cabal" "ghc" "ghc-pkg"
+
+data SomeLocalBuildInfo = SomeLocalBuildInfo {
+      slbiEntrypoints   :: [(ChComponentName, ChEntrypoint)],
+      slbiSourceDirs    :: [(ChComponentName, [String])],
+      slbiGhcOptions    :: [(ChComponentName, [String])],
+      slbiGhcSrcOptions :: [(ChComponentName, [String])],
+      slbiGhcPkgOptions :: [(ChComponentName, [String])]
+    } deriving (Eq, Ord, Read, Show)
+
+-- | Caches helper executable result so it doesn't have to be run more than once
+-- as reading in Cabal's @LocalBuildInfo@ datatype from disk is very slow but
+-- running all possible queries against it at once is cheap.
+newtype Query m a = Query { unQuery :: StateT (Maybe SomeLocalBuildInfo)
+                                         (ReaderT (Programs, FilePath) m) a }
+
+type MonadQuery m = ( MonadIO m
+                    , MonadState (Maybe SomeLocalBuildInfo) m
+                    , MonadReader (Programs, FilePath) m)
+
+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/@
+         -> 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 ())
+
+getSlbi :: MonadQuery m => m SomeLocalBuildInfo
+getSlbi = do
+  s <- get
+  case s of
+    Nothing -> do
+            slbi <- getSomeConfigState
+            put (Just slbi)
+            return slbi
+    Just slbi -> return slbi
+
+-- | Modules or files Cabal would have the compiler build directly. Can be used
+-- to compute the home module closure for a component.
+entrypoints   :: MonadIO m => Query m [(ChComponentName, ChEntrypoint)]
+
+-- | A component's @source-dirs@ field, beware as if this is empty implicit
+-- behaviour in GHC kicks in.
+sourceDirs    :: MonadIO m => Query m [(ChComponentName, [FilePath])]
+
+-- | All options cabal would pass to GHC.
+ghcOptions    :: MonadIO m => Query m [(ChComponentName, [String])]
+
+-- | Only search path related GHC options.
+ghcSrcOptions :: MonadIO m => Query m [(ChComponentName, [String])]
+
+-- | Only package related GHC options, sufficient for things don't need to
+-- access any home modules.
+ghcPkgOptions :: MonadIO m => Query m [(ChComponentName, [String])]
+
+entrypoints   = Query $ slbiEntrypoints   `liftM` getSlbi
+sourceDirs    = Query $ slbiSourceDirs    `liftM` getSlbi
+ghcOptions    = Query $ slbiGhcOptions    `liftM` getSlbi
+ghcSrcOptions = Query $ slbiGhcSrcOptions `liftM` getSlbi
+ghcPkgOptions = Query $ slbiGhcPkgOptions `liftM` getSlbi
+
+-- | Run @cabal configure@
+reconfigure :: MonadIO m
+            => Programs -- ^ Program paths
+            -> [String] -- ^ Command line arguments to be passed to @cabal@
+            -> m ()
+reconfigure progs cabalOpts = do
+    let progOpts =
+            [ "--with-ghc=" ++ ghcProgram progs ]
+            -- Only pass ghc-pkg if it was actually set otherwise we
+            -- might break cabal's guessing logic
+            ++ if ghcPkgProgram progs /= ghcPkgProgram def
+                 then [ "--with-ghc-pkg=" ++ ghcPkgProgram progs ]
+                 else []
+            ++ cabalOpts
+    _ <- liftIO $ readProcess (cabalProgram progs) ("configure":progOpts) ""
+    return ()
+
+getSomeConfigState :: MonadQuery m => m SomeLocalBuildInfo
+getSomeConfigState = ask >>= \(progs, distdir) -> do
+  let progArgs = [ "--with-ghc="     ++ ghcProgram progs
+                 , "--with-ghc-pkg=" ++ ghcPkgProgram progs
+                 , "--with-cabal="   ++ cabalProgram progs
+                 ]
+
+  let args = [ "entrypoints"
+             , "source-dirs"
+             , "ghc-options"
+             , "ghc-src-options"
+             , "ghc-pkg-options"
+             ] ++ progArgs
+
+  res <- liftIO $ do
+    exe  <- findLibexecExe "cabal-helper-wrapper"
+    out <- readProcess exe (distdir:args) ""
+    evaluate (read out) `catch` \(SomeException _) ->
+      error $ concat ["getSomeConfigState", ": ", exe, " "
+                     , intercalate " " (map show $ distdir:args)
+                     , " (read failed)"]
+
+  let [ Just (ResponseEntrypoints eps),
+        Just (ResponseStrings srcDirs),
+        Just (ResponseStrings ghcOpts),
+        Just (ResponseStrings ghcSrcOpts),
+        Just (ResponseStrings ghcPkgOpts) ] = res
+
+  return $ SomeLocalBuildInfo eps srcDirs ghcOpts ghcSrcOpts ghcPkgOpts
+
+-- | Create @cabal_macros.h@ and @Paths_\<pkg\>@ possibly other generated files
+-- in the usual place.
+writeAutogenFiles :: MonadIO m
+                  => FilePath -- ^ Path to the @dist/@ directory
+                  -> m ()
+writeAutogenFiles distdir = liftIO $ do
+  exe  <- findLibexecExe "cabal-helper-wrapper"
+  callProcess exe [distdir, "write-autogen-files"]
+
+-- | This exception is thrown by all 'runQuery' functions if the internal
+-- wrapper executable cannot be found. You may catch this and present the user
+-- an appropriate error message however the default is to print
+-- 'libexecNotFoundError'.
+data LibexecNotFoundError = LibexecNotFoundError String FilePath
+                          deriving (Typeable)
+instance Exception LibexecNotFoundError
+instance Show LibexecNotFoundError where
+  show (LibexecNotFoundError exe dir) =
+    libexecNotFoundError exe dir "https://github.com/DanielG/cabal-helper/issues"
+
+findLibexecExe :: String -> IO FilePath
+findLibexecExe "cabal-helper-wrapper" = do
+    libexecdir <- getLibexecDir
+    let exeName = "cabal-helper-wrapper"
+        exe = libexecdir </> exeName
+
+    exists <- doesFileExist exe
+
+    if exists
+       then return exe
+       else do
+         mdir <- tryFindCabalHelperTreeLibexecDir
+         case mdir of
+           Nothing ->
+               error $ throw $ LibexecNotFoundError exeName libexecdir
+           Just dir ->
+               return $ dir </> "dist" </> "build" </> exeName </> exeName
+findLibexecExe exe = error $ "findLibexecExe: Unknown executable: " ++ exe
+
+tryFindCabalHelperTreeLibexecDir :: IO (Maybe FilePath)
+tryFindCabalHelperTreeLibexecDir = do
+  exe <- getExecutablePath'
+  dir <- case takeFileName exe of
+    "ghc" -> do -- we're probably in ghci; try CWD
+        getCurrentDirectory
+    _ ->
+        return $ (!!4) $ iterate takeDirectory exe
+  exists <- doesFileExist $ dir </> "cabal-helper.cabal"
+  return $ if exists
+             then Just dir
+             else Nothing
+
+libexecNotFoundError :: String   -- ^ Name of the executable we were trying to
+                                 -- find
+                     -> FilePath -- ^ Path to @$libexecdir@
+                     -> String   -- ^ URL the user will be directed towards to
+                                 -- report a bug.
+                     -> String
+libexecNotFoundError exe dir reportBug = printf
+ ( "Could not find $libexecdir/%s\n"
+ ++"\n"
+ ++"If you are a developer set the environment variable\n"
+ ++"`cabal_helper_libexecdir' to override $libexecdir[1]. The following will\n"
+ ++"work in the cabal-helper source tree:\n"
+ ++"\n"
+ ++"    $ export cabal_helper_libexecdir=$PWD/dist/build/%s\n"
+ ++"\n"
+ ++"[1]: %s\n"
+ ++"\n"
+ ++"If you don't know what I'm talking about something went wrong with your\n"
+ ++"installation. Please report this problem here:\n"
+ ++"\n"
+ ++"    %s") exe exe dir reportBug
+
+getExecutablePath' :: IO FilePath
+getExecutablePath' =
+#if MIN_VERSION_base(4,6,0)
+    getExecutablePath
+#else
+    getProgName
+#endif