ghc-mod/core/GhcMod/Monad.hs

149 lines
4.8 KiB
Haskell
Raw Normal View History

2017-03-06 23:19:57 +00:00
-- ghc-mod: Happy Haskell Hacking
2015-03-03 19:28:34 +00:00
-- 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 #-}
module GhcMod.Monad (
runGmOutT
, runGmOutT'
, runGhcModT
2014-07-17 05:30:42 +00:00
, runGhcModT'
, hoistGhcModT
, runGmlT
, runGmlT'
, runGmlTWith
, runGmPkgGhc
, withGhcModEnv
2015-09-14 03:59:01 +00:00
, withGhcModEnv'
, module GhcMod.Monad.Types
2014-07-17 05:30:42 +00:00
) where
import GhcMod.Types
import GhcMod.Monad.Types
import GhcMod.Error
import GhcMod.Logging
import GhcMod.Cradle
import GhcMod.Target
import GhcMod.Output
2014-07-03 05:26:39 +00:00
2014-07-22 17:45:48 +00:00
import Control.Arrow (first)
import Control.Applicative
import Control.Concurrent
import Control.Monad.Reader (runReaderT)
import Control.Monad.State.Strict (runStateT)
import Control.Monad.Trans.Journal (runJournalT)
import Exception
2015-01-16 14:47:56 +00:00
import System.Directory
import System.IO.Unsafe
2015-08-03 01:09:56 +00:00
import Prelude
2015-01-16 14:47:56 +00:00
withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a
withGhcModEnv dir opts f = withGhcModEnv' withCradle dir opts f
2015-09-14 03:59:01 +00:00
where
withCradle dir' =
gbracket
(runJournalT $ do
gmSetLogLevel $ ooptLogLevel $ optOutput opts
findCradle' (optPrograms opts) dir')
(liftIO . cleanupCradle . fst)
cwdLock :: MVar ThreadId
cwdLock = unsafePerformIO $ newEmptyMVar
{-# NOINLINE cwdLock #-}
2015-10-30 18:05:41 +00:00
withGhcModEnv' :: (IOish m, GmOut m) => (FilePath -> ((Cradle, GhcModLog) -> m a) -> m a) -> FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a
2015-09-14 03:59:01 +00:00
withGhcModEnv' withCradle dir opts f =
2015-10-30 18:05:41 +00:00
withCradle dir $ \(crdl,lg) ->
withCradleRootDir crdl $
2015-10-30 18:05:41 +00:00
f (GhcModEnv opts crdl, lg)
where
swapCurrentDirectory ndir = do
odir <- canonicalizePath =<< getCurrentDirectory
setCurrentDirectory ndir
return odir
withCradleRootDir (cradleRootDir -> projdir) a = do
success <- liftIO $ tryPutMVar cwdLock =<< myThreadId
if not success
then error "withGhcModEnv': using ghc-mod from multiple threads is not supported!"
else gbracket setup teardown (const a)
where
setup = liftIO $ swapCurrentDirectory projdir
teardown odir = liftIO $ do
setCurrentDirectory odir
void $ takeMVar cwdLock
runGmOutT :: IOish m => Options -> GmOutT m a -> m a
runGmOutT opts ma = do
gmo@GhcModOut{..} <- GhcModOut (optOutput opts) <$> liftIO newChan
let action = runGmOutT' gmo ma
case ooptLinePrefix $ optOutput opts of
Nothing -> action
Just pfxs ->
gbracket_ (liftIO $ forkIO $ stdoutGateway pfxs gmoChan)
(const $ liftIO $ flushStdoutGateway gmoChan)
action
runGmOutT' :: GhcModOut -> GmOutT m a -> m a
runGmOutT' gmo ma = flip runReaderT gmo $ unGmOutT ma
2014-07-22 17:45:48 +00:00
-- | Run a @GhcModT m@ computation.
runGhcModT :: IOish m
2014-07-22 17:45:48 +00:00
=> Options
-> GhcModT m a
-> m (Either GhcModError a, GhcModLog)
runGhcModT opt action = liftIO (getCurrentDirectory >>= canonicalizePath) >>= \dir' -> do
runGmOutT opt $
2015-10-30 18:05:41 +00:00
withGhcModEnv dir' opt $ \(env,lg) ->
2016-01-09 22:22:27 +00:00
first (fst <$>) <$> runGhcModT' env defaultGhcModState (do
gmSetLogLevel (ooptLogLevel $ optOutput opt)
gmAppendLogQuiet lg
action)
-- | @hoistGhcModT result@. Embed a GhcModT computation's result into a GhcModT
-- computation. Note that if the computation that returned @result@ modified the
-- state part of GhcModT this cannot be restored.
hoistGhcModT :: IOish m
=> (Either GhcModError a, GhcModLog)
-> GhcModT m a
hoistGhcModT (r,l) = do
gmlJournal l >> case r of
Left e -> throwError e
Right a -> return a
-- | Run a computation inside @GhcModT@ providing the RWST environment and
-- initial state. This is a low level function, use it only if you know what to
-- do with 'GhcModEnv' and 'GhcModState'.
--
-- You should probably look at 'runGhcModT' instead.
runGhcModT' :: IOish m
=> GhcModEnv
-> GhcModState
-> GhcModT m a
-> GmOutT m (Either GhcModError (a, GhcModState), GhcModLog)
runGhcModT' r s a = do
flip runReaderT r $ runJournalT $ runErrorT $ runStateT (unGmT a) s
gbracket_ :: ExceptionMonad m => m a -> (a -> m b) -> m c -> m c
gbracket_ ma mb mc = gbracket ma mb (const mc)