ghc-mod/core/Language/Haskell/GhcMod/Monad.hs

-- 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 #-}
module Language.Haskell.GhcMod.Monad (
    runGmOutT
  , runGmOutT'
  , runGhcModT
  , runGhcModT'
  , hoistGhcModT
  , runGmlT
  , runGmlT'
  , runGmlTWith
  , runGmPkgGhc
  , withGhcModEnv
  , withGhcModEnv'
  , module Language.Haskell.GhcMod.Monad.Types
  ) where

import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Error
import Language.Haskell.GhcMod.Logging
import Language.Haskell.GhcMod.Cradle
import Language.Haskell.GhcMod.Target
import Language.Haskell.GhcMod.Output

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

import System.Directory
import System.IO.Unsafe
import Prelude

withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a
withGhcModEnv dir opts f = withGhcModEnv' withCradle dir opts f
 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 #-}

withGhcModEnv' :: (IOish m, GmOut m) => (FilePath -> ((Cradle, GhcModLog) -> m a) -> m a) -> FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a
withGhcModEnv' withCradle dir opts f =
    withCradle dir $ \(crdl,lg) ->
      withCradleRootDir crdl $
        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

-- | Run a @GhcModT m@ computation.
runGhcModT :: IOish m
           => Options
           -> GhcModT m a
           -> m (Either GhcModError a, GhcModLog)
runGhcModT opt action = liftIO (getCurrentDirectory >>= canonicalizePath) >>= \dir' -> do
    runGmOutT opt $
      withGhcModEnv dir' opt $ \(env,lg) ->
        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)