From fff9087ff75a7abe1fd33280f449fe4d9f154b33 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Sun, 27 Dec 2015 02:42:45 +0300 Subject: [PATCH 01/15] [Shell-Parse] Use \STX and \ETX for quoting Also drops escaping --- src/GHCMod/Options/ShellParse.hs | 34 +++++++++----------------------- test/ShellParseSpec.hs | 24 +++------------------- 2 files changed, 12 insertions(+), 46 deletions(-) diff --git a/src/GHCMod/Options/ShellParse.hs b/src/GHCMod/Options/ShellParse.hs index 5799906..4ad4efe 100644 --- a/src/GHCMod/Options/ShellParse.hs +++ b/src/GHCMod/Options/ShellParse.hs @@ -16,35 +16,19 @@ module GHCMod.Options.ShellParse (parseCmdLine) where import Data.Char -import Data.Maybe -isQuote :: Char -> Bool -isQuote = (==) '"' - -isEscapeChar :: Char -> Bool -isEscapeChar = (==) '\\' - -isEscapable :: Char -> Bool -isEscapable c = any ($ c) [isSpace, isQuote, isEscapeChar] - -go :: String -> String -> [String] -> Maybe Char -> [String] +go :: String -> String -> [String] -> Bool -> [String] -- result go [] curarg accargs _ = reverse $ reverse curarg : accargs --- escaped character -go (esc:c:cl) curarg accargs quote - | isEscapeChar esc - = if isEscapable c - then go cl (c:curarg) accargs quote - else go (c:cl) (esc:curarg) accargs quote go (c:cl) curarg accargs quotes - -- quote character -- opens quotes - | isQuote c, isNothing quotes - = go cl curarg accargs (Just c) + -- open quotes + | c == '\STX', not quotes + = go cl curarg accargs True -- close quotes - | quotes == Just c - = go cl curarg accargs Nothing - -- space separates argumetns outside quotes - | isSpace c, isNothing quotes + | c == '\ETX', quotes + = go cl curarg accargs False + -- space separates arguments outside quotes + | isSpace c, not quotes = if null curarg then go cl curarg accargs quotes else go cl [] (reverse curarg : accargs) quotes @@ -52,4 +36,4 @@ go (c:cl) curarg accargs quotes | otherwise = go cl (c:curarg) accargs quotes parseCmdLine :: String -> [String] -parseCmdLine comline = go comline [] [] Nothing +parseCmdLine comline = go comline [] [] False diff --git a/test/ShellParseSpec.hs b/test/ShellParseSpec.hs index 3d02f43..8817ec7 100644 --- a/test/ShellParseSpec.hs +++ b/test/ShellParseSpec.hs @@ -10,27 +10,9 @@ spec = describe "parseCmdLine" $ do it "splits arguments" $ parseCmdLine "test command line" `shouldBe` ["test", "command", "line"] - it "honors double quotes" $ - parseCmdLine "test command line \"with double quotes\"" - `shouldBe` ["test", "command", "line", "with double quotes"] - it "escapes spaces" $ do - parseCmdLine "with\\ spaces" - `shouldBe` ["with spaces"] - parseCmdLine "\"with\\ spaces\"" - `shouldBe` ["with spaces"] - it "escapes '\\'" $ do - parseCmdLine "\\\\" - `shouldBe` ["\\"] - parseCmdLine "\"\\\\\"" - `shouldBe` ["\\"] - it "escapes double quotes" $ do - parseCmdLine "\\\"" - `shouldBe` ["\""] - parseCmdLine "\"\\\"\"" - `shouldBe` ["\""] - it "doesn't escape random characters" $ - parseCmdLine "\\a\\b\\c" - `shouldBe` ["\\a\\b\\c"] + it "honors quoted segments" $ + parseCmdLine "test command line \STXwith quoted segment\ETX" + `shouldBe` ["test", "command", "line", "with quoted segment"] it "squashes multiple spaces" $ parseCmdLine "test command" `shouldBe` ["test", "command"] From d49d4cf2ea9a227e3f310105a8d7d2cb31426d95 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Wed, 30 Dec 2015 20:46:06 +0300 Subject: [PATCH 02/15] [Shell-escape] Escape toggle with \ prefix E.g. check file.hs will treat quote characters as literal characters, while \check file.hs will assume quoting behavior Backslash will be dropped, naturally. --- src/GHCMod/Options/ShellParse.hs | 4 +++- test/ShellParseSpec.hs | 14 ++++++++++---- 2 files changed, 13 insertions(+), 5 deletions(-) diff --git a/src/GHCMod/Options/ShellParse.hs b/src/GHCMod/Options/ShellParse.hs index 4ad4efe..2bcba0c 100644 --- a/src/GHCMod/Options/ShellParse.hs +++ b/src/GHCMod/Options/ShellParse.hs @@ -36,4 +36,6 @@ go (c:cl) curarg accargs quotes | otherwise = go cl (c:curarg) accargs quotes parseCmdLine :: String -> [String] -parseCmdLine comline = go comline [] [] False +parseCmdLine ('\\':comline) = go comline [] [] False +parseCmdLine [] = [""] +parseCmdLine comline = words comline diff --git a/test/ShellParseSpec.hs b/test/ShellParseSpec.hs index 8817ec7..30274f9 100644 --- a/test/ShellParseSpec.hs +++ b/test/ShellParseSpec.hs @@ -8,11 +8,17 @@ import Test.Hspec spec :: Spec spec = describe "parseCmdLine" $ do - it "splits arguments" $ + it "splits arguments" $ do parseCmdLine "test command line" `shouldBe` ["test", "command", "line"] - it "honors quoted segments" $ - parseCmdLine "test command line \STXwith quoted segment\ETX" + parseCmdLine "\\test command line" `shouldBe` ["test", "command", "line"] + it "honors quoted segments if turned on" $ + parseCmdLine "\\test command line \STXwith quoted segment\ETX" `shouldBe` ["test", "command", "line", "with quoted segment"] - it "squashes multiple spaces" $ + it "doesn't honor quoted segments if turned off" $ + parseCmdLine "test command line \STXwith quoted segment\ETX" + `shouldBe` words "test command line \STXwith quoted segment\ETX" + it "squashes multiple spaces" $ do parseCmdLine "test command" `shouldBe` ["test", "command"] + parseCmdLine "\\test command" + `shouldBe` ["test", "command"] From 849496c0473b4fadd34ebf6b524cbe2737256d8f Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Wed, 30 Dec 2015 21:11:39 +0300 Subject: [PATCH 03/15] [Shell-escape] 'ascii-escape ' prefix toggle --- src/GHCMod/Options/ShellParse.hs | 5 ++++- test/ShellParseSpec.hs | 11 ++++++++--- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/src/GHCMod/Options/ShellParse.hs b/src/GHCMod/Options/ShellParse.hs index 2bcba0c..acd609b 100644 --- a/src/GHCMod/Options/ShellParse.hs +++ b/src/GHCMod/Options/ShellParse.hs @@ -16,6 +16,7 @@ module GHCMod.Options.ShellParse (parseCmdLine) where import Data.Char +import Data.List go :: String -> String -> [String] -> Bool -> [String] -- result @@ -36,6 +37,8 @@ go (c:cl) curarg accargs quotes | otherwise = go cl (c:curarg) accargs quotes parseCmdLine :: String -> [String] -parseCmdLine ('\\':comline) = go comline [] [] False +parseCmdLine comline' + | Just comline <- stripPrefix "ascii-escape " $ dropWhile isSpace comline' + = go (dropWhile isSpace comline) [] [] False parseCmdLine [] = [""] parseCmdLine comline = words comline diff --git a/test/ShellParseSpec.hs b/test/ShellParseSpec.hs index 30274f9..5517a11 100644 --- a/test/ShellParseSpec.hs +++ b/test/ShellParseSpec.hs @@ -10,9 +10,9 @@ spec = describe "parseCmdLine" $ do it "splits arguments" $ do parseCmdLine "test command line" `shouldBe` ["test", "command", "line"] - parseCmdLine "\\test command line" `shouldBe` ["test", "command", "line"] + parseCmdLine "ascii-escape test command line" `shouldBe` ["test", "command", "line"] it "honors quoted segments if turned on" $ - parseCmdLine "\\test command line \STXwith quoted segment\ETX" + parseCmdLine "ascii-escape test command line \STXwith quoted segment\ETX" `shouldBe` ["test", "command", "line", "with quoted segment"] it "doesn't honor quoted segments if turned off" $ parseCmdLine "test command line \STXwith quoted segment\ETX" @@ -20,5 +20,10 @@ spec = it "squashes multiple spaces" $ do parseCmdLine "test command" `shouldBe` ["test", "command"] - parseCmdLine "\\test command" + parseCmdLine "ascii-escape test command" + `shouldBe` ["test", "command"] + it "ingores leading spaces" $ do + parseCmdLine " test command" + `shouldBe` ["test", "command"] + parseCmdLine " ascii-escape test command" `shouldBe` ["test", "command"] From 9f5dc6dc3cf8112bec1b77531ecf866e179c100c Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Wed, 30 Dec 2015 21:18:57 +0300 Subject: [PATCH 04/15] [Shell-escape] Add empty input string test --- test/ShellParseSpec.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/test/ShellParseSpec.hs b/test/ShellParseSpec.hs index 5517a11..2c5cefe 100644 --- a/test/ShellParseSpec.hs +++ b/test/ShellParseSpec.hs @@ -27,3 +27,8 @@ spec = `shouldBe` ["test", "command"] parseCmdLine " ascii-escape test command" `shouldBe` ["test", "command"] + it "parses empty string as no argument" $ do + parseCmdLine "" + `shouldBe` [""] + parseCmdLine "ascii-escape " + `shouldBe` [""] From 699ce178cbf917ed88a520915593a9d0d16af912 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sat, 2 Jan 2016 00:49:22 +0100 Subject: [PATCH 05/15] Split L.H.GM.Monad.Types module --- Language/Haskell/GhcMod/Monad/Compat.hs_h | 32 ++ Language/Haskell/GhcMod/Monad/Env.hs | 68 ++++ Language/Haskell/GhcMod/Monad/Log.hs | 71 +++++ Language/Haskell/GhcMod/Monad/Newtypes.hs | 198 ++++++++++++ Language/Haskell/GhcMod/Monad/Orphans.hs | 69 ++++ Language/Haskell/GhcMod/Monad/Out.hs | 52 +++ Language/Haskell/GhcMod/Monad/State.hs | 67 ++++ Language/Haskell/GhcMod/Monad/Types.hs | 372 +--------------------- ghc-mod.cabal | 6 + 9 files changed, 575 insertions(+), 360 deletions(-) create mode 100644 Language/Haskell/GhcMod/Monad/Compat.hs_h create mode 100644 Language/Haskell/GhcMod/Monad/Env.hs create mode 100644 Language/Haskell/GhcMod/Monad/Log.hs create mode 100644 Language/Haskell/GhcMod/Monad/Newtypes.hs create mode 100644 Language/Haskell/GhcMod/Monad/Orphans.hs create mode 100644 Language/Haskell/GhcMod/Monad/Out.hs create mode 100644 Language/Haskell/GhcMod/Monad/State.hs diff --git a/Language/Haskell/GhcMod/Monad/Compat.hs_h b/Language/Haskell/GhcMod/Monad/Compat.hs_h new file mode 100644 index 0000000..4aafa75 --- /dev/null +++ b/Language/Haskell/GhcMod/Monad/Compat.hs_h @@ -0,0 +1,32 @@ +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015,2016 Daniel Gröber +-- +-- 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 . + +-- MonadUtils of GHC 7.6 or earlier defines its own MonadIO. +-- RWST does not automatically become an instance of MonadIO. +-- MonadUtils of GHC 7.8 or later imports MonadIO in Monad.Control.IO.Class. +-- So, RWST automatically becomes an instance of +#if __GLASGOW_HASKELL__ < 708 +-- 'CoreMonad.MonadIO' and 'Control.Monad.IO.Class.MonadIO' are different +-- classes before ghc 7.8 +#define DIFFERENT_MONADIO 1 + +-- RWST doen't have a MonadIO instance before ghc 7.8 +#define MONADIO_INSTANCES 1 +#endif + +#if DIFFERENT_MONADIO +import Data.Monoid (Monoid) +#endif diff --git a/Language/Haskell/GhcMod/Monad/Env.hs b/Language/Haskell/GhcMod/Monad/Env.hs new file mode 100644 index 0000000..e154e50 --- /dev/null +++ b/Language/Haskell/GhcMod/Monad/Env.hs @@ -0,0 +1,68 @@ +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015,2016 Daniel Gröber +-- +-- 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 . + +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} + +module Language.Haskell.GhcMod.Monad.Env where + +import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Monad.Newtypes + +import Control.Monad +import Control.Monad.Trans.Journal (JournalT) +import Control.Monad.State.Strict (StateT(..)) +import Control.Monad.Error (ErrorT(..)) +import Control.Monad.Reader.Class +import Control.Monad.Trans.Class (MonadTrans(..)) +import Prelude + +class Monad m => GmEnv m where + gmeAsk :: m GhcModEnv + gmeAsk = gmeReader id + + gmeReader :: (GhcModEnv -> a) -> m a + gmeReader f = f `liftM` gmeAsk + + gmeLocal :: (GhcModEnv -> GhcModEnv) -> m a -> m a + {-# MINIMAL (gmeAsk | gmeReader), gmeLocal #-} + +instance Monad m => GmEnv (GmT m) where + gmeAsk = GmT ask + gmeReader = GmT . reader + gmeLocal f a = GmT $ local f (unGmT a) + +instance GmEnv m => GmEnv (GmOutT m) where + gmeAsk = lift gmeAsk + gmeReader = lift . gmeReader + gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma)) + +instance GmEnv m => GmEnv (StateT s m) where + gmeAsk = lift gmeAsk + gmeReader = lift . gmeReader + gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma)) + +instance GmEnv m => GmEnv (JournalT GhcModLog m) where + gmeAsk = lift gmeAsk + gmeReader = lift . gmeReader + gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma)) + +instance GmEnv m => GmEnv (ErrorT GhcModError m) where + gmeAsk = lift gmeAsk + gmeReader = lift . gmeReader + gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma)) + +deriving instance (Monad m, GmEnv (GhcModT m)) => GmEnv (GmlT m) diff --git a/Language/Haskell/GhcMod/Monad/Log.hs b/Language/Haskell/GhcMod/Monad/Log.hs new file mode 100644 index 0000000..f0b245b --- /dev/null +++ b/Language/Haskell/GhcMod/Monad/Log.hs @@ -0,0 +1,71 @@ +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015,2016 Daniel Gröber +-- +-- 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 . + +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} + +module Language.Haskell.GhcMod.Monad.Log where + +import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Monad.Newtypes + +import Control.Monad +import Control.Monad.Trans.Journal (JournalT) +import Control.Monad.Reader (ReaderT(..)) +import Control.Monad.State.Strict (StateT(..)) +import Control.Monad.Error (Error, ErrorT(..)) +import Control.Monad.Trans.Maybe (MaybeT(..)) +import Control.Monad.Journal.Class (MonadJournal(..)) +import Control.Monad.Trans.Class (MonadTrans(..)) +import Prelude + +class Monad m => GmLog m where + gmlJournal :: GhcModLog -> m () + gmlHistory :: m GhcModLog + gmlClear :: m () + +instance Monad m => GmLog (JournalT GhcModLog m) where + gmlJournal = journal + gmlHistory = history + gmlClear = clear + +instance Monad m => GmLog (GmT m) where + gmlJournal = GmT . lift . lift . journal + gmlHistory = GmT $ lift $ lift history + gmlClear = GmT $ lift $ lift clear + +instance (Monad m, GmLog m) => GmLog (ReaderT r m) where + gmlJournal = lift . gmlJournal + gmlHistory = lift gmlHistory + gmlClear = lift gmlClear + +instance (Monad m, GmLog m) => GmLog (StateT s m) where + gmlJournal = lift . gmlJournal + gmlHistory = lift gmlHistory + gmlClear = lift gmlClear + +instance (Monad m, GmLog m, Error e) => GmLog (ErrorT e m) where + gmlJournal = lift . gmlJournal + gmlHistory = lift gmlHistory + gmlClear = lift gmlClear + +instance (Monad m, GmLog m) => GmLog (MaybeT m) where + gmlJournal = lift . gmlJournal + gmlHistory = lift gmlHistory + gmlClear = lift gmlClear + +deriving instance GmLog m => GmLog (GmOutT m) +deriving instance (Monad m, GmLog (GhcModT m)) => GmLog (GmlT m) diff --git a/Language/Haskell/GhcMod/Monad/Newtypes.hs b/Language/Haskell/GhcMod/Monad/Newtypes.hs new file mode 100644 index 0000000..915dded --- /dev/null +++ b/Language/Haskell/GhcMod/Monad/Newtypes.hs @@ -0,0 +1,198 @@ +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015,2016 Daniel Gröber +-- +-- 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 . + +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, DeriveFunctor #-} +{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE RankNTypes, FlexibleInstances #-} + +module Language.Haskell.GhcMod.Monad.Newtypes where + +#include "Compat.hs_h" + +import Language.Haskell.GhcMod.Types + +import GHC + +import Control.Applicative +import Control.Monad + +import Control.Monad.Reader (ReaderT(..)) +import Control.Monad.Error (ErrorT(..), MonadError(..)) +import Control.Monad.State.Strict (StateT(..)) +import Control.Monad.Trans.Journal (JournalT) +import Control.Monad.Reader.Class +import Control.Monad.State.Class (MonadState(..)) +import Control.Monad.Journal.Class (MonadJournal(..)) +import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad.Trans.Control +import Control.Monad.Base (MonadBase(..), liftBase) + +#if DIFFERENT_MONADIO +import qualified MonadUtils as GHC (MonadIO(..)) +#endif +import qualified Control.Monad.IO.Class as MTL + +import Data.IORef +import Prelude + + +type GhcModT m = GmT (GmOutT m) + +newtype GmOutT m a = GmOutT { + unGmOutT :: ReaderT GhcModOut m a + } deriving ( Functor + , Applicative + , Alternative + , Monad + , MonadPlus + , MonadTrans + , MTL.MonadIO +#if DIFFERENT_MONADIO + , GHC.MonadIO +#endif + ) + +newtype GmT m a = GmT { + unGmT :: StateT GhcModState + (ErrorT GhcModError + (JournalT GhcModLog + (ReaderT GhcModEnv m) ) ) a + } deriving ( Functor + , Applicative + , Alternative + , Monad + , MonadPlus + , MTL.MonadIO +#if DIFFERENT_MONADIO + , GHC.MonadIO +#endif + , MonadError GhcModError + ) + +newtype GmlT m a = GmlT { unGmlT :: GhcModT m a } + deriving ( Functor + , Applicative + , Alternative + , Monad + , MonadPlus + , MTL.MonadIO +#if DIFFERENT_MONADIO + , GHC.MonadIO +#endif + , MonadError GhcModError + ) + +newtype LightGhc a = LightGhc { unLightGhc :: ReaderT (IORef HscEnv) IO a } + deriving ( Functor + , Applicative + , Monad + , MTL.MonadIO +#if DIFFERENT_MONADIO + , GHC.MonadIO +#endif + ) + +-- GmOutT ---------------------------------------- +instance (MonadBaseControl IO m) => MonadBase IO (GmOutT m) where + liftBase = GmOutT . liftBase + +instance (MonadBaseControl IO m) => MonadBaseControl IO (GmOutT m) where + type StM (GmOutT m) a = StM (ReaderT GhcModEnv m) a + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM + {-# INLINE liftBaseWith #-} + {-# INLINE restoreM #-} + +instance MonadTransControl GmOutT where + type StT GmOutT a = StT (ReaderT GhcModEnv) a + liftWith = defaultLiftWith GmOutT unGmOutT + restoreT = defaultRestoreT GmOutT + + +-- GmlT ------------------------------------------ +instance (MonadBaseControl IO m) => MonadBase IO (GmlT m) where + liftBase = GmlT . liftBase + +instance (MonadBaseControl IO m) => MonadBaseControl IO (GmlT m) where + type StM (GmlT m) a = StM (GmT m) a + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM + {-# INLINE liftBaseWith #-} + {-# INLINE restoreM #-} + +instance MonadTransControl GmlT where + type StT GmlT a = StT GmT a + liftWith f = GmlT $ + liftWith $ \runGm -> + liftWith $ \runEnv -> + f $ \ma -> runEnv $ runGm $ unGmlT ma + restoreT = GmlT . restoreT . restoreT + +instance MonadTrans GmlT where + lift = GmlT . lift . lift + +-- GmT ------------------------------------------ + +instance forall r m. MonadReader r m => MonadReader r (GmT m) where + local f ma = gmLiftWithInner (\run -> local f (run ma)) + ask = gmLiftInner ask + +instance MonadState s m => MonadState s (GmT m) where + get = GmT $ lift $ lift $ lift get + put = GmT . lift . lift . lift . put + state = GmT . lift . lift . lift . state + +instance Monad m => MonadJournal GhcModLog (GmT m) where + journal w = GmT $ lift $ lift $ (journal w) + history = GmT $ lift $ lift $ history + clear = GmT $ lift $ lift $ clear + +instance (MonadBaseControl IO m) => MonadBase IO (GmT m) where + liftBase = GmT . liftBase + +instance (MonadBaseControl IO m) => MonadBaseControl IO (GmT m) where + type StM (GmT m) a = + StM (StateT GhcModState + (ErrorT GhcModError + (JournalT GhcModLog + (ReaderT GhcModEnv m) ) ) ) a + liftBaseWith f = GmT (liftBaseWith $ \runInBase -> + f $ runInBase . unGmT) + restoreM = GmT . restoreM + {-# INLINE liftBaseWith #-} + {-# INLINE restoreM #-} + +instance MonadTransControl GmT where + type StT GmT a = (Either GhcModError (a, GhcModState), GhcModLog) + liftWith f = GmT $ + liftWith $ \runS -> + liftWith $ \runE -> + liftWith $ \runJ -> + liftWith $ \runR -> + f $ \ma -> runR $ runJ $ runE $ runS $ unGmT ma + restoreT = GmT . restoreT . restoreT . restoreT . restoreT + {-# INLINE liftWith #-} + {-# INLINE restoreT #-} + +instance MonadTrans GmT where + lift = GmT . lift . lift . lift . lift + +gmLiftInner :: Monad m => m a -> GmT m a +gmLiftInner = GmT . lift . lift . lift . lift + +gmLiftWithInner :: (MonadTransControl t, Monad m, Monad (t m)) + => (Run t -> m (StT t a)) -> t m a +gmLiftWithInner f = liftWith f >>= restoreT . return diff --git a/Language/Haskell/GhcMod/Monad/Orphans.hs b/Language/Haskell/GhcMod/Monad/Orphans.hs new file mode 100644 index 0000000..80c1fb3 --- /dev/null +++ b/Language/Haskell/GhcMod/Monad/Orphans.hs @@ -0,0 +1,69 @@ +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015,2016 Daniel Gröber +-- +-- 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 . + +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Language.Haskell.GhcMod.Monad.Orphans where + +#include "Compat.hs_h" + +import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Monad.Newtypes + +import qualified Control.Monad.IO.Class as MTL + +import Control.Monad.Reader (ReaderT(..)) +import Control.Monad.State.Strict (StateT(..)) +import Control.Monad.Trans.Journal (JournalT) +import Control.Monad.Trans.Maybe (MaybeT(..)) +import Control.Monad.Error (Error(..), ErrorT(..)) + +-------------------------------------------------- +-- Miscellaneous instances + +#if DIFFERENT_MONADIO +instance MTL.MonadIO m => GHC.MonadIO (ReaderT x m) where + liftIO = MTL.liftIO +instance MTL.MonadIO m => GHC.MonadIO (StateT x m) where + liftIO = MTL.liftIO +instance (Error e, MTL.MonadIO m) => GHC.MonadIO (ErrorT e m) where + liftIO = MTL.liftIO +instance MTL.MonadIO m => GHC.MonadIO (JournalT x m) where + liftIO = MTL.liftIO +instance MTL.MonadIO m => GHC.MonadIO (MaybeT m) where + liftIO = MTL.liftIO +#endif + +instance MonadIO IO where + liftIO = id +instance MonadIO m => MonadIO (ReaderT x m) where + liftIO = MTL.liftIO +instance MonadIO m => MonadIO (StateT x m) where + liftIO = MTL.liftIO +instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where + liftIO = MTL.liftIO +instance MonadIO m => MonadIO (JournalT x m) where + liftIO = MTL.liftIO +instance MonadIO m => MonadIO (MaybeT m) where + liftIO = MTL.liftIO +instance MonadIOC m => MonadIO (GmOutT m) where + liftIO = MTL.liftIO +instance MonadIOC m => MonadIO (GmT m) where + liftIO = MTL.liftIO +instance MonadIOC m => MonadIO (GmlT m) where + liftIO = MTL.liftIO +instance MonadIO LightGhc where + liftIO = MTL.liftIO diff --git a/Language/Haskell/GhcMod/Monad/Out.hs b/Language/Haskell/GhcMod/Monad/Out.hs new file mode 100644 index 0000000..92e88db --- /dev/null +++ b/Language/Haskell/GhcMod/Monad/Out.hs @@ -0,0 +1,52 @@ +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015,2016 Daniel Gröber +-- +-- 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 . + +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-} + +module Language.Haskell.GhcMod.Monad.Out where + +import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Monad.Newtypes + +import Control.Monad +import Control.Monad.State.Strict (StateT(..)) +import Control.Monad.Trans.Journal (JournalT) +import Control.Monad.Trans.Maybe (MaybeT(..)) +import Control.Monad.Reader.Class +import Control.Monad.Trans.Class (MonadTrans(..)) +import Prelude + +class Monad m => GmOut m where + gmoAsk :: m GhcModOut + +instance Monad m => GmOut (GmOutT m) where + gmoAsk = GmOutT ask + +instance Monad m => GmOut (GmlT m) where + gmoAsk = GmlT $ lift $ GmOutT ask + +instance GmOut m => GmOut (GmT m) where + gmoAsk = lift gmoAsk + +instance GmOut m => GmOut (StateT s m) where + gmoAsk = lift gmoAsk + +instance GmOut m => GmOut (JournalT w m) where + gmoAsk = lift gmoAsk + +instance GmOut m => GmOut (MaybeT m) where + gmoAsk = lift gmoAsk diff --git a/Language/Haskell/GhcMod/Monad/State.hs b/Language/Haskell/GhcMod/Monad/State.hs new file mode 100644 index 0000000..701ba27 --- /dev/null +++ b/Language/Haskell/GhcMod/Monad/State.hs @@ -0,0 +1,67 @@ +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015,2016 Daniel Gröber +-- +-- 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 . + +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} + +module Language.Haskell.GhcMod.Monad.State where + +import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Monad.Newtypes + +import Control.Monad +import Control.Monad.State.Strict (StateT(..)) +import Control.Monad.Trans.Maybe (MaybeT(..)) +import Control.Monad.State.Class (MonadState(..)) +import Control.Monad.Trans.Class (MonadTrans(..)) +import Prelude + +class Monad m => GmState m where + gmsGet :: m GhcModState + gmsGet = gmsState (\s -> (s, s)) + + gmsPut :: GhcModState -> m () + gmsPut s = gmsState (\_ -> ((), s)) + + gmsState :: (GhcModState -> (a, GhcModState)) -> m a + gmsState f = do + s <- gmsGet + let ~(a, s') = f s + gmsPut s' + return a + {-# MINIMAL gmsState | gmsGet, gmsPut #-} + +instance GmState m => GmState (StateT s m) where + gmsGet = lift gmsGet + gmsPut = lift . gmsPut + gmsState = lift . gmsState + +instance Monad m => GmState (StateT GhcModState m) where + gmsGet = get + gmsPut = put + gmsState = state + +instance Monad m => GmState (GmT m) where + gmsGet = GmT get + gmsPut = GmT . put + gmsState = GmT . state + +instance GmState m => GmState (MaybeT m) where + gmsGet = MaybeT $ Just `liftM` gmsGet + gmsPut = MaybeT . (Just `liftM`) . gmsPut + gmsState = MaybeT . (Just `liftM`) . gmsState + +deriving instance (Monad m, GmState (GhcModT m)) => GmState (GmlT m) diff --git a/Language/Haskell/GhcMod/Monad/Types.hs b/Language/Haskell/GhcMod/Monad/Types.hs index eb6baed..8b2ac50 100644 --- a/Language/Haskell/GhcMod/Monad/Types.hs +++ b/Language/Haskell/GhcMod/Monad/Types.hs @@ -62,21 +62,17 @@ module Language.Haskell.GhcMod.Monad.Types ( , gmlSetSession ) where --- MonadUtils of GHC 7.6 or earlier defines its own MonadIO. --- RWST does not automatically become an instance of MonadIO. --- MonadUtils of GHC 7.8 or later imports MonadIO in Monad.Control.IO.Class. --- So, RWST automatically becomes an instance of -#if __GLASGOW_HASKELL__ < 708 --- 'CoreMonad.MonadIO' and 'Control.Monad.IO.Class.MonadIO' are different --- classes before ghc 7.8 -#define DIFFERENT_MONADIO 1 - --- RWST doen't have a MonadIO instance before ghc 7.8 -#define MONADIO_INSTANCES 1 -#endif +#include "Compat.hs_h" import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Monad.Env +import Language.Haskell.GhcMod.Monad.State +import Language.Haskell.GhcMod.Monad.Log +import Language.Haskell.GhcMod.Monad.Out +import Language.Haskell.GhcMod.Monad.Newtypes +import Language.Haskell.GhcMod.Monad.Orphans () + import GHC import DynFlags import Exception @@ -86,25 +82,12 @@ import Control.Applicative import Control.Monad import Control.Monad.Reader (ReaderT(..)) -import Control.Monad.Error (ErrorT(..), MonadError(..)) import Control.Monad.State.Strict (StateT(..)) import Control.Monad.Trans.Journal (JournalT) -import Control.Monad.Trans.Maybe (MaybeT(..)) -import Control.Monad.Base (MonadBase(..), liftBase) import Control.Monad.Trans.Control import Control.Monad.Reader.Class -import Control.Monad.Writer.Class -import Control.Monad.State.Class (MonadState(..)) -import Control.Monad.Journal.Class (MonadJournal(..)) -import Control.Monad.Trans.Class (MonadTrans(..)) -import Control.Monad.Error (Error(..)) -import qualified Control.Monad.IO.Class as MTL - -#if DIFFERENT_MONADIO -import Data.Monoid (Monoid) -#endif import qualified Data.Map as M import Data.Maybe @@ -112,339 +95,8 @@ import Data.Monoid import Data.IORef import Prelude -import qualified MonadUtils as GHC (MonadIO(..)) - -type GhcModT m = GmT (GmOutT m) - -newtype GmOutT m a = GmOutT { - unGmOutT :: ReaderT GhcModOut m a - } deriving ( Functor - , Applicative - , Alternative - , Monad - , MonadPlus - , MonadTrans - , MTL.MonadIO -#if DIFFERENT_MONADIO - , GHC.MonadIO -#endif - , GmLog - ) - -newtype GmT m a = GmT { - unGmT :: StateT GhcModState - (ErrorT GhcModError - (JournalT GhcModLog - (ReaderT GhcModEnv m) ) ) a - } deriving ( Functor - , Applicative - , Alternative - , Monad - , MonadPlus - , MTL.MonadIO -#if DIFFERENT_MONADIO - , GHC.MonadIO -#endif - , MonadError GhcModError - ) - -newtype GmlT m a = GmlT { unGmlT :: GhcModT m a } - deriving ( Functor - , Applicative - , Alternative - , Monad - , MonadPlus - , MTL.MonadIO -#if DIFFERENT_MONADIO - , GHC.MonadIO -#endif - , MonadError GhcModError - , GmEnv - , GmState - , GmLog - ) - -newtype LightGhc a = LightGhc { unLightGhc :: ReaderT (IORef HscEnv) IO a } - deriving ( Functor - , Applicative - , Monad - , MTL.MonadIO -#if DIFFERENT_MONADIO - , GHC.MonadIO -#endif - ) - --------------------------------------------------- --- Miscellaneous instances - -#if DIFFERENT_MONADIO -instance MTL.MonadIO m => GHC.MonadIO (ReaderT x m) where - liftIO = MTL.liftIO -instance MTL.MonadIO m => GHC.MonadIO (StateT x m) where - liftIO = MTL.liftIO -instance (Error e, MTL.MonadIO m) => GHC.MonadIO (ErrorT e m) where - liftIO = MTL.liftIO -instance MTL.MonadIO m => GHC.MonadIO (JournalT x m) where - liftIO = MTL.liftIO -instance MTL.MonadIO m => GHC.MonadIO (MaybeT m) where - liftIO = MTL.liftIO -#endif - -instance MonadIO IO where - liftIO = id -instance MonadIO m => MonadIO (ReaderT x m) where - liftIO = MTL.liftIO -instance MonadIO m => MonadIO (StateT x m) where - liftIO = MTL.liftIO -instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where - liftIO = MTL.liftIO -instance MonadIO m => MonadIO (JournalT x m) where - liftIO = MTL.liftIO -instance MonadIO m => MonadIO (MaybeT m) where - liftIO = MTL.liftIO -instance MonadIOC m => MonadIO (GmOutT m) where - liftIO = MTL.liftIO -instance MonadIOC m => MonadIO (GmT m) where - liftIO = MTL.liftIO -instance MonadIOC m => MonadIO (GmlT m) where - liftIO = MTL.liftIO -instance MonadIO LightGhc where - liftIO = MTL.liftIO - -instance MonadTrans GmT where - lift = GmT . lift . lift . lift . lift -instance MonadTrans GmlT where - lift = GmlT . lift . lift - --------------------------------------------------- --- Gm Classes - type Gm m = (GmEnv m, GmState m, GmLog m, GmOut m) --- GmEnv ----------------------------------------- -class Monad m => GmEnv m where - gmeAsk :: m GhcModEnv - gmeAsk = gmeReader id - - gmeReader :: (GhcModEnv -> a) -> m a - gmeReader f = f `liftM` gmeAsk - - gmeLocal :: (GhcModEnv -> GhcModEnv) -> m a -> m a - {-# MINIMAL (gmeAsk | gmeReader), gmeLocal #-} - -instance Monad m => GmEnv (GmT m) where - gmeAsk = GmT ask - gmeReader = GmT . reader - gmeLocal f a = GmT $ local f (unGmT a) - -instance GmEnv m => GmEnv (GmOutT m) where - gmeAsk = lift gmeAsk - gmeReader = lift . gmeReader - gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma)) - -instance GmEnv m => GmEnv (StateT s m) where - gmeAsk = lift gmeAsk - gmeReader = lift . gmeReader - gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma)) - -instance GmEnv m => GmEnv (JournalT GhcModLog m) where - gmeAsk = lift gmeAsk - gmeReader = lift . gmeReader - gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma)) - -instance GmEnv m => GmEnv (ErrorT GhcModError m) where - gmeAsk = lift gmeAsk - gmeReader = lift . gmeReader - gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma)) - --- GmState --------------------------------------- -class Monad m => GmState m where - gmsGet :: m GhcModState - gmsGet = gmsState (\s -> (s, s)) - - gmsPut :: GhcModState -> m () - gmsPut s = gmsState (\_ -> ((), s)) - - gmsState :: (GhcModState -> (a, GhcModState)) -> m a - gmsState f = do - s <- gmsGet - let ~(a, s') = f s - gmsPut s' - return a - {-# MINIMAL gmsState | gmsGet, gmsPut #-} - -instance GmState m => GmState (StateT s m) where - gmsGet = lift gmsGet - gmsPut = lift . gmsPut - gmsState = lift . gmsState - -instance Monad m => GmState (StateT GhcModState m) where - gmsGet = get - gmsPut = put - gmsState = state - -instance Monad m => GmState (GmT m) where - gmsGet = GmT get - gmsPut = GmT . put - gmsState = GmT . state - -instance GmState m => GmState (MaybeT m) where - gmsGet = MaybeT $ Just `liftM` gmsGet - gmsPut = MaybeT . (Just `liftM`) . gmsPut - gmsState = MaybeT . (Just `liftM`) . gmsState - --- GmLog ----------------------------------------- -class Monad m => GmLog m where - gmlJournal :: GhcModLog -> m () - gmlHistory :: m GhcModLog - gmlClear :: m () - -instance Monad m => GmLog (JournalT GhcModLog m) where - gmlJournal = journal - gmlHistory = history - gmlClear = clear - -instance Monad m => GmLog (GmT m) where - gmlJournal = GmT . lift . lift . journal - gmlHistory = GmT $ lift $ lift history - gmlClear = GmT $ lift $ lift clear - -instance (Monad m, GmLog m) => GmLog (ReaderT r m) where - gmlJournal = lift . gmlJournal - gmlHistory = lift gmlHistory - gmlClear = lift gmlClear - -instance (Monad m, GmLog m) => GmLog (StateT s m) where - gmlJournal = lift . gmlJournal - gmlHistory = lift gmlHistory - gmlClear = lift gmlClear - -instance (Monad m, GmLog m) => GmLog (MaybeT m) where - gmlJournal = lift . gmlJournal - gmlHistory = lift gmlHistory - gmlClear = lift gmlClear - --- GmOut ----------------------------------------- -class Monad m => GmOut m where - gmoAsk :: m GhcModOut - -instance Monad m => GmOut (GmOutT m) where - gmoAsk = GmOutT ask - -instance Monad m => GmOut (GmlT m) where - gmoAsk = GmlT $ lift $ GmOutT ask - -instance GmOut m => GmOut (GmT m) where - gmoAsk = lift gmoAsk - -instance GmOut m => GmOut (StateT s m) where - gmoAsk = lift gmoAsk - -instance GmOut m => GmOut (JournalT w m) where - gmoAsk = lift gmoAsk - -instance GmOut m => GmOut (MaybeT m) where - gmoAsk = lift gmoAsk - -instance Monad m => MonadJournal GhcModLog (GmT m) where - journal !w = GmT $ lift $ lift $ (journal w) - history = GmT $ lift $ lift $ history - clear = GmT $ lift $ lift $ clear - -instance forall r m. MonadReader r m => MonadReader r (GmT m) where - local f ma = gmLiftWithInner (\run -> local f (run ma)) - ask = gmLiftInner ask - -instance (Monoid w, MonadWriter w m) => MonadWriter w (GmT m) where - tell = gmLiftInner . tell - listen ma = - liftWith (\run -> listen (run ma)) >>= \(sta, w) -> - flip (,) w `liftM` restoreT (return sta) - - pass maww = maww >>= gmLiftInner . pass . return - -instance MonadState s m => MonadState s (GmT m) where - get = GmT $ lift $ lift $ lift get - put = GmT . lift . lift . lift . put - state = GmT . lift . lift . lift . state - - --------------------------------------------------- --- monad-control instances - --- GmOutT ---------------------------------------- -instance (MonadBaseControl IO m) => MonadBase IO (GmOutT m) where - liftBase = GmOutT . liftBase - -instance (MonadBaseControl IO m) => MonadBaseControl IO (GmOutT m) where - type StM (GmOutT m) a = StM (ReaderT GhcModEnv m) a - liftBaseWith = defaultLiftBaseWith - restoreM = defaultRestoreM - {-# INLINE liftBaseWith #-} - {-# INLINE restoreM #-} - -instance MonadTransControl GmOutT where - type StT GmOutT a = StT (ReaderT GhcModEnv) a - liftWith = defaultLiftWith GmOutT unGmOutT - restoreT = defaultRestoreT GmOutT - - --- GmlT ------------------------------------------ -instance (MonadBaseControl IO m) => MonadBase IO (GmlT m) where - liftBase = GmlT . liftBase - -instance (MonadBaseControl IO m) => MonadBaseControl IO (GmlT m) where - type StM (GmlT m) a = StM (GmT m) a - liftBaseWith = defaultLiftBaseWith - restoreM = defaultRestoreM - {-# INLINE liftBaseWith #-} - {-# INLINE restoreM #-} - -instance MonadTransControl GmlT where - type StT GmlT a = StT GmT a - liftWith f = GmlT $ - liftWith $ \runGm -> - liftWith $ \runEnv -> - f $ \ma -> runEnv $ runGm $ unGmlT ma - restoreT = GmlT . restoreT . restoreT - - --- GmT ------------------------------------------ - -instance (MonadBaseControl IO m) => MonadBase IO (GmT m) where - liftBase = GmT . liftBase - -instance (MonadBaseControl IO m) => MonadBaseControl IO (GmT m) where - type StM (GmT m) a = - StM (StateT GhcModState - (ErrorT GhcModError - (JournalT GhcModLog - (ReaderT GhcModEnv m) ) ) ) a - liftBaseWith f = GmT (liftBaseWith $ \runInBase -> - f $ runInBase . unGmT) - restoreM = GmT . restoreM - {-# INLINE liftBaseWith #-} - {-# INLINE restoreM #-} - -instance MonadTransControl GmT where - type StT GmT a = (Either GhcModError (a, GhcModState), GhcModLog) - liftWith f = GmT $ - liftWith $ \runS -> - liftWith $ \runE -> - liftWith $ \runJ -> - liftWith $ \runR -> - f $ \ma -> runR $ runJ $ runE $ runS $ unGmT ma - restoreT = GmT . restoreT . restoreT . restoreT . restoreT - {-# INLINE liftWith #-} - {-# INLINE restoreT #-} - -gmLiftInner :: Monad m => m a -> GmT m a -gmLiftInner = GmT . lift . lift . lift . lift - -gmLiftWithInner :: (MonadTransControl t, Monad m, Monad (t m)) - => (Run t -> m (StT t a)) -> t m a -gmLiftWithInner f = liftWith f >>= restoreT . return - -------------------------------------------------- -- GHC API instances ----------------------------- @@ -463,16 +115,16 @@ instance (MonadIO m, MonadBaseControl IO m) => GhcMonad (GmlT m) where gmlGetSession :: (MonadIO m, MonadBaseControl IO m) => GmlT m HscEnv gmlGetSession = do ref <- gmgsSession . fromJust . gmGhcSession <$> gmsGet - GHC.liftIO $ readIORef ref + liftIO $ readIORef ref gmlSetSession :: (MonadIO m, MonadBaseControl IO m) => HscEnv -> GmlT m () gmlSetSession a = do ref <- gmgsSession . fromJust . gmGhcSession <$> gmsGet - GHC.liftIO $ flip writeIORef a ref + liftIO $ flip writeIORef a ref instance GhcMonad LightGhc where - getSession = (GHC.liftIO . readIORef) =<< LightGhc ask - setSession a = (GHC.liftIO . flip writeIORef a) =<< LightGhc ask + getSession = (liftIO . readIORef) =<< LightGhc ask + setSession a = (liftIO . flip writeIORef a) =<< LightGhc ask #if __GLASGOW_HASKELL__ >= 706 instance (MonadIO m, MonadBaseControl IO m) => HasDynFlags (GmlT m) where diff --git a/ghc-mod.cabal b/ghc-mod.cabal index cac9337..0a83e8e 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -131,6 +131,12 @@ Library Language.Haskell.GhcMod.Logging Language.Haskell.GhcMod.Modules Language.Haskell.GhcMod.Monad + Language.Haskell.GhcMod.Monad.Env + Language.Haskell.GhcMod.Monad.Log + Language.Haskell.GhcMod.Monad.Newtypes + Language.Haskell.GhcMod.Monad.Orphans + Language.Haskell.GhcMod.Monad.Out + Language.Haskell.GhcMod.Monad.State Language.Haskell.GhcMod.Monad.Types Language.Haskell.GhcMod.Output Language.Haskell.GhcMod.PathsAndFiles From cde7ac77f008c3597c92116e563e5d1df3ca74e9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sat, 2 Jan 2016 23:31:26 +0100 Subject: [PATCH 06/15] Add missing extra-src files --- ghc-mod.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 0a83e8e..dea4938 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -33,6 +33,7 @@ Extra-Source-Files: ChangeLog SetupCompat.hs NotCPP/*.hs NotCPP/COPYING + Language/Haskell/GhcMod/Monad/Compat.hs_h test/data/annotations/*.hs test/data/broken-cabal/*.cabal test/data/broken-cabal/cabal.sandbox.config.in From 67c9538f30ffac048fdab50b65d88ab36c255fbe Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 4 Jan 2016 01:09:38 +0100 Subject: [PATCH 07/15] Fix 7.6 warning --- Language/Haskell/GhcMod/Gap.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs index 00d8bc5..79c63de 100644 --- a/Language/Haskell/GhcMod/Gap.hs +++ b/Language/Haskell/GhcMod/Gap.hs @@ -370,7 +370,7 @@ pprInfo m pefas (thing, fixity, insts) (char '\t' <> ptext (sLit "--") <+> loc) where loc = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing') #else - pprTyThingInContextLoc' pefas thing' = hang (pprTyThingInContext pefas thing') 2 + pprTyThingInContextLoc' pefas' thing' = hang (pprTyThingInContext pefas' thing') 2 (char '\t' <> ptext (sLit "--") <+> loc) where loc = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing') #endif From d2f7df21dfd24796e9ce9af7416ed0f54320ae5c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 4 Jan 2016 01:10:04 +0100 Subject: [PATCH 08/15] Fix instances for GHC<7.8 --- Language/Haskell/GhcMod/Monad/Compat.hs_h | 4 ---- Language/Haskell/GhcMod/Monad/Newtypes.hs | 22 ---------------------- Language/Haskell/GhcMod/Monad/Orphans.hs | 16 +++++++++++++++- 3 files changed, 15 insertions(+), 27 deletions(-) diff --git a/Language/Haskell/GhcMod/Monad/Compat.hs_h b/Language/Haskell/GhcMod/Monad/Compat.hs_h index 4aafa75..7437bfc 100644 --- a/Language/Haskell/GhcMod/Monad/Compat.hs_h +++ b/Language/Haskell/GhcMod/Monad/Compat.hs_h @@ -26,7 +26,3 @@ -- RWST doen't have a MonadIO instance before ghc 7.8 #define MONADIO_INSTANCES 1 #endif - -#if DIFFERENT_MONADIO -import Data.Monoid (Monoid) -#endif diff --git a/Language/Haskell/GhcMod/Monad/Newtypes.hs b/Language/Haskell/GhcMod/Monad/Newtypes.hs index 915dded..dd7e5a6 100644 --- a/Language/Haskell/GhcMod/Monad/Newtypes.hs +++ b/Language/Haskell/GhcMod/Monad/Newtypes.hs @@ -40,15 +40,9 @@ import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Control import Control.Monad.Base (MonadBase(..), liftBase) -#if DIFFERENT_MONADIO -import qualified MonadUtils as GHC (MonadIO(..)) -#endif -import qualified Control.Monad.IO.Class as MTL - import Data.IORef import Prelude - type GhcModT m = GmT (GmOutT m) newtype GmOutT m a = GmOutT { @@ -59,10 +53,6 @@ newtype GmOutT m a = GmOutT { , Monad , MonadPlus , MonadTrans - , MTL.MonadIO -#if DIFFERENT_MONADIO - , GHC.MonadIO -#endif ) newtype GmT m a = GmT { @@ -75,10 +65,6 @@ newtype GmT m a = GmT { , Alternative , Monad , MonadPlus - , MTL.MonadIO -#if DIFFERENT_MONADIO - , GHC.MonadIO -#endif , MonadError GhcModError ) @@ -88,10 +74,6 @@ newtype GmlT m a = GmlT { unGmlT :: GhcModT m a } , Alternative , Monad , MonadPlus - , MTL.MonadIO -#if DIFFERENT_MONADIO - , GHC.MonadIO -#endif , MonadError GhcModError ) @@ -99,10 +81,6 @@ newtype LightGhc a = LightGhc { unLightGhc :: ReaderT (IORef HscEnv) IO a } deriving ( Functor , Applicative , Monad - , MTL.MonadIO -#if DIFFERENT_MONADIO - , GHC.MonadIO -#endif ) -- GmOutT ---------------------------------------- diff --git a/Language/Haskell/GhcMod/Monad/Orphans.hs b/Language/Haskell/GhcMod/Monad/Orphans.hs index 80c1fb3..88e3e28 100644 --- a/Language/Haskell/GhcMod/Monad/Orphans.hs +++ b/Language/Haskell/GhcMod/Monad/Orphans.hs @@ -14,7 +14,9 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, UndecidableInstances, StandaloneDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.Haskell.GhcMod.Monad.Orphans where @@ -23,6 +25,9 @@ module Language.Haskell.GhcMod.Monad.Orphans where import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Monad.Newtypes +#if DIFFERENT_MONADIO +import qualified MonadUtils as GHC (MonadIO(..)) +#endif import qualified Control.Monad.IO.Class as MTL import Control.Monad.Reader (ReaderT(..)) @@ -45,8 +50,17 @@ instance MTL.MonadIO m => GHC.MonadIO (JournalT x m) where liftIO = MTL.liftIO instance MTL.MonadIO m => GHC.MonadIO (MaybeT m) where liftIO = MTL.liftIO +deriving instance MTL.MonadIO m => GHC.MonadIO (GmOutT m) +deriving instance MTL.MonadIO m => GHC.MonadIO (GmT m) +deriving instance MTL.MonadIO m => GHC.MonadIO (GmlT m) +deriving instance GHC.MonadIO LightGhc #endif +deriving instance MTL.MonadIO m => MTL.MonadIO (GmOutT m) +deriving instance MTL.MonadIO m => MTL.MonadIO (GmT m) +deriving instance MTL.MonadIO m => MTL.MonadIO (GmlT m) +deriving instance MTL.MonadIO LightGhc + instance MonadIO IO where liftIO = id instance MonadIO m => MonadIO (ReaderT x m) where From ec5a362179b53c70b3a97599ea135bd08730b386 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 4 Jan 2016 05:27:31 +0100 Subject: [PATCH 09/15] Add AsyncSymbolDb to fix runGhcMod race condition for good --- Language/Haskell/GhcMod/Find.hs | 73 ++++++++++++++++++++++++++------- ghc-mod.cabal | 3 +- src/GHCMod.hs | 18 ++++---- src/Misc.hs | 48 ---------------------- 4 files changed, 66 insertions(+), 76 deletions(-) delete mode 100644 src/Misc.hs diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index 3962b01..5723a65 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse #-} +{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse, MultiWayIf #-} module Language.Haskell.GhcMod.Find #ifndef SPEC @@ -10,34 +10,42 @@ module Language.Haskell.GhcMod.Find , findSymbol , lookupSym , isOutdated + -- * Load 'SymbolDb' asynchronously + , AsyncSymbolDb + , newAsyncSymbolDb + , getAsyncSymbolDb ) #endif where -import Control.Applicative -import Control.Monad (when, void) -import Data.Function (on) -import Data.List (groupBy, sort) -import qualified GHC as G import Language.Haskell.GhcMod.Convert -import Language.Haskell.GhcMod.Gap (listVisibleModules) +import Language.Haskell.GhcMod.Gap import Language.Haskell.GhcMod.Monad +import Language.Haskell.GhcMod.Output import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils -import Language.Haskell.GhcMod.World (timedPackageCaches) -import Language.Haskell.GhcMod.Output -import Name (getOccString) -import Module (moduleName) -import System.Directory (doesFileExist) +import Language.Haskell.GhcMod.World + +import qualified GHC as G +import Name +import Module +import Exception + +import Control.Applicative +import Control.Monad +import Control.Monad.Trans.Control +import Control.Concurrent +import Data.Function +import Data.List +import Data.Map (Map) +import qualified Data.Map as M +import System.Directory import System.Directory.ModTime import System.FilePath (()) import System.IO import Prelude -import Data.Map (Map) -import qualified Data.Map as M - ---------------------------------------------------------------- -- | Type of function and operation names. @@ -147,3 +155,38 @@ collectModules :: [(Symbol, ModuleString)] collectModules = map tieup . groupBy ((==) `on` fst) . sort where tieup x = (head (map fst x), map snd x) + +---------------------------------------------------------------- + +data AsyncSymbolDb = AsyncSymbolDb FilePath (MVar (Either SomeException SymbolDb)) + +asyncLoadSymbolDb :: IOish m + => FilePath + -> MVar (Either SomeException SymbolDb) + -> GhcModT m () +asyncLoadSymbolDb tmpdir mv = void $ + liftBaseWith $ \run -> forkIO $ void $ run $ do + edb <- gtry $ loadSymbolDb tmpdir + liftIO $ putMVar mv edb + +newAsyncSymbolDb :: IOish m => FilePath -> GhcModT m AsyncSymbolDb +newAsyncSymbolDb tmpdir = do + mv <- liftIO newEmptyMVar + asyncLoadSymbolDb tmpdir mv + return $ AsyncSymbolDb tmpdir mv + +getAsyncSymbolDb :: forall m. IOish m => AsyncSymbolDb -> GhcModT m SymbolDb +getAsyncSymbolDb (AsyncSymbolDb tmpdir mv) = go 0 + where + go :: Integer -> GhcModT m SymbolDb + go i = do + edb <- liftIO $ takeMVar mv + case edb of + Left ex -> throw ex + Right db -> do + outdated <- isOutdated db + if | i > 2 -> error "getAsyncSymbolDb: outdated loop" + | outdated -> asyncLoadSymbolDb tmpdir mv >> go (i + 1) + | otherwise -> do + liftIO $ putMVar mv (Right db) + return db diff --git a/ghc-mod.cabal b/ghc-mod.cabal index dea4938..1b12725 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -206,7 +206,6 @@ Executable ghc-mod Default-Extensions: ConstraintKinds, FlexibleContexts HS-Source-Dirs: src Build-Depends: base < 5 && >= 4.0 - , async < 2.1 , directory < 1.3 , filepath < 1.5 , pretty < 1.2 @@ -214,6 +213,7 @@ Executable ghc-mod , split < 0.3 , mtl < 2.3 && >= 2.0 , ghc < 7.11 + , monad-control ==1.0.* , fclabels ==2.0.* , optparse-applicative >=0.11.0 && <0.13.0 , ghc-mod @@ -222,7 +222,6 @@ Executable ghc-modi Default-Language: Haskell2010 Main-Is: GHCModi.hs Other-Modules: Paths_ghc_mod - Misc Utils GHC-Options: -Wall -threaded -fno-warn-deprecations if os(windows) diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 09c5036..40340fc 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -11,6 +11,7 @@ import Language.Haskell.GhcMod import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO) import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Monad +import Language.Haskell.GhcMod.Find (AsyncSymbolDb, newAsyncSymbolDb, getAsyncSymbolDb) import System.FilePath (()) import System.Directory (setCurrentDirectory, getAppUserDataDirectory, removeDirectoryRecursive) @@ -20,8 +21,6 @@ import Text.PrettyPrint hiding ((<>)) import GHCMod.Options import Prelude -import Misc - ghcModStyle :: Style ghcModStyle = style { lineLength = 80, ribbonsPerLine = 1.2 } @@ -49,17 +48,14 @@ progMain (globalOptions, commands) = runGmOutT globalOptions $ -- ghc-modi legacyInteractive :: IOish m => GhcModT m () legacyInteractive = do - opt <- options prepareCabalHelper tmpdir <- cradleTempDir <$> cradle - gmo <- gmoAsk - symdbreq <- liftIO $ newSymDbReq opt gmo tmpdir + asyncSymbolDb <- newAsyncSymbolDb tmpdir world <- getCurrentWorld - legacyInteractiveLoop symdbreq world + legacyInteractiveLoop asyncSymbolDb world -legacyInteractiveLoop :: IOish m - => SymDbReq -> World -> GhcModT m () -legacyInteractiveLoop symdbreq world = do +legacyInteractiveLoop :: IOish m => AsyncSymbolDb -> World -> GhcModT m () +legacyInteractiveLoop asyncSymbolDb world = do liftIO . setCurrentDirectory =<< cradleRootDir <$> cradle -- blocking @@ -80,12 +76,12 @@ legacyInteractiveLoop symdbreq world = do $ parseArgsInteractive cmdArg case pargs of CmdFind symbol -> - lookupSymbol symbol =<< checkDb symdbreq =<< getDb symdbreq + lookupSymbol symbol =<< getAsyncSymbolDb asyncSymbolDb -- other commands are handled here x -> ghcCommands x gmPutStr res >> gmPutStrLn "OK" >> liftIO (hFlush stdout) - legacyInteractiveLoop symdbreq world' + legacyInteractiveLoop asyncSymbolDb world' where interactiveHandlers = [ GHandler $ \(e :: ExitCode) -> throw e diff --git a/src/Misc.hs b/src/Misc.hs deleted file mode 100644 index 98e8f39..0000000 --- a/src/Misc.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Misc ( - SymDbReq - , newSymDbReq - , getDb - , checkDb - ) where - -import Control.Concurrent.Async (Async, async, wait) -import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import Prelude - -import Language.Haskell.GhcMod -import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO) -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Monad - ----------------------------------------------------------------- - -type SymDbReqAction = (Either GhcModError SymbolDb, GhcModLog) -data SymDbReq = SymDbReq (IORef (Async SymDbReqAction)) (IO SymDbReqAction) - -newSymDbReq :: Options -> GhcModOut -> FilePath -> IO SymDbReq -newSymDbReq opt gmo tmpdir = do - let act = runGmOutT' gmo $ runGhcModT opt $ loadSymbolDb tmpdir - req <- async act - ref <- newIORef req - return $ SymDbReq ref act - -getDb :: IOish m => SymDbReq -> GhcModT m SymbolDb -getDb (SymDbReq ref _) = do - req <- liftIO $ readIORef ref - -- 'wait' really waits for the asynchronous action at the fist time. - -- Then it reads a cached value from the second time. - hoistGhcModT =<< liftIO (wait req) - -checkDb :: IOish m => SymDbReq -> SymbolDb -> GhcModT m SymbolDb -checkDb (SymDbReq ref act) db = do - outdated <- isOutdated db - if outdated then do - -- async and wait here is unnecessary because this is essentially - -- synchronous. But Async can be used a cache. - req <- liftIO $ async act - liftIO $ writeIORef ref req - hoistGhcModT =<< liftIO (wait req) - else - return db From 254f6a9a733736781dd7f292043f05b6957deb81 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 4 Jan 2016 06:02:30 +0100 Subject: [PATCH 10/15] Get rid of landmine --- Language/Haskell/GhcMod/Find.hs | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index 5723a65..382bb08 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse, MultiWayIf #-} +{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse #-} module Language.Haskell.GhcMod.Find #ifndef SPEC @@ -176,17 +176,18 @@ newAsyncSymbolDb tmpdir = do return $ AsyncSymbolDb tmpdir mv getAsyncSymbolDb :: forall m. IOish m => AsyncSymbolDb -> GhcModT m SymbolDb -getAsyncSymbolDb (AsyncSymbolDb tmpdir mv) = go 0 +getAsyncSymbolDb (AsyncSymbolDb tmpdir mv) = do + db <- liftIO $ handleEx <$> takeMVar mv + outdated <- isOutdated db + if outdated + then do + asyncLoadSymbolDb tmpdir mv + liftIO $ handleEx <$> readMVar mv + else do + liftIO $ putMVar mv $ Right db + return db where - go :: Integer -> GhcModT m SymbolDb - go i = do - edb <- liftIO $ takeMVar mv + handleEx edb = case edb of Left ex -> throw ex - Right db -> do - outdated <- isOutdated db - if | i > 2 -> error "getAsyncSymbolDb: outdated loop" - | outdated -> asyncLoadSymbolDb tmpdir mv >> go (i + 1) - | otherwise -> do - liftIO $ putMVar mv (Right db) - return db + Right db -> db From 7bbaa35f5665b2be4964c83cf292043bc09bed54 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 4 Jan 2016 19:05:15 +0100 Subject: [PATCH 11/15] Reinstate cwd setup, this time with locking --- Language/Haskell/GhcMod/Monad.hs | 32 +++++++++++++++++++++----------- ghc-mod.cabal | 2 +- test/MonadSpec.hs | 20 ++++++++++++++++++++ test/TestUtils.hs | 15 +-------------- 4 files changed, 43 insertions(+), 26 deletions(-) diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs index 2e0fe05..431b9b8 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ b/Language/Haskell/GhcMod/Monad.hs @@ -50,6 +50,7 @@ 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 @@ -57,24 +58,33 @@ withGhcModEnv = withGhcModEnv' withCradle where withCradle dir = gbracket (runJournalT $ findCradle' 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 - withCradleRootDir (cradleRootDir -> projdir) a = do - cdir <- liftIO $ getCurrentDirectory - eq <- liftIO $ pathsEqual projdir cdir - if not eq - then throw $ GMEWrongWorkingDirectory projdir cdir - else a + swapCurrentDirectory ndir = do + odir <- canonicalizePath =<< getCurrentDirectory + setCurrentDirectory ndir + return odir - pathsEqual a b = do - ca <- canonicalizePath a - cb <- canonicalizePath b - return $ ca == cb + 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 diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 1b12725..c35b952 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -256,7 +256,7 @@ Test-Suite spec DataKinds, KindSignatures, TypeOperators, ViewPatterns Main-Is: Main.hs Hs-Source-Dirs: test, ., src - Ghc-Options: -Wall -fno-warn-deprecations + Ghc-Options: -Wall -fno-warn-deprecations -threaded CPP-Options: -DSPEC=1 Type: exitcode-stdio-1.0 Other-Modules: Paths_ghc_mod diff --git a/test/MonadSpec.hs b/test/MonadSpec.hs index 5e60f55..171dd7d 100644 --- a/test/MonadSpec.hs +++ b/test/MonadSpec.hs @@ -3,6 +3,8 @@ module MonadSpec where import Test.Hspec import TestUtils import Control.Monad.Error.Class +import Control.Concurrent +import Control.Exception spec :: Spec spec = do @@ -15,3 +17,21 @@ spec = do return "hello" `catchError` (const $ fail "oh noes") a `shouldBe` (Left $ GMEString "oh noes") + + describe "runGhcModT" $ + it "throws an exception when run in multiple threads" $ do + mv1 :: MVar (Either SomeException ()) + <- newEmptyMVar + mv2 :: MVar (Either SomeException ()) + <- newEmptyMVar + + _ <- forkOS $ putMVar mv1 =<< (try $ evaluate =<< (runD $ liftIO $ readMVar mv2 >> return ())) + _ <- forkOS $ putMVar mv2 =<< (try $ evaluate =<< (runD $ return ())) + e1 <- takeMVar mv1 + e2 <- takeMVar mv2 + + (isLeft e1 || isLeft e2) `shouldBe` True + +isLeft :: Either a b -> Bool +isLeft (Right _) = False +isLeft (Left _) = True diff --git a/test/TestUtils.hs b/test/TestUtils.hs index 9251b9b..9ce67b5 100644 --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -45,20 +45,7 @@ extract action = do withSpecCradle :: (IOish m, GmOut m) => FilePath -> ((Cradle, GhcModLog) -> m a) -> m a withSpecCradle cradledir f = do - gbracket (runJournalT $ findSpecCradle cradledir) (liftIO . cleanupCradle . fst) $ \arg@(crdl,_) -> - bracketWorkingDirectory (cradleRootDir crdl) $ - f arg - -bracketWorkingDirectory :: - (ExceptionMonad m, MonadIO m) => FilePath -> m c -> m c -bracketWorkingDirectory dir a = - gbracket (swapWorkingDirectory dir) (liftIO . setCurrentDirectory) (const a) - -swapWorkingDirectory :: MonadIO m => FilePath -> m FilePath -swapWorkingDirectory ndir = liftIO $ do - odir <- getCurrentDirectory >>= canonicalizePath - setCurrentDirectory $ ndir - return odir + gbracket (runJournalT $ findSpecCradle cradledir) (liftIO . cleanupCradle . fst) f runGhcModTSpec :: Options -> GhcModT IO a -> IO (Either GhcModError a, GhcModLog) runGhcModTSpec opt action = do From ab1fa9cc138535b8193eef487ad3dc46fc806f4a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 4 Jan 2016 20:36:27 +0100 Subject: [PATCH 12/15] Bump version to 5.5.0.0 --- elisp/ghc.el | 2 +- ghc-mod.cabal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/elisp/ghc.el b/elisp/ghc.el index 82c4fe5..ec14a81 100644 --- a/elisp/ghc.el +++ b/elisp/ghc.el @@ -28,7 +28,7 @@ (< emacs-minor-version minor))) (error "ghc-mod requires at least Emacs %d.%d" major minor))) -(defconst ghc-version "5.4.0.0") +(defconst ghc-version "5.5.0.0") (defgroup ghc-mod '() "ghc-mod customization") diff --git a/ghc-mod.cabal b/ghc-mod.cabal index c35b952..0f81b22 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -1,5 +1,5 @@ Name: ghc-mod -Version: 5.4.0.0 +Version: 5.5.0.0 Author: Kazu Yamamoto , Daniel Gröber , Alejandro Serrano From d3c159821a6d415eac206505292d636b8eaf261e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 4 Jan 2016 21:43:20 +0100 Subject: [PATCH 13/15] Update cabal file Authors field Welcome to the club @lierdakil :) --- ghc-mod.cabal | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 0f81b22..fec548d 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -2,7 +2,8 @@ Name: ghc-mod Version: 5.5.0.0 Author: Kazu Yamamoto , Daniel Gröber , - Alejandro Serrano + Alejandro Serrano , + Nikolay Yakimov Maintainer: Daniel Gröber License: AGPL-3 License-File: LICENSE From 73863e0b000543c946facb1b2017d636192fc791 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 4 Jan 2016 21:44:49 +0100 Subject: [PATCH 14/15] Remove GMEWrongWorkingDirectory constructor --- Language/Haskell/GhcMod/Error.hs | 5 ----- Language/Haskell/GhcMod/Types.hs | 2 -- 2 files changed, 7 deletions(-) diff --git a/Language/Haskell/GhcMod/Error.hs b/Language/Haskell/GhcMod/Error.hs index e69cc34..4ec373c 100644 --- a/Language/Haskell/GhcMod/Error.hs +++ b/Language/Haskell/GhcMod/Error.hs @@ -104,11 +104,6 @@ gmeDoc e = case e of GMETooManyCabalFiles cfs -> text $ "Multiple cabal files found. Possible cabal files: \"" ++ intercalate "\", \"" cfs ++"\"." - GMEWrongWorkingDirectory projdir cdir -> - (text $ "You must run ghc-mod in the project directory as returned by `ghc-mod root`.") - <+> text "Currently in:" <+> showDoc cdir - <> text "but should be in" <+> showDoc projdir - <> text "." ghcExceptionDoc :: GhcException -> Doc ghcExceptionDoc e@(CmdLineError _) = diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 40a8a83..51d4c3c 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -347,8 +347,6 @@ data GhcModError | GMETooManyCabalFiles [FilePath] -- ^ Too many cabal files found. - | GMEWrongWorkingDirectory FilePath FilePath - deriving (Eq,Show,Typeable) instance Error GhcModError where From 306cb939a9355bc5913fea54c9409e3f068d8ecd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Mon, 4 Jan 2016 23:58:44 +0100 Subject: [PATCH 15/15] Update stack.yaml --- stack.yaml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/stack.yaml b/stack.yaml index 6d9769e..fdcb756 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,5 +2,5 @@ flags: {} packages: - '.' extra-deps: -- cabal-helper-0.6.1.0 -resolver: lts-3.1 +- cabal-helper-0.6.2.0 +resolver: lts-3.20