From 9b88b71f4d022e6b4f7cf7a7e1cff98de1e1aa0b Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Tue, 26 Jan 2016 23:48:33 +0300 Subject: [PATCH 01/24] Fix sig command Fixes #704 --- Language/Haskell/GhcMod/Target.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 7985d1a..7d232c6 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -451,7 +451,9 @@ loadTargets opts targetStrs = do case target' of HscNothing -> do void $ load LoadAllTargets - mapM_ (parseModule >=> typecheckModule >=> desugarModule) mg + forM_ mg $ + handleSourceError (gmLog GmWarning "loadTargets" . text . show) + . void . (parseModule >=> typecheckModule >=> desugarModule) HscInterpreted -> do void $ load LoadAllTargets _ -> error ("loadTargets: unsupported hscTarget") From 1559a91a84de87be893239f18df6746bdad60dd1 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Sun, 10 Jan 2016 01:19:15 +0300 Subject: [PATCH 02/24] Cache non-interactive find results in distdir --- Language/Haskell/GhcMod/Find.hs | 20 ++++++++++++++++++-- Language/Haskell/GhcMod/PathsAndFiles.hs | 2 +- 2 files changed, 19 insertions(+), 3 deletions(-) diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index 5f00138..bd51749 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -56,7 +56,8 @@ import Data.Map (Map) import qualified Data.Map as M import Data.Set (Set) import qualified Data.Set as S - +import Language.Haskell.GhcMod.PathsAndFiles +import System.Directory import Prelude ---------------------------------------------------------------- @@ -83,7 +84,7 @@ isOutdated db = -- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\] -- which will be concatenated. 'loadSymbolDb' is called internally. findSymbol :: IOish m => String -> GhcModT m String -findSymbol sym = loadSymbolDb >>= lookupSymbol sym +findSymbol sym = loadSymbolDb' >>= lookupSymbol sym -- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\] -- which will be concatenated. @@ -95,6 +96,21 @@ lookupSym sym db = map (ModuleString . unpackFS . mkFastStringByteString') $ S.t --------------------------------------------------------------- +loadSymbolDb' :: IOish m => GhcModT m SymbolDb +loadSymbolDb' = do + cache <- symbolCache <$> cradle + let doLoad True = do + db <- decode <$> liftIO (LBS.readFile cache) + outdated <- isOutdated db + if outdated + then doLoad False + else return db + doLoad False = do + db <- loadSymbolDb + liftIO $ LBS.writeFile cache $ encode db + return db + doLoad =<< liftIO (doesFileExist cache) + -- | Loading a file and creates 'SymbolDb'. loadSymbolDb :: IOish m => GhcModT m SymbolDb loadSymbolDb = do diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs index 43ed020..6c0a68e 100644 --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ b/Language/Haskell/GhcMod/PathsAndFiles.hs @@ -220,7 +220,7 @@ packageCache = "package.cache" -- | Filename of the symbol table cache file. symbolCache :: Cradle -> FilePath -symbolCache crdl = cradleTempDir crdl symbolCacheFile +symbolCache crdl = cradleRootDir crdl cradleDistDir crdl symbolCacheFile symbolCacheFile :: String symbolCacheFile = "ghc-mod.symbol-cache" From 2f1e586fea9d08bdc9569dda813b296a33a849ba Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Sun, 10 Jan 2016 01:20:26 +0300 Subject: [PATCH 03/24] Remove worldSymbolCache from World --- Language/Haskell/GhcMod/World.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/Language/Haskell/GhcMod/World.hs b/Language/Haskell/GhcMod/World.hs index 89596b8..74ed5a2 100644 --- a/Language/Haskell/GhcMod/World.hs +++ b/Language/Haskell/GhcMod/World.hs @@ -19,7 +19,6 @@ data World = World { , worldCabalFile :: Maybe TimedFile , worldCabalConfig :: Maybe TimedFile , worldCabalSandboxConfig :: Maybe TimedFile - , worldSymbolCache :: Maybe TimedFile } deriving (Eq) timedPackageCaches :: IOish m => GhcModT m [TimedFile] @@ -35,14 +34,12 @@ getCurrentWorld = do mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl) mCabalSandboxConfig <- liftIO $ timeMaybe (sandboxConfigFile crdl) - mSymbolCache <- liftIO $ timeMaybe (symbolCache crdl) return World { worldPackageCaches = pkgCaches , worldCabalFile = mCabalFile , worldCabalConfig = mCabalConfig , worldCabalSandboxConfig = mCabalSandboxConfig - , worldSymbolCache = mSymbolCache } didWorldChange :: IOish m => World -> GhcModT m Bool From 1cc97db24f8cbeb24891d90669cb8313ace4360d Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Mon, 8 Feb 2016 22:34:20 +0200 Subject: [PATCH 04/24] Move the CLI parser definitions into the lib So they can be used by library clients to parse and pass in the appropriate ghc-mod Options. --- .../Haskell/GhcMod}/Options/Commands.hs | 6 +++--- .../Haskell/GhcMod}/Options/DocUtils.hs | 2 +- .../Haskell/GhcMod}/Options/Help.hs | 2 +- .../Haskell/GhcMod/Options}/Options.hs | 12 ++++++------ .../Haskell/GhcMod}/Options/ShellParse.hs | 2 +- .../Haskell/GhcMod/Options}/Version.hs | 2 +- ghc-mod.cabal | 15 ++++++++------- src/GHCMod.hs | 2 +- 8 files changed, 22 insertions(+), 21 deletions(-) rename {src/GHCMod => Language/Haskell/GhcMod}/Options/Commands.hs (98%) rename {src/GHCMod => Language/Haskell/GhcMod}/Options/DocUtils.hs (96%) rename {src/GHCMod => Language/Haskell/GhcMod}/Options/Help.hs (97%) rename {src/GHCMod => Language/Haskell/GhcMod/Options}/Options.hs (95%) rename {src/GHCMod => Language/Haskell/GhcMod}/Options/ShellParse.hs (95%) rename {src/GHCMod => Language/Haskell/GhcMod/Options}/Version.hs (95%) diff --git a/src/GHCMod/Options/Commands.hs b/Language/Haskell/GhcMod/Options/Commands.hs similarity index 98% rename from src/GHCMod/Options/Commands.hs rename to Language/Haskell/GhcMod/Options/Commands.hs index 2e1f60a..b39663a 100644 --- a/src/GHCMod/Options/Commands.hs +++ b/Language/Haskell/GhcMod/Options/Commands.hs @@ -16,15 +16,15 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -module GHCMod.Options.Commands where +module Language.Haskell.GhcMod.Options.Commands where import Options.Applicative import Options.Applicative.Types import Options.Applicative.Builder.Internal import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Read -import GHCMod.Options.DocUtils -import GHCMod.Options.Help +import Language.Haskell.GhcMod.Options.DocUtils +import Language.Haskell.GhcMod.Options.Help type Symbol = String type Expr = String diff --git a/src/GHCMod/Options/DocUtils.hs b/Language/Haskell/GhcMod/Options/DocUtils.hs similarity index 96% rename from src/GHCMod/Options/DocUtils.hs rename to Language/Haskell/GhcMod/Options/DocUtils.hs index 95fad26..c81dec8 100644 --- a/src/GHCMod/Options/DocUtils.hs +++ b/Language/Haskell/GhcMod/Options/DocUtils.hs @@ -14,7 +14,7 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -module GHCMod.Options.DocUtils ( +module Language.Haskell.GhcMod.Options.DocUtils ( ($$), ($$$), (<=>), diff --git a/src/GHCMod/Options/Help.hs b/Language/Haskell/GhcMod/Options/Help.hs similarity index 97% rename from src/GHCMod/Options/Help.hs rename to Language/Haskell/GhcMod/Options/Help.hs index 9e33194..d43b6fb 100644 --- a/src/GHCMod/Options/Help.hs +++ b/Language/Haskell/GhcMod/Options/Help.hs @@ -15,7 +15,7 @@ -- along with this program. If not, see . {-# LANGUAGE OverloadedStrings, FlexibleInstances, GeneralizedNewtypeDeriving #-} -module GHCMod.Options.Help where +module Language.Haskell.GhcMod.Options.Help where import Options.Applicative import Options.Applicative.Help.Pretty (Doc) diff --git a/src/GHCMod/Options.hs b/Language/Haskell/GhcMod/Options/Options.hs similarity index 95% rename from src/GHCMod/Options.hs rename to Language/Haskell/GhcMod/Options/Options.hs index 0a2a73e..6f95e02 100644 --- a/src/GHCMod/Options.hs +++ b/Language/Haskell/GhcMod/Options/Options.hs @@ -16,7 +16,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -module GHCMod.Options ( +module Language.Haskell.GhcMod.Options.Options ( parseArgs, parseArgsInteractive, GhcModCommands(..) @@ -29,11 +29,11 @@ import Control.Arrow import Data.Char (toUpper, toLower) import Data.List (intercalate) import Language.Haskell.GhcMod.Read -import GHCMod.Options.Commands -import GHCMod.Version -import GHCMod.Options.DocUtils -import GHCMod.Options.Help -import GHCMod.Options.ShellParse +import Language.Haskell.GhcMod.Options.Commands +import Language.Haskell.GhcMod.Options.Version +import Language.Haskell.GhcMod.Options.DocUtils +import Language.Haskell.GhcMod.Options.Help +import Language.Haskell.GhcMod.Options.ShellParse parseArgs :: IO (Options, GhcModCommands) parseArgs = diff --git a/src/GHCMod/Options/ShellParse.hs b/Language/Haskell/GhcMod/Options/ShellParse.hs similarity index 95% rename from src/GHCMod/Options/ShellParse.hs rename to Language/Haskell/GhcMod/Options/ShellParse.hs index acd609b..a807932 100644 --- a/src/GHCMod/Options/ShellParse.hs +++ b/Language/Haskell/GhcMod/Options/ShellParse.hs @@ -13,7 +13,7 @@ -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -module GHCMod.Options.ShellParse (parseCmdLine) where +module Language.Haskell.GhcMod.Options.ShellParse (parseCmdLine) where import Data.Char import Data.List diff --git a/src/GHCMod/Version.hs b/Language/Haskell/GhcMod/Options/Version.hs similarity index 95% rename from src/GHCMod/Version.hs rename to Language/Haskell/GhcMod/Options/Version.hs index 2bf6db2..72d7371 100644 --- a/src/GHCMod/Version.hs +++ b/Language/Haskell/GhcMod/Options/Version.hs @@ -14,7 +14,7 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -module GHCMod.Version where +module Language.Haskell.GhcMod.Options.Version where import Paths_ghc_mod import Data.Version (showVersion) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 01358b5..def5ce7 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -152,6 +152,13 @@ Library Language.Haskell.GhcMod.Types Language.Haskell.GhcMod.Utils Language.Haskell.GhcMod.World + + Language.Haskell.GhcMod.Options.Options + Language.Haskell.GhcMod.Options.Commands + Language.Haskell.GhcMod.Options.Version + Language.Haskell.GhcMod.Options.DocUtils + Language.Haskell.GhcMod.Options.ShellParse + Language.Haskell.GhcMod.Options.Help Other-Modules: Paths_ghc_mod Utils Data.Binary.Generic @@ -187,6 +194,7 @@ Library , extra == 1.4.* , pipes == 4.1.* , safe < 0.4 && >= 0.3.9 + , optparse-applicative >=0.11.0 && <0.13.0 if impl(ghc < 7.8) Build-Depends: convertible if impl(ghc < 7.5) @@ -198,12 +206,6 @@ Executable ghc-mod Default-Language: Haskell2010 Main-Is: GHCMod.hs Other-Modules: Paths_ghc_mod - , GHCMod.Options - , GHCMod.Options.Commands - , GHCMod.Version - , GHCMod.Options.DocUtils - , GHCMod.Options.ShellParse - , GHCMod.Options.Help GHC-Options: -Wall -fno-warn-deprecations -threaded Default-Extensions: ConstraintKinds, FlexibleContexts HS-Source-Dirs: src @@ -217,7 +219,6 @@ Executable ghc-mod , ghc < 7.11 , monad-control ==1.0.* , fclabels ==2.0.* - , optparse-applicative >=0.11.0 && <0.13.0 , ghc-mod Executable ghc-modi diff --git a/src/GHCMod.hs b/src/GHCMod.hs index fdade72..23e40d4 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -19,7 +19,7 @@ import System.Directory (setCurrentDirectory, getAppUserDataDirectory, import System.IO import System.Exit import Text.PrettyPrint hiding ((<>)) -import GHCMod.Options +import Language.Haskell.GhcMod.Options.Options import Prelude ghcModStyle :: Style From b1d123c4b6df5c4edc3c012f968b7cf8204ae06c Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Mon, 8 Feb 2016 23:02:31 +0200 Subject: [PATCH 05/24] Fix tests, export parser spec --- Language/Haskell/GhcMod/Options/Options.hs | 3 ++- test/ShellParseSpec.hs | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/Language/Haskell/GhcMod/Options/Options.hs b/Language/Haskell/GhcMod/Options/Options.hs index 6f95e02..82bbda8 100644 --- a/Language/Haskell/GhcMod/Options/Options.hs +++ b/Language/Haskell/GhcMod/Options/Options.hs @@ -19,7 +19,8 @@ module Language.Haskell.GhcMod.Options.Options ( parseArgs, parseArgsInteractive, - GhcModCommands(..) + GhcModCommands(..), + globalArgSpec ) where import Options.Applicative diff --git a/test/ShellParseSpec.hs b/test/ShellParseSpec.hs index 2c5cefe..5111217 100644 --- a/test/ShellParseSpec.hs +++ b/test/ShellParseSpec.hs @@ -1,7 +1,7 @@ module ShellParseSpec where -import GHCMod.Options.ShellParse +import Language.Haskell.GhcMod.Options.ShellParse import Test.Hspec From 5f070b842862096b6172ae3382a5448e094985ad Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Tue, 9 Feb 2016 22:24:46 +0200 Subject: [PATCH 06/24] Rebalance between lib and exe --- Language/Haskell/GhcMod/Options/Options.hs | 45 ----------- ghc-mod.cabal | 7 +- src/GHCMod.hs | 1 + src/GHCMod/Options.hs | 77 +++++++++++++++++++ .../GhcMod => src/GHCMod}/Options/Commands.hs | 2 +- .../GHCMod}/Options/ShellParse.hs | 2 +- .../GhcMod/Options => src/GHCMod}/Version.hs | 2 +- test/ShellParseSpec.hs | 2 +- 8 files changed, 86 insertions(+), 52 deletions(-) create mode 100644 src/GHCMod/Options.hs rename {Language/Haskell/GhcMod => src/GHCMod}/Options/Commands.hs (99%) rename {Language/Haskell/GhcMod => src/GHCMod}/Options/ShellParse.hs (95%) rename {Language/Haskell/GhcMod/Options => src/GHCMod}/Version.hs (95%) diff --git a/Language/Haskell/GhcMod/Options/Options.hs b/Language/Haskell/GhcMod/Options/Options.hs index 72cbe69..b0349f0 100644 --- a/Language/Haskell/GhcMod/Options/Options.hs +++ b/Language/Haskell/GhcMod/Options/Options.hs @@ -17,9 +17,6 @@ {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} module Language.Haskell.GhcMod.Options.Options ( - parseArgs, - parseArgsInteractive, - GhcModCommands(..), globalArgSpec ) where @@ -30,50 +27,8 @@ import Control.Arrow import Data.Char (toUpper, toLower) import Data.List (intercalate) import Language.Haskell.GhcMod.Read -import Language.Haskell.GhcMod.Options.Commands -import Language.Haskell.GhcMod.Options.Version import Language.Haskell.GhcMod.Options.DocUtils import Language.Haskell.GhcMod.Options.Help -import Language.Haskell.GhcMod.Options.ShellParse - -parseArgs :: IO (Options, GhcModCommands) -parseArgs = - execParser opts - where - opts = info (argAndCmdSpec <**> helpVersion) - $$ fullDesc - <=> header "ghc-mod: Happy Haskell Programming" - -parseArgsInteractive :: String -> Either String GhcModCommands -parseArgsInteractive args = - handle $ execParserPure (prefs idm) opts $ parseCmdLine args - where - opts = info interactiveCommandsSpec $$ fullDesc - handle (Success a) = Right a - handle (Failure failure) = - Left $ fst $ renderFailure failure "" - handle _ = Left "Completion invoked" - -helpVersion :: Parser (a -> a) -helpVersion = - helper - <*> abortOption (InfoMsg ghcModVersion) - $$ long "version" - <=> help "Print the version of the program." - <*> argument r - $$ value id - <=> metavar "" - where - r :: ReadM (a -> a) - r = do - v <- readerAsk - case v of - "help" -> readerAbort ShowHelpText - "version" -> readerAbort $ InfoMsg ghcModVersion - _ -> return id - -argAndCmdSpec :: Parser (Options, GhcModCommands) -argAndCmdSpec = (,) <$> globalArgSpec <*> commandsSpec splitOn :: Eq a => a -> [a] -> ([a], [a]) splitOn c = second (drop 1) . break (==c) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index def5ce7..1e74c23 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -154,10 +154,7 @@ Library Language.Haskell.GhcMod.World Language.Haskell.GhcMod.Options.Options - Language.Haskell.GhcMod.Options.Commands - Language.Haskell.GhcMod.Options.Version Language.Haskell.GhcMod.Options.DocUtils - Language.Haskell.GhcMod.Options.ShellParse Language.Haskell.GhcMod.Options.Help Other-Modules: Paths_ghc_mod Utils @@ -206,6 +203,9 @@ Executable ghc-mod Default-Language: Haskell2010 Main-Is: GHCMod.hs Other-Modules: Paths_ghc_mod + , GHCMod.Options.Commands + , GHCMod.Options.ShellParse + , GHCMod.Version GHC-Options: -Wall -fno-warn-deprecations -threaded Default-Extensions: ConstraintKinds, FlexibleContexts HS-Source-Dirs: src @@ -219,6 +219,7 @@ Executable ghc-mod , ghc < 7.11 , monad-control ==1.0.* , fclabels ==2.0.* + , optparse-applicative >=0.11.0 && <0.13.0 , ghc-mod Executable ghc-modi diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 4a71f61..f67e9b9 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -20,6 +20,7 @@ import System.IO import System.Exit import Text.PrettyPrint hiding ((<>)) import Language.Haskell.GhcMod.Options.Options +import GHCMod.Options import Prelude ghcModStyle :: Style diff --git a/src/GHCMod/Options.hs b/src/GHCMod/Options.hs new file mode 100644 index 0000000..b7b13d0 --- /dev/null +++ b/src/GHCMod/Options.hs @@ -0,0 +1,77 @@ +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015 Nikolay Yakimov +-- +-- 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 OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} + +module GHCMod.Options ( + parseArgs, + parseArgsInteractive, + GhcModCommands(..), +) where + +import Options.Applicative +import Options.Applicative.Types +import Language.Haskell.GhcMod.Types +-- import Control.Arrow +-- import Data.Char (toUpper, toLower) +-- import Data.List (intercalate) +-- import Language.Haskell.GhcMod.Read +import GHCMod.Options.Commands +import GHCMod.Version +import Language.Haskell.GhcMod.Options.DocUtils +-- import Language.Haskell.GhcMod.Options.Help +import Language.Haskell.GhcMod.Options.Options +import GHCMod.Options.ShellParse + +parseArgs :: IO (Options, GhcModCommands) +parseArgs = + execParser opts + where + opts = info (argAndCmdSpec <**> helpVersion) + $$ fullDesc + <=> header "ghc-mod: Happy Haskell Programming" + +parseArgsInteractive :: String -> Either String GhcModCommands +parseArgsInteractive args = + handle $ execParserPure (prefs idm) opts $ parseCmdLine args + where + opts = info interactiveCommandsSpec $$ fullDesc + handle (Success a) = Right a + handle (Failure failure) = + Left $ fst $ renderFailure failure "" + handle _ = Left "Completion invoked" + +helpVersion :: Parser (a -> a) +helpVersion = + helper + <*> abortOption (InfoMsg ghcModVersion) + $$ long "version" + <=> help "Print the version of the program." + <*> argument r + $$ value id + <=> metavar "" + where + r :: ReadM (a -> a) + r = do + v <- readerAsk + case v of + "help" -> readerAbort ShowHelpText + "version" -> readerAbort $ InfoMsg ghcModVersion + _ -> return id + +argAndCmdSpec :: Parser (Options, GhcModCommands) +argAndCmdSpec = (,) <$> globalArgSpec <*> commandsSpec + diff --git a/Language/Haskell/GhcMod/Options/Commands.hs b/src/GHCMod/Options/Commands.hs similarity index 99% rename from Language/Haskell/GhcMod/Options/Commands.hs rename to src/GHCMod/Options/Commands.hs index b39663a..a2ab3c0 100644 --- a/Language/Haskell/GhcMod/Options/Commands.hs +++ b/src/GHCMod/Options/Commands.hs @@ -16,7 +16,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -module Language.Haskell.GhcMod.Options.Commands where +module GHCMod.Options.Commands where import Options.Applicative import Options.Applicative.Types diff --git a/Language/Haskell/GhcMod/Options/ShellParse.hs b/src/GHCMod/Options/ShellParse.hs similarity index 95% rename from Language/Haskell/GhcMod/Options/ShellParse.hs rename to src/GHCMod/Options/ShellParse.hs index a807932..acd609b 100644 --- a/Language/Haskell/GhcMod/Options/ShellParse.hs +++ b/src/GHCMod/Options/ShellParse.hs @@ -13,7 +13,7 @@ -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -module Language.Haskell.GhcMod.Options.ShellParse (parseCmdLine) where +module GHCMod.Options.ShellParse (parseCmdLine) where import Data.Char import Data.List diff --git a/Language/Haskell/GhcMod/Options/Version.hs b/src/GHCMod/Version.hs similarity index 95% rename from Language/Haskell/GhcMod/Options/Version.hs rename to src/GHCMod/Version.hs index 72d7371..2bf6db2 100644 --- a/Language/Haskell/GhcMod/Options/Version.hs +++ b/src/GHCMod/Version.hs @@ -14,7 +14,7 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -module Language.Haskell.GhcMod.Options.Version where +module GHCMod.Version where import Paths_ghc_mod import Data.Version (showVersion) diff --git a/test/ShellParseSpec.hs b/test/ShellParseSpec.hs index 5111217..2c5cefe 100644 --- a/test/ShellParseSpec.hs +++ b/test/ShellParseSpec.hs @@ -1,7 +1,7 @@ module ShellParseSpec where -import Language.Haskell.GhcMod.Options.ShellParse +import GHCMod.Options.ShellParse import Test.Hspec From b02dfb9ce3043e216c4ae75e778b8574c11d34d5 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Tue, 9 Feb 2016 22:34:25 +0200 Subject: [PATCH 07/24] Cleaning up --- ghc-mod.cabal | 3 ++- src/GHCMod.hs | 1 - src/GHCMod/Options.hs | 7 +------ 3 files changed, 3 insertions(+), 8 deletions(-) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 1e74c23..deb1a38 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -203,9 +203,10 @@ Executable ghc-mod Default-Language: Haskell2010 Main-Is: GHCMod.hs Other-Modules: Paths_ghc_mod + , GHCMod.Options , GHCMod.Options.Commands - , GHCMod.Options.ShellParse , GHCMod.Version + , GHCMod.Options.ShellParse GHC-Options: -Wall -fno-warn-deprecations -threaded Default-Extensions: ConstraintKinds, FlexibleContexts HS-Source-Dirs: src diff --git a/src/GHCMod.hs b/src/GHCMod.hs index f67e9b9..531f7de 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -19,7 +19,6 @@ import System.Directory (setCurrentDirectory, getAppUserDataDirectory, import System.IO import System.Exit import Text.PrettyPrint hiding ((<>)) -import Language.Haskell.GhcMod.Options.Options import GHCMod.Options import Prelude diff --git a/src/GHCMod/Options.hs b/src/GHCMod/Options.hs index b7b13d0..c3cf263 100644 --- a/src/GHCMod/Options.hs +++ b/src/GHCMod/Options.hs @@ -19,20 +19,15 @@ module GHCMod.Options ( parseArgs, parseArgsInteractive, - GhcModCommands(..), + GhcModCommands(..) ) where import Options.Applicative import Options.Applicative.Types import Language.Haskell.GhcMod.Types --- import Control.Arrow --- import Data.Char (toUpper, toLower) --- import Data.List (intercalate) --- import Language.Haskell.GhcMod.Read import GHCMod.Options.Commands import GHCMod.Version import Language.Haskell.GhcMod.Options.DocUtils --- import Language.Haskell.GhcMod.Options.Help import Language.Haskell.GhcMod.Options.Options import GHCMod.Options.ShellParse From 85df08a91312098173c3450ee0250ab88beb39d3 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Mon, 15 Feb 2016 22:04:47 +0200 Subject: [PATCH 08/24] Add a argument parser and some haddocks I am not sure if I have set the ParserInfo up correctly, I have never used it before. --- Language/Haskell/GhcMod/Options/Options.hs | 23 +++++++++++++++++++++- 1 file changed, 22 insertions(+), 1 deletion(-) diff --git a/Language/Haskell/GhcMod/Options/Options.hs b/Language/Haskell/GhcMod/Options/Options.hs index b0349f0..8d10d9d 100644 --- a/Language/Haskell/GhcMod/Options/Options.hs +++ b/Language/Haskell/GhcMod/Options/Options.hs @@ -17,10 +17,12 @@ {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} module Language.Haskell.GhcMod.Options.Options ( - globalArgSpec + globalArgSpec + , parseCmdLineOptions ) where import Options.Applicative +import Options.Applicative.Help.Chunk import Options.Applicative.Types import Language.Haskell.GhcMod.Types import Control.Arrow @@ -30,6 +32,22 @@ import Language.Haskell.GhcMod.Read import Language.Haskell.GhcMod.Options.DocUtils import Language.Haskell.GhcMod.Options.Help +-- | Parse a set of arguments according to the ghc-mod CLI flag spec, producing +-- @Options@ set accordingly. +parseCmdLineOptions :: [String] -> Maybe Options +parseCmdLineOptions args = execParserMaybe parserInfo args + where + parserInfo + = ParserInfo + { infoParser = globalArgSpec + , infoFullDesc = True + , infoProgDesc = Chunk Nothing + , infoHeader = Chunk Nothing + , infoFooter = Chunk Nothing + , infoFailureCode = -1 + , infoIntersperse = True + } + splitOn :: Eq a => a -> [a] -> ([a], [a]) splitOn c = second (drop 1) . break (==c) @@ -119,6 +137,9 @@ programsArgSpec = Programs <=> showDefault <=> help "stack executable to use" +-- | An optparse-applicative @Parser@ sepcification for @Options@ so that +-- applications making use of the ghc-mod API can have a consistent way of +-- parsing global options. globalArgSpec :: Parser Options globalArgSpec = Options <$> outputOptsSpec From 4874bc914b53c8ce9d18ae62797cd9c2a59210aa Mon Sep 17 00:00:00 2001 From: Moritz Kiefer Date: Tue, 16 Feb 2016 21:44:10 +0100 Subject: [PATCH 09/24] Add Ord instances for Cradle --- Language/Haskell/GhcMod/Types.hs | 6 +++--- stack.yaml | 5 ++--- 2 files changed, 5 insertions(+), 6 deletions(-) diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 42dac13..2281ba9 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -134,7 +134,7 @@ data Project = CabalProject | SandboxProject | PlainProject | StackProject StackEnv - deriving (Eq, Show) + deriving (Eq, Show, Ord) isCabalHelperProject :: Project -> Bool isCabalHelperProject StackProject {} = True @@ -146,7 +146,7 @@ data StackEnv = StackEnv { , seBinPath :: [FilePath] , seSnapshotPkgDb :: FilePath , seLocalPkgDb :: FilePath - } deriving (Eq, Show) + } deriving (Eq, Show, Ord) -- | The environment where this library is used. data Cradle = Cradle { @@ -161,7 +161,7 @@ data Cradle = Cradle { , cradleCabalFile :: Maybe FilePath -- | The build info directory. , cradleDistDir :: FilePath - } deriving (Eq, Show) + } deriving (Eq, Show, Ord) data GmStream = GmOutStream | GmErrStream deriving (Show) diff --git a/stack.yaml b/stack.yaml index fdcb756..1e26270 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,6 +1,5 @@ flags: {} packages: - '.' -extra-deps: -- cabal-helper-0.6.2.0 -resolver: lts-3.20 +extra-deps: [] +resolver: lts-5.3 From 45eb3b8d4c0dd4857e9b7c6c9044a4d2c95db586 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Mon, 29 Feb 2016 20:45:32 +0200 Subject: [PATCH 10/24] Do not use deprecated API for parseCmdLineOptions Thanks to @lierdakil --- Language/Haskell/GhcMod/Options/Options.hs | 13 +------------ 1 file changed, 1 insertion(+), 12 deletions(-) diff --git a/Language/Haskell/GhcMod/Options/Options.hs b/Language/Haskell/GhcMod/Options/Options.hs index 8d10d9d..c49d6f7 100644 --- a/Language/Haskell/GhcMod/Options/Options.hs +++ b/Language/Haskell/GhcMod/Options/Options.hs @@ -35,18 +35,7 @@ import Language.Haskell.GhcMod.Options.Help -- | Parse a set of arguments according to the ghc-mod CLI flag spec, producing -- @Options@ set accordingly. parseCmdLineOptions :: [String] -> Maybe Options -parseCmdLineOptions args = execParserMaybe parserInfo args - where - parserInfo - = ParserInfo - { infoParser = globalArgSpec - , infoFullDesc = True - , infoProgDesc = Chunk Nothing - , infoHeader = Chunk Nothing - , infoFooter = Chunk Nothing - , infoFailureCode = -1 - , infoIntersperse = True - } +parseCmdLineOptions = getParseResult . execParserPure (prefs mempty) (info globalArgSpec mempty) splitOn :: Eq a => a -> [a] -> ([a], [a]) splitOn c = second (drop 1) . break (==c) From 04b75e2bdef561ab53b1068673ff66f8c2fb6084 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Mon, 29 Feb 2016 21:24:30 +0200 Subject: [PATCH 11/24] Sort out imports for earlier GHC versions --- Language/Haskell/GhcMod/Options/Options.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/Language/Haskell/GhcMod/Options/Options.hs b/Language/Haskell/GhcMod/Options/Options.hs index c49d6f7..8b13091 100644 --- a/Language/Haskell/GhcMod/Options/Options.hs +++ b/Language/Haskell/GhcMod/Options/Options.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} -- ghc-mod: Making Haskell development *more* fun -- Copyright (C) 2015 Nikolay Yakimov -- @@ -22,12 +23,14 @@ module Language.Haskell.GhcMod.Options.Options ( ) where import Options.Applicative -import Options.Applicative.Help.Chunk import Options.Applicative.Types import Language.Haskell.GhcMod.Types import Control.Arrow import Data.Char (toUpper, toLower) import Data.List (intercalate) +#if __GLASGOW_HASKELL__ < 710 +import Data.Monoid (mempty) +#endif import Language.Haskell.GhcMod.Read import Language.Haskell.GhcMod.Options.DocUtils import Language.Haskell.GhcMod.Options.Help From f992200d57fc93355d5e5c754ce7b65ee701cfc3 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Tue, 1 Mar 2016 22:58:10 +0200 Subject: [PATCH 12/24] Remove CPP from Options As per @lierdakil suggestion --- Language/Haskell/GhcMod/Options/Options.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/Language/Haskell/GhcMod/Options/Options.hs b/Language/Haskell/GhcMod/Options/Options.hs index 8b13091..7d4aa3a 100644 --- a/Language/Haskell/GhcMod/Options/Options.hs +++ b/Language/Haskell/GhcMod/Options/Options.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} -- ghc-mod: Making Haskell development *more* fun -- Copyright (C) 2015 Nikolay Yakimov -- @@ -28,12 +27,11 @@ import Language.Haskell.GhcMod.Types import Control.Arrow import Data.Char (toUpper, toLower) import Data.List (intercalate) -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid (mempty) -#endif import Language.Haskell.GhcMod.Read import Language.Haskell.GhcMod.Options.DocUtils import Language.Haskell.GhcMod.Options.Help +import Data.Monoid +import Prelude -- | Parse a set of arguments according to the ghc-mod CLI flag spec, producing -- @Options@ set accordingly. From 5e2f79b7c89b1e1d5f54be7407c52a09d243c75f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 2 Mar 2016 00:38:40 +0100 Subject: [PATCH 13/24] Bump lower bound on hlint The Error -> Warning changes in older versions of hlint break the tests otherwise --- ghc-mod.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index c7b1f9f..f583ca5 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -172,7 +172,7 @@ Library , ghc < 8.2 && >= 7.6 , ghc-paths < 0.2 , ghc-syb-utils < 0.3 - , hlint < 1.10 && >= 1.9.26 + , hlint < 1.10 && >= 1.9.27 , monad-journal < 0.8 && >= 0.4 , old-time < 1.2 , pretty < 1.2 From 2f82d5cdf433754f06fb36f7a8e5bac8b674d574 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Thu, 3 Mar 2016 23:01:20 +0300 Subject: [PATCH 14/24] Change loadTargets stderr loglevel to Debug Closes #763 --- Language/Haskell/GhcMod/Target.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 536842b..67fa140 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -464,7 +464,7 @@ loadTargets opts targetStrs = do HscNothing -> do void $ load LoadAllTargets forM_ mg $ - handleSourceError (gmLog GmWarning "loadTargets" . text . show) + handleSourceError (gmLog GmDebug "loadTargets" . text . show) . void . (parseModule >=> typecheckModule >=> desugarModule) HscInterpreted -> do void $ load LoadAllTargets From 5d9e8ea12bb06958fde499c70b44bef169f94df4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 9 Mar 2016 21:43:19 +0100 Subject: [PATCH 15/24] Add more version information to debug command --- Language/Haskell/GhcMod/Debug.hs | 31 ++++++++++++++++++++++++++----- 1 file changed, 26 insertions(+), 5 deletions(-) diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs index 2fd7bb0..48f7137 100644 --- a/Language/Haskell/GhcMod/Debug.hs +++ b/Language/Haskell/GhcMod/Debug.hs @@ -7,6 +7,7 @@ import Control.Monad.Trans.Journal import qualified Data.Map as Map import qualified Data.Set as Set import Data.Char +import Data.Version import Data.List.Split import Text.PrettyPrint import Language.Haskell.GhcMod.Monad @@ -17,6 +18,11 @@ import Language.Haskell.GhcMod.Pretty import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.Cradle import Language.Haskell.GhcMod.Stack +import Language.Haskell.GhcMod.Output + +import Paths_ghc_mod (version) + +import Config (cProjectVersion) ---------------------------------------------------------------- @@ -34,14 +40,20 @@ debugInfo = do pkgOpts <- packageGhcOptions + readProc <- gmReadProcess + + ghcVersion <- liftIO $ + dropWhileEnd isSpace <$> readProc "ghc" ["--numeric-version"] "" + return $ unlines $ - [ "Root directory: " ++ cradleRootDir + [ "Version: ghc-mod-" ++ showVersion version + , "Library GHC Version: " ++ cProjectVersion + , "System GHC Version: " ++ ghcVersion + , "Root directory: " ++ cradleRootDir , "Current directory: " ++ cradleCurrentDir , "GHC Package flags:\n" ++ render (nest 4 $ fsep $ map text pkgOpts) , "GHC System libraries: " ++ ghcLibDir - , "GHC user options:\n" ++ render (nest 4 $ - fsep $ map text optGhcUserOptions) ] ++ cabal stackPaths :: IOish m => GhcModT m [String] @@ -63,9 +75,18 @@ cabalDebug = do opts = Map.map gmcGhcOpts mcs srcOpts = Map.map gmcGhcSrcOpts mcs + readProc <- gmReadProcess + cabalInstVersion <- liftIO $ + dropWhileEnd isSpace <$> readProc "cabal" ["--numeric-version"] "" + packages <- liftIO $ readProc "ghc-pkg" ["list", "--simple-output"] "" + let cabalPackages = filter ((== ["Cabal"]) . take 1 . splitOn "-") $ splitWhen isSpace packages + return $ - [ "Cabal file: " ++ show cradleCabalFile - , "Project: " ++ show cradleProject + [ "cabal-install Version: " ++ cabalInstVersion + , "Cabal Library Versions:\n" ++ render (nest 4 $ + fsep $ map text cabalPackages) + , "Cabal file: " ++ show cradleCabalFile + , "Project: " ++ show cradleProject , "Cabal entrypoints:\n" ++ render (nest 4 $ mapDoc gmComponentNameDoc smpDoc entrypoints) , "Cabal components:\n" ++ render (nest 4 $ From dbe1c83a2cefdce015be3aae0ff9715aa29610c3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 2 Mar 2016 00:38:40 +0100 Subject: [PATCH 16/24] Bump lower bound on hlint The Error -> Warning changes in older versions of hlint break the tests otherwise --- ghc-mod.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index c7b1f9f..f583ca5 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -172,7 +172,7 @@ Library , ghc < 8.2 && >= 7.6 , ghc-paths < 0.2 , ghc-syb-utils < 0.3 - , hlint < 1.10 && >= 1.9.26 + , hlint < 1.10 && >= 1.9.27 , monad-journal < 0.8 && >= 0.4 , old-time < 1.2 , pretty < 1.2 From 59ade0d447b34931bb5813ddec10e9c313531556 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 9 Mar 2016 21:43:19 +0100 Subject: [PATCH 17/24] Add more version information to debug command --- Language/Haskell/GhcMod/Debug.hs | 31 ++++++++++++++++++++++++++----- 1 file changed, 26 insertions(+), 5 deletions(-) diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs index 2fd7bb0..48f7137 100644 --- a/Language/Haskell/GhcMod/Debug.hs +++ b/Language/Haskell/GhcMod/Debug.hs @@ -7,6 +7,7 @@ import Control.Monad.Trans.Journal import qualified Data.Map as Map import qualified Data.Set as Set import Data.Char +import Data.Version import Data.List.Split import Text.PrettyPrint import Language.Haskell.GhcMod.Monad @@ -17,6 +18,11 @@ import Language.Haskell.GhcMod.Pretty import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.Cradle import Language.Haskell.GhcMod.Stack +import Language.Haskell.GhcMod.Output + +import Paths_ghc_mod (version) + +import Config (cProjectVersion) ---------------------------------------------------------------- @@ -34,14 +40,20 @@ debugInfo = do pkgOpts <- packageGhcOptions + readProc <- gmReadProcess + + ghcVersion <- liftIO $ + dropWhileEnd isSpace <$> readProc "ghc" ["--numeric-version"] "" + return $ unlines $ - [ "Root directory: " ++ cradleRootDir + [ "Version: ghc-mod-" ++ showVersion version + , "Library GHC Version: " ++ cProjectVersion + , "System GHC Version: " ++ ghcVersion + , "Root directory: " ++ cradleRootDir , "Current directory: " ++ cradleCurrentDir , "GHC Package flags:\n" ++ render (nest 4 $ fsep $ map text pkgOpts) , "GHC System libraries: " ++ ghcLibDir - , "GHC user options:\n" ++ render (nest 4 $ - fsep $ map text optGhcUserOptions) ] ++ cabal stackPaths :: IOish m => GhcModT m [String] @@ -63,9 +75,18 @@ cabalDebug = do opts = Map.map gmcGhcOpts mcs srcOpts = Map.map gmcGhcSrcOpts mcs + readProc <- gmReadProcess + cabalInstVersion <- liftIO $ + dropWhileEnd isSpace <$> readProc "cabal" ["--numeric-version"] "" + packages <- liftIO $ readProc "ghc-pkg" ["list", "--simple-output"] "" + let cabalPackages = filter ((== ["Cabal"]) . take 1 . splitOn "-") $ splitWhen isSpace packages + return $ - [ "Cabal file: " ++ show cradleCabalFile - , "Project: " ++ show cradleProject + [ "cabal-install Version: " ++ cabalInstVersion + , "Cabal Library Versions:\n" ++ render (nest 4 $ + fsep $ map text cabalPackages) + , "Cabal file: " ++ show cradleCabalFile + , "Project: " ++ show cradleProject , "Cabal entrypoints:\n" ++ render (nest 4 $ mapDoc gmComponentNameDoc smpDoc entrypoints) , "Cabal components:\n" ++ render (nest 4 $ From dcaf95b4e3fe8f62c504a0ba8cffbb5f3210299a Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Tue, 15 Mar 2016 21:43:27 +0300 Subject: [PATCH 18/24] Fix file-map for case-split --- Language/Haskell/GhcMod/CaseSplit.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/Language/Haskell/GhcMod/CaseSplit.hs b/Language/Haskell/GhcMod/CaseSplit.hs index 7c98f6e..7bcd3fa 100644 --- a/Language/Haskell/GhcMod/CaseSplit.hs +++ b/Language/Haskell/GhcMod/CaseSplit.hs @@ -27,6 +27,7 @@ import Language.Haskell.GhcMod.SrcUtils import Language.Haskell.GhcMod.Doc import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Utils (withMappedFile) import Language.Haskell.GhcMod.FileMapping (fileModSummaryWithMapping) ---------------------------------------------------------------- @@ -57,12 +58,14 @@ splits file lineNo colNo = whenFound' oopts (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> case x of (SplitInfo varName bndLoc (varLoc,varT) _matches) -> do let varName' = showName dflag style varName -- Convert name to string - t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $ + t <- withMappedFile file $ \file' -> + genCaseSplitTextFile file' (SplitToTextInfo varName' bndLoc varLoc $ getTyCons dflag style varName varT) return (fourInts bndLoc, t) (TySplitInfo varName bndLoc (varLoc,varT)) -> do let varName' = showName dflag style varName -- Convert name to string - t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $ + t <- withMappedFile file $ \file' -> + genCaseSplitTextFile file' (SplitToTextInfo varName' bndLoc varLoc $ getTyCons dflag style varName varT) return (fourInts bndLoc, t) where From 11a1ad2cf3e75fc6b7604cdbb60d573421ec7d5a Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Fri, 29 Jan 2016 01:51:40 +0300 Subject: [PATCH 19/24] Fix mapping subst in info for insts add type fams --- Language/Haskell/GhcMod/Gap.hs | 38 ++++++++++++++++++++++++++-------- 1 file changed, 29 insertions(+), 9 deletions(-) diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs index 48337e0..bf38e1c 100644 --- a/Language/Haskell/GhcMod/Gap.hs +++ b/Language/Haskell/GhcMod/Gap.hs @@ -75,6 +75,10 @@ import qualified InstEnv import qualified Pretty import qualified StringBuffer as SB +#if __GLASGOW_HASKELL__ >= 710 +import CoAxiom (coAxiomTyCon) +#endif + #if __GLASGOW_HASKELL__ >= 708 import FamInstEnv import ConLike (ConLike(..)) @@ -357,28 +361,44 @@ pprInfo :: (FilePath -> FilePath) -> Bool -> (TyThing, GHC.Fixity, [ClsInst], [F pprInfo m _ (thing, fixity, insts, famInsts) = pprTyThingInContextLoc' thing $$ show_fixity fixity - $$ InstEnv.pprInstances insts - $$ pprFamInsts famInsts + $$ vcat (map pprInstance' insts) + $$ vcat (map pprFamInst' famInsts) #else pprInfo :: (FilePath -> FilePath) -> PrintExplicitForalls -> (TyThing, GHC.Fixity, [ClsInst]) -> SDoc pprInfo m pefas (thing, fixity, insts) = pprTyThingInContextLoc' pefas thing $$ show_fixity fixity - $$ vcat (map pprInstance insts) + $$ vcat (map pprInstance' insts) #endif where show_fixity fx | fx == defaultFixity = Outputable.empty | otherwise = ppr fx <+> ppr (getName thing) #if __GLASGOW_HASKELL__ >= 708 - pprTyThingInContextLoc' thing' = hang (pprTyThingInContext thing') 2 - (char '\t' <> ptext (sLit "--") <+> loc) - where loc = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing') + pprTyThingInContextLoc' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext thing') +#if __GLASGOW_HASKELL__ >= 710 + pprFamInst' (FamInst { fi_flavor = DataFamilyInst rep_tc }) + = pprTyThingInContextLoc (ATyCon rep_tc) + + pprFamInst' (FamInst { fi_flavor = SynFamilyInst, fi_axiom = axiom + , fi_tys = lhs_tys, fi_rhs = rhs }) + = showWithLoc (pprDefinedAt' (getName axiom)) $ + hang (ptext (sLit "type instance") <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys) + 2 (equals <+> ppr rhs) #else - pprTyThingInContextLoc' pefas' thing' = hang (pprTyThingInContext pefas' thing') 2 - (char '\t' <> ptext (sLit "--") <+> loc) - where loc = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing') + pprFamInst' ispec = showWithLoc (pprDefinedAt' (getName ispec)) (pprFamInstHdr ispec) #endif +#else + pprTyThingInContextLoc' pefas' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext pefas' thing') +#endif + showWithLoc loc doc + = hang doc 2 (char '\t' <> comment <+> loc) + -- The tab tries to make them line up a bit + where + comment = ptext (sLit "--") + pprInstance' ispec = hang (pprInstanceHdr ispec) + 2 (ptext (sLit "--") <+> pprDefinedAt' (getName ispec)) + pprDefinedAt' thing' = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing') pprNameDefnLoc' name = case Name.nameSrcLoc name of RealSrcLoc s -> ptext (sLit "at") <+> ppr (subst s) From 3ae9204b95b743cd41a58576a59a4d0473e36c12 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 11 May 2016 15:10:00 +0200 Subject: [PATCH 20/24] Disable 'cabal' cradle when executable isn't found --- Language/Haskell/GhcMod/Cradle.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs index fe2b179..ed940c8 100644 --- a/Language/Haskell/GhcMod/Cradle.hs +++ b/Language/Haskell/GhcMod/Cradle.hs @@ -69,12 +69,16 @@ fillTempDir crdl = do tmpDir <- liftIO $ newTempDir (cradleRootDir crdl) return crdl { cradleTempDir = tmpDir } -cabalCradle :: IOish m => FilePath -> MaybeT m Cradle +cabalCradle :: (IOish m, GmLog m, GmOut m) => FilePath -> MaybeT m Cradle cabalCradle wdir = do cabalFile <- MaybeT $ liftIO $ findCabalFile wdir - let cabalDir = takeDirectory cabalFile + -- If cabal doesn't exist the user probably wants to use something else + whenM (isJust <$> liftIO (findExecutable "cabal")) $ do + gmLog GmWarning "" $ text "'dist/setup-config' exists but 'cabal' executable wasn't found." + mzero + return Cradle { cradleProject = CabalProject , cradleCurrentDir = wdir From 7e05c152198c03f2e33aece701af158eb939e0e0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 11 May 2016 15:27:11 +0200 Subject: [PATCH 21/24] 'debug' shouldn't fail if 'cabal' is not installed which seems to be more common that you'd think --- Language/Haskell/GhcMod/Debug.hs | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs index 48f7137..59673e0 100644 --- a/Language/Haskell/GhcMod/Debug.hs +++ b/Language/Haskell/GhcMod/Debug.hs @@ -9,6 +9,7 @@ import qualified Data.Set as Set import Data.Char import Data.Version import Data.List.Split +import System.Directory import Text.PrettyPrint import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Types @@ -76,8 +77,14 @@ cabalDebug = do srcOpts = Map.map gmcGhcSrcOpts mcs readProc <- gmReadProcess - cabalInstVersion <- liftIO $ - dropWhileEnd isSpace <$> readProc "cabal" ["--numeric-version"] "" + cabalExists <- liftIO $ (/=Nothing) <$> findExecutable "cabal" + + cabalInstVersion <- + if cabalExists + then liftIO $ + dropWhileEnd isSpace <$> readProc "cabal" ["--numeric-version"] "" + else return "" + packages <- liftIO $ readProc "ghc-pkg" ["list", "--simple-output"] "" let cabalPackages = filter ((== ["Cabal"]) . take 1 . splitOn "-") $ splitWhen isSpace packages From b8076fc5d37854534c661f4e9d53af60bb3101f6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 11 May 2016 15:13:19 +0200 Subject: [PATCH 22/24] Bump cabal-helper dependency For Cabal-1.24 support --- Language/Haskell/GhcMod/Pretty.hs | 3 ++- ghc-mod.cabal | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/Language/Haskell/GhcMod/Pretty.hs b/Language/Haskell/GhcMod/Pretty.hs index 1df6948..b2d9e7d 100644 --- a/Language/Haskell/GhcMod/Pretty.hs +++ b/Language/Haskell/GhcMod/Pretty.hs @@ -32,7 +32,8 @@ gmRenderDoc = renderStyle docStyle gmComponentNameDoc :: ChComponentName -> Doc gmComponentNameDoc ChSetupHsName = text $ "Setup.hs" -gmComponentNameDoc ChLibName = text $ "library" +gmComponentNameDoc (ChLibName "") = text $ "library" +gmComponentNameDoc (ChLibName n) = text $ "library:" ++ n gmComponentNameDoc (ChExeName n) = text $ "exe:" ++ n gmComponentNameDoc (ChTestName n) = text $ "test:" ++ n gmComponentNameDoc (ChBenchName n) = text $ "bench:" ++ n diff --git a/ghc-mod.cabal b/ghc-mod.cabal index f583ca5..583e033 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -165,7 +165,7 @@ Library , bytestring < 0.11 , binary < 0.9 && >= 0.5.1.0 , containers < 0.6 - , cabal-helper < 0.7 && >= 0.6.3.0 + , cabal-helper < 0.8 && >= 0.7.0.1 , deepseq < 1.5 , directory < 1.3 , filepath < 1.5 From 0e024c9b79d7188ee07acd4bfddd22b52b6855a7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sat, 14 May 2016 20:17:11 +0200 Subject: [PATCH 23/24] Fix broken logic in cradle --- Language/Haskell/GhcMod/Cradle.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs index ed940c8..06ad80e 100644 --- a/Language/Haskell/GhcMod/Cradle.hs +++ b/Language/Haskell/GhcMod/Cradle.hs @@ -75,8 +75,8 @@ cabalCradle wdir = do let cabalDir = takeDirectory cabalFile -- If cabal doesn't exist the user probably wants to use something else - whenM (isJust <$> liftIO (findExecutable "cabal")) $ do - gmLog GmWarning "" $ text "'dist/setup-config' exists but 'cabal' executable wasn't found." + whenM ((==Nothing) <$> liftIO (findExecutable "cabal")) $ do + gmLog GmInfo "" $ text "'dist/setup-config' exists but 'cabal' executable wasn't found" mzero return Cradle { From e495c55a8db0b0940df98e9fea03c33b25de0e26 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sat, 14 May 2016 20:18:06 +0200 Subject: [PATCH 24/24] Use existence of cabal/stack as cradle indicator Also add some more "info" logging for which cradle was picked. --- Language/Haskell/GhcMod/Cradle.hs | 68 +++++++++++++++++++------------ Language/Haskell/GhcMod/Debug.hs | 7 ++-- Language/Haskell/GhcMod/Monad.hs | 14 +++++-- src/GHCMod.hs | 3 +- test/CradleSpec.hs | 6 +-- test/PathsAndFilesSpec.hs | 4 +- test/TestUtils.hs | 15 +++++-- 7 files changed, 74 insertions(+), 43 deletions(-) diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs index 06ad80e..05f6b31 100644 --- a/Language/Haskell/GhcMod/Cradle.hs +++ b/Language/Haskell/GhcMod/Cradle.hs @@ -34,24 +34,29 @@ import Control.Monad.Trans.Journal (runJournalT) -- Find a cabal file by tracing ancestor directories. -- Find a sandbox according to a cabal sandbox config -- in a cabal directory. -findCradle :: (GmLog m, IOish m, GmOut m) => m Cradle -findCradle = findCradle' =<< liftIO getCurrentDirectory +findCradle :: (GmLog m, IOish m, GmOut m) => Programs -> m Cradle +findCradle progs = findCradle' progs =<< liftIO getCurrentDirectory -findCradleNoLog :: forall m. (IOish m, GmOut m) => m Cradle -findCradleNoLog = fst <$> (runJournalT findCradle :: m (Cradle, GhcModLog)) +findCradleNoLog :: forall m. (IOish m, GmOut m) => Programs -> m Cradle +findCradleNoLog progs = + fst <$> (runJournalT (findCradle progs) :: m (Cradle, GhcModLog)) -findCradle' :: (GmLog m, IOish m, GmOut m) => FilePath -> m Cradle -findCradle' dir = run $ - msum [ stackCradle dir - , cabalCradle dir +findCradle' :: (GmLog m, IOish m, GmOut m) => Programs -> FilePath -> m Cradle +findCradle' Programs { stackProgram, cabalProgram } dir = run $ + msum [ stackCradle stackProgram dir + , cabalCradle cabalProgram dir , sandboxCradle dir , plainCradle dir ] where run a = fillTempDir =<< (fromJustNote "findCradle'" <$> runMaybeT a) -findSpecCradle :: (GmLog m, IOish m, GmOut m) => FilePath -> m Cradle -findSpecCradle dir = do - let cfs = [stackCradleSpec, cabalCradle, sandboxCradle] +findSpecCradle :: + (GmLog m, IOish m, GmOut m) => Programs -> FilePath -> m Cradle +findSpecCradle Programs { stackProgram, cabalProgram } dir = do + let cfs = [ stackCradleSpec stackProgram + , cabalCradle cabalProgram + , sandboxCradle + ] cs <- catMaybes <$> mapM (runMaybeT . ($ dir)) cfs gcs <- filterM isNotGmCradle cs fillTempDir =<< case gcs of @@ -69,16 +74,18 @@ fillTempDir crdl = do tmpDir <- liftIO $ newTempDir (cradleRootDir crdl) return crdl { cradleTempDir = tmpDir } -cabalCradle :: (IOish m, GmLog m, GmOut m) => FilePath -> MaybeT m Cradle -cabalCradle wdir = do - cabalFile <- MaybeT $ liftIO $ findCabalFile wdir - let cabalDir = takeDirectory cabalFile - +cabalCradle :: + (IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle +cabalCradle cabalProg wdir = do -- If cabal doesn't exist the user probably wants to use something else - whenM ((==Nothing) <$> liftIO (findExecutable "cabal")) $ do + whenM ((==Nothing) <$> liftIO (findExecutable cabalProg)) $ do gmLog GmInfo "" $ text "'dist/setup-config' exists but 'cabal' executable wasn't found" mzero + cabalFile <- MaybeT $ liftIO $ findCabalFile wdir + let cabalDir = takeDirectory cabalFile + + gmLog GmInfo "" $ text "found Cabal project at" <+>: text cabalDir return Cradle { cradleProject = CabalProject , cradleCurrentDir = wdir @@ -88,12 +95,19 @@ cabalCradle wdir = do , cradleDistDir = "dist" } -stackCradle :: (GmLog m, IOish m, GmOut m) => FilePath -> MaybeT m Cradle -stackCradle wdir = do +stackCradle :: + (IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle +stackCradle stackProg wdir = do #if !MIN_VERSION_ghc(7,8,0) -- GHC < 7.8 is not supported by stack mzero #endif + + -- If cabal doesn't exist the user probably wants to use something else + whenM ((==Nothing) <$> liftIO (findExecutable stackProg)) $ do + gmLog GmInfo "" $ text "'dist/setup-config' exists but 'cabal' executable wasn't found" + mzero + cabalFile <- MaybeT $ liftIO $ findCabalFile wdir let cabalDir = takeDirectory cabalFile @@ -103,11 +117,12 @@ stackCradle wdir = do -- If dist/setup-config already exists the user probably wants to use cabal -- rather than stack, or maybe that's just me ;) whenM (liftIO $ doesFileExist $ cabalDir setupConfigPath "dist") $ do - gmLog GmWarning "" $ text "'dist/setup-config' exists, ignoring Stack and using cabal-install instead." + gmLog GmWarning "" $ text "'dist/setup-config' exists, ignoring Stack and using cabal-install instead" mzero senv <- MaybeT $ getStackEnv cabalDir + gmLog GmInfo "" $ text "found Stack project at" <+>: text cabalDir return Cradle { cradleProject = StackProject senv , cradleCurrentDir = wdir @@ -117,9 +132,10 @@ stackCradle wdir = do , cradleDistDir = seDistDir senv } -stackCradleSpec :: (GmLog m, IOish m, GmOut m) => FilePath -> MaybeT m Cradle -stackCradleSpec wdir = do - crdl <- stackCradle wdir +stackCradleSpec :: + (IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle +stackCradleSpec stackProg wdir = do + crdl <- stackCradle stackProg wdir case crdl of Cradle { cradleProject = StackProject StackEnv { seDistDir } } -> do b <- isGmDistDir seDistDir @@ -130,9 +146,10 @@ stackCradleSpec wdir = do isGmDistDir dir = liftIO $ not <$> doesFileExist (dir ".." "ghc-mod.cabal") -sandboxCradle :: IOish m => FilePath -> MaybeT m Cradle +sandboxCradle :: (IOish m, GmLog m, GmOut m) => FilePath -> MaybeT m Cradle sandboxCradle wdir = do sbDir <- MaybeT $ liftIO $ findCabalSandboxDir wdir + gmLog GmInfo "" $ text "Found sandbox project at" <+>: text sbDir return Cradle { cradleProject = SandboxProject , cradleCurrentDir = wdir @@ -142,8 +159,9 @@ sandboxCradle wdir = do , cradleDistDir = "dist" } -plainCradle :: IOish m => FilePath -> MaybeT m Cradle +plainCradle :: (IOish m, GmLog m, GmOut m) => FilePath -> MaybeT m Cradle plainCradle wdir = do + gmLog GmInfo "" $ text "Found no other project type, falling back to plain GHC project" return $ Cradle { cradleProject = PlainProject , cradleCurrentDir = wdir diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs index 59673e0..9811e72 100644 --- a/Language/Haskell/GhcMod/Debug.hs +++ b/Language/Haskell/GhcMod/Debug.hs @@ -3,7 +3,6 @@ module Language.Haskell.GhcMod.Debug (debugInfo, rootInfo, componentInfo) where import Control.Arrow (first) import Control.Applicative import Control.Monad -import Control.Monad.Trans.Journal import qualified Data.Map as Map import qualified Data.Set as Set import Data.Char @@ -167,5 +166,7 @@ mapDoc kd ad m = vcat $ ---------------------------------------------------------------- -- | Obtaining root information. -rootInfo :: forall m. (IOish m, GmOut m) => m String -rootInfo = (++"\n") . cradleRootDir <$> fst `liftM` (runJournalT findCradle :: m (Cradle, GhcModLog)) +rootInfo :: forall m. (IOish m, GmOut m, GmEnv m) => m String +rootInfo = do + crdl <- findCradleNoLog =<< (optPrograms <$> options) + return $ cradleRootDir crdl ++ "\n" diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs index 5d90aee..96d55e5 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ b/Language/Haskell/GhcMod/Monad.hs @@ -53,11 +53,17 @@ import System.Directory import System.IO.Unsafe import Prelude -withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a -withGhcModEnv = withGhcModEnv' withCradle +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 $ findCradle' dir) (liftIO . cleanupCradle . fst) + withCradle dir' = + gbracket + (runJournalT $ do + gmSetLogLevel $ ooptLogLevel $ optOutput opts + findCradle' (optPrograms opts) dir') + (liftIO . cleanupCradle . fst) + + cwdLock :: MVar ThreadId cwdLock = unsafePerformIO $ newEmptyMVar diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 531f7de..713d567 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -111,7 +111,6 @@ getFileSourceFromStdin = do else return [] wrapGhcCommands :: (IOish m, GmOut m) => Options -> GhcModCommands -> m () -wrapGhcCommands _opts CmdRoot = gmPutStr =<< rootInfo wrapGhcCommands opts cmd = handleGmError $ runGhcModT opts $ handler $ do forM_ (reverse $ optFileMappings opts) $ @@ -141,7 +140,7 @@ ghcCommands (CmdDebug) = debugInfo ghcCommands (CmdDebugComponent ts) = componentInfo ts ghcCommands (CmdBoot) = boot -- ghcCommands (CmdNukeCaches) = nukeCaches >> return "" --- ghcCommands (CmdRoot) = undefined -- handled in wrapGhcCommands +ghcCommands (CmdRoot) = rootInfo ghcCommands (CmdLegacyInteractive) = legacyInteractive >> return "" ghcCommands (CmdModules detail) = modules detail ghcCommands (CmdDumpSym) = dumpSymbol >> return "" diff --git a/test/CradleSpec.hs b/test/CradleSpec.hs index 6396437..c62a589 100644 --- a/test/CradleSpec.hs +++ b/test/CradleSpec.hs @@ -37,14 +37,14 @@ spec = do it "returns the current directory" $ do withDirectory_ "/" $ do curDir <- stripLastDot <$> canonicalizePath "/" - res <- clean_ $ runGmOutDef findCradleNoLog + res <- clean_ $ runGmOutDef $ findCradleNoLog $ optPrograms defaultOptions cradleCurrentDir res `shouldBe` curDir cradleRootDir res `shouldBe` curDir cradleCabalFile res `shouldBe` Nothing it "finds a cabal file and a sandbox" $ do withDirectory "test/data/cabal-project/subdir1/subdir2" $ \dir -> do - res <- relativeCradle dir <$> clean_ (runGmOutDef findCradleNoLog) + res <- relativeCradle dir <$> clean_ (runGmOutDef $ findCradleNoLog $ optPrograms defaultOptions) cradleCurrentDir res `shouldBe` "test/data/cabal-project/subdir1/subdir2" @@ -56,7 +56,7 @@ spec = do it "works even if a sandbox config file is broken" $ do withDirectory "test/data/broken-sandbox" $ \dir -> do - res <- relativeCradle dir <$> clean_ (runGmOutDef findCradleNoLog) + res <- relativeCradle dir <$> clean_ (runGmOutDef $ findCradleNoLog $ optPrograms defaultOptions) cradleCurrentDir res `shouldBe` "test" "data" "broken-sandbox" diff --git a/test/PathsAndFilesSpec.hs b/test/PathsAndFilesSpec.hs index b2ac6e6..d3611f1 100644 --- a/test/PathsAndFilesSpec.hs +++ b/test/PathsAndFilesSpec.hs @@ -16,12 +16,12 @@ spec = do describe "getSandboxDb" $ do it "can parse a config file and extract the sandbox package-db" $ do cwd <- getCurrentDirectory - Just crdl <- runMaybeT $ plainCradle "test/data/cabal-project" + Just crdl <- runLogDef $ runMaybeT $ plainCradle "test/data/cabal-project" Just db <- getSandboxDb crdl db `shouldSatisfy` isPkgDbAt (cwd "test/data/cabal-project/.cabal-sandbox") it "returns Nothing if the sandbox config file is broken" $ do - Just crdl <- runMaybeT $ plainCradle "test/data/broken-sandbox" + Just crdl <- runLogDef $ runMaybeT $ plainCradle "test/data/broken-sandbox" getSandboxDb crdl `shouldReturn` Nothing describe "findCabalFile" $ do diff --git a/test/TestUtils.hs b/test/TestUtils.hs index 9ce67b5..af5367b 100644 --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -6,6 +6,7 @@ module TestUtils ( , runE , runNullLog , runGmOutDef + , runLogDef , shouldReturnError , isPkgDbAt , isPkgConfDAt @@ -43,10 +44,6 @@ extract action = do Right a -> return a Left e -> error $ show e -withSpecCradle :: (IOish m, GmOut m) => FilePath -> ((Cradle, GhcModLog) -> m a) -> m a -withSpecCradle cradledir f = do - gbracket (runJournalT $ findSpecCradle cradledir) (liftIO . cleanupCradle . fst) f - runGhcModTSpec :: Options -> GhcModT IO a -> IO (Either GhcModError a, GhcModLog) runGhcModTSpec opt action = do dir <- getCurrentDirectory @@ -59,6 +56,13 @@ runGhcModTSpec' dir opt action = liftIO (canonicalizePath dir) >>= \dir' -> do withGhcModEnv' withSpecCradle dir' opt $ \(env,_) -> do first (fst <$>) <$> runGhcModT' env defaultGhcModState (gmSetLogLevel (ooptLogLevel $ optOutput opt) >> action) + where + withSpecCradle :: (IOish m, GmOut m) => FilePath -> ((Cradle, GhcModLog) -> m a) -> m a + withSpecCradle cradledir f = + gbracket + (runJournalT $ findSpecCradle (optPrograms opt) cradledir) + (liftIO . cleanupCradle . fst) f + -- | Run GhcMod run :: Options -> GhcModT IO a -> IO a @@ -88,6 +92,9 @@ runNullLog action = do runGmOutDef :: IOish m => GmOutT m a -> m a runGmOutDef = runGmOutT defaultOptions +runLogDef :: IOish m => GmOutT (JournalT GhcModLog m) a -> m a +runLogDef = fmap fst . runJournalT . runGmOutDef + shouldReturnError :: Show a => IO (Either GhcModError a, GhcModLog) -> Expectation