hasufell
/
ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Sandwich new Monad layer GmOutT into transformer stack 

This way we can have access to some options pre Cradle setup which
should fix the output interleaving problems I was observing.
This commit is contained in:
Daniel Gröber 2015-09-01 10:27:12 +02:00
parent 2af1da960b
commit 41de8b8b2e
25 changed files with 390 additions and 281 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
Language/Haskell/GhcMod/Browse.hs
View File

@ -80,7 +80,7 @@ processExports :: (G.GhcMonad m, MonadIO m, ExceptionMonad m)
processExports opt minfo = do processExports opt minfo = do
let let
removeOps removeOps
| operators opt = id | optOperators opt = id
| otherwise = filter (isNotOp . getOccString) | otherwise = filter (isNotOp . getOccString)
mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo
@ -90,17 +90,17 @@ showExport opt minfo e = do
mtype' <- mtype mtype' <- mtype
return $ concat $ catMaybes [mqualified, Just $ formatOp $ getOccString e, mtype'] return $ concat $ catMaybes [mqualified, Just $ formatOp $ getOccString e, mtype']
where where
mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` qualified opt mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` optQualified opt
mtype :: m (Maybe String) mtype :: m (Maybe String)
mtype mtype
| detailed opt = do | optDetailed opt = do
tyInfo <- G.modInfoLookupName minfo e tyInfo <- G.modInfoLookupName minfo e
-- If nothing found, load dependent module and lookup global -- If nothing found, load dependent module and lookup global
tyResult <- maybe (inOtherModule e) (return . Just) tyInfo tyResult <- maybe (inOtherModule e) (return . Just) tyInfo
dflag <- G.getSessionDynFlags dflag <- G.getSessionDynFlags
return $ do return $ do
typeName <- tyResult >>= showThing dflag typeName <- tyResult >>= showThing dflag
(" :: " ++ typeName) `justIf` detailed opt (" :: " ++ typeName) `justIf` optDetailed opt
| otherwise = return Nothing | otherwise = return Nothing
formatOp nm formatOp nm
| null nm = error "formatOp" | null nm = error "formatOp"

34
Language/Haskell/GhcMod/CabalHelper.hs
View File

@ -53,7 +53,7 @@ import Paths_ghc_mod as GhcMod
-- | Only package related GHC options, sufficient for things that don't need to -- | Only package related GHC options, sufficient for things that don't need to
-- access home modules -- access home modules
getGhcMergedPkgOptions :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m) getGhcMergedPkgOptions :: (Applicative m, IOish m, Gm m)
=> m [GHCOption] => m [GHCOption]
getGhcMergedPkgOptions = chCached $ \distdir -> Cached { getGhcMergedPkgOptions = chCached $ \distdir -> Cached {
cacheLens = Just (lGmcMergedPkgOptions . lGmCaches), cacheLens = Just (lGmcMergedPkgOptions . lGmCaches),
@ -65,7 +65,7 @@ getGhcMergedPkgOptions = chCached $ \distdir -> Cached {
return ([setupConfigPath distdir], opts) return ([setupConfigPath distdir], opts)
} }
getCabalPackageDbStack :: (IOish m, GmEnv m, GmState m, GmLog m) => m [GhcPkgDb] getCabalPackageDbStack :: (IOish m, Gm m) => m [GhcPkgDb]
getCabalPackageDbStack = chCached $ \distdir -> Cached { getCabalPackageDbStack = chCached $ \distdir -> Cached {
cacheLens = Just (lGmcPackageDbStack . lGmCaches), cacheLens = Just (lGmcPackageDbStack . lGmCaches),
cacheFile = pkgDbStackCacheFile distdir, cacheFile = pkgDbStackCacheFile distdir,
@ -86,7 +86,7 @@ chPkgToGhcPkg (ChPkgSpecific f) = PackageDb f
-- --
-- The Component\'s 'gmcHomeModuleGraph' will be empty and has to be resolved by -- The Component\'s 'gmcHomeModuleGraph' will be empty and has to be resolved by
-- 'resolveGmComponents'. -- 'resolveGmComponents'.
getComponents :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m) getComponents :: (Applicative m, IOish m, Gm m)
=> m [GmComponent 'GMCRaw ChEntrypoint] => m [GmComponent 'GMCRaw ChEntrypoint]
getComponents = chCached$ \distdir -> Cached { getComponents = chCached$ \distdir -> Cached {
cacheLens = Just (lGmcComponents . lGmCaches), cacheLens = Just (lGmcComponents . lGmCaches),
@ -116,7 +116,7 @@ getComponents = chCached$ \distdir -> Cached {
, a == a' , a == a'
] ]
prepareCabalHelper :: (IOish m, GmEnv m, GmLog m) => m () prepareCabalHelper :: (IOish m, GmEnv m, GmOut m, GmLog m) => m ()
prepareCabalHelper = do prepareCabalHelper = do
crdl <- cradle crdl <- cradle
let projdir = cradleRootDir crdl let projdir = cradleRootDir crdl
@ -147,19 +147,19 @@ getStackPackageDbStack = do
localDb <- liftIO $ readProcess stack ["path", "--local-pkg-db"] "" localDb <- liftIO $ readProcess stack ["path", "--local-pkg-db"] ""
return $ map (PackageDb . takeWhile (/='\n')) [snapshotDb, localDb] return $ map (PackageDb . takeWhile (/='\n')) [snapshotDb, localDb]
patchStackPrograms :: IOish m => OutputOpts -> Cradle -> Programs -> m Programs patchStackPrograms :: (IOish m, GmOut m) => Cradle -> Programs -> m Programs
patchStackPrograms _oopts crdl progs patchStackPrograms crdl progs
| cradleProjectType crdl /= StackProject = return progs | cradleProjectType crdl /= StackProject = return progs
patchStackPrograms oopts crdl progs = do patchStackPrograms crdl progs = do
let projdir = cradleRootDir crdl let projdir = cradleRootDir crdl
Just ghc <- liftIO $ getStackGhcPath oopts projdir Just ghc <- getStackGhcPath projdir
Just ghcPkg <- liftIO $ getStackGhcPkgPath oopts projdir Just ghcPkg <- getStackGhcPkgPath projdir
return $ progs { return $ progs {
ghcProgram = ghc ghcProgram = ghc
, ghcPkgProgram = ghcPkg , ghcPkgProgram = ghcPkg
} }
withCabal :: (IOish m, GmEnv m, GmLog m) => m a -> m a withCabal :: (IOish m, GmEnv m, GmOut m, GmLog m) => m a -> m a
withCabal action = do withCabal action = do
crdl <- cradle crdl <- cradle
opts <- options opts <- options
@ -177,7 +177,7 @@ withCabal action = do
pkgDbStackOutOfSync <- pkgDbStackOutOfSync <-
case mCusPkgDbStack of case mCusPkgDbStack of
Just cusPkgDbStack -> do Just cusPkgDbStack -> do
pkgDb <- runQuery'' readProc (helperProgs $ programs opts) projdir distdir $ pkgDb <- runQuery'' readProc (helperProgs $ optPrograms opts) projdir distdir $
map chPkgToGhcPkg <$> packageDbStack map chPkgToGhcPkg <$> packageDbStack
return $ pkgDb /= cusPkgDbStack return $ pkgDb /= cusPkgDbStack
@ -199,10 +199,10 @@ withCabal action = do
|| isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $ || isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $
case projType of case projType of
CabalProject -> CabalProject ->
cabalReconfigure readProc (programs opts) crdl projdir distdir cabalReconfigure readProc (optPrograms opts) crdl projdir distdir
StackProject -> StackProject ->
stackReconfigure crdl (programs opts) stackReconfigure crdl (optPrograms opts)
_ -> _ ->
error $ "withCabal: unsupported project type: " ++ show projType error $ "withCabal: unsupported project type: " ++ show projType
@ -216,7 +216,7 @@ withCabal action = do
[ "--with-ghc=" ++ T.ghcProgram progs ] [ "--with-ghc=" ++ T.ghcProgram progs ]
-- Only pass ghc-pkg if it was actually set otherwise we -- Only pass ghc-pkg if it was actually set otherwise we
-- might break cabal's guessing logic -- might break cabal's guessing logic
++ if T.ghcPkgProgram progs /= T.ghcPkgProgram (programs defaultOptions) ++ if T.ghcPkgProgram progs /= T.ghcPkgProgram (optPrograms defaultOptions)
then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram progs ] then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram progs ]
else [] else []
++ map pkgDbArg cusPkgStack ++ map pkgDbArg cusPkgStack
@ -277,7 +277,7 @@ helperProgs progs = CH.Programs {
ghcPkgProgram = T.ghcPkgProgram progs ghcPkgProgram = T.ghcPkgProgram progs
} }
chCached :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m, Serialize a) chCached :: (Applicative m, IOish m, Gm m, Serialize a)
=> (FilePath -> Cached m GhcModState ChCacheData a) -> m a => (FilePath -> Cached m GhcModState ChCacheData a) -> m a
chCached c = do chCached c = do
root <- cradleRootDir <$> cradle root <- cradleRootDir <$> cradle
@ -289,10 +289,8 @@ chCached c = do
-- changes the cache files will be gone anyways ;) -- changes the cache files will be gone anyways ;)
cacheInputData root = do cacheInputData root = do
opts <- options opts <- options
let oopts = outputOpts opts
progs = programs opts
crdl <- cradle crdl <- cradle
progs' <- patchStackPrograms oopts crdl progs progs' <- patchStackPrograms crdl (optPrograms opts)
return $ ( helperProgs progs' return $ ( helperProgs progs'
, root , root
, (gmVer, chVer) , (gmVer, chVer)

5
Language/Haskell/GhcMod/CaseSplit.hs
View File

@ -6,7 +6,6 @@ module Language.Haskell.GhcMod.CaseSplit (
import Data.List (find, intercalate) import Data.List (find, intercalate)
import Data.Maybe (isJust) import Data.Maybe (isJust)
import Data.Functor
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.IO as T (readFile) import qualified Data.Text.IO as T (readFile)
import System.FilePath import System.FilePath
@ -50,7 +49,7 @@ splits :: IOish m
-> GhcModT m String -> GhcModT m String
splits file lineNo colNo = splits file lineNo colNo =
ghandle handler $ runGmlT' [Left file] deferErrors $ do ghandle handler $ runGmlT' [Left file] deferErrors $ do
oopts <- outputOpts <$> options oopts <- outputOpts
crdl <- cradle crdl <- cradle
style <- getStyle style <- getStyle
dflag <- G.getSessionDynFlags dflag <- G.getSessionDynFlags
@ -70,7 +69,7 @@ splits file lineNo colNo =
handler (SomeException ex) = do handler (SomeException ex) = do
gmLog GmException "splits" $ gmLog GmException "splits" $
text "" $$ nest 4 (showDoc ex) text "" $$ nest 4 (showDoc ex)
emptyResult =<< outputOpts <$> options emptyResult =<< outputOpts
---------------------------------------------------------------- ----------------------------------------------------------------
-- a. Code for getting the information of the variable -- a. Code for getting the information of the variable

8
Language/Haskell/GhcMod/Convert.hs
View File

@ -25,11 +25,11 @@ inter _ [] = id
inter c bs = foldr1 (\x y -> x . (c:) . y) bs inter c bs = foldr1 (\x y -> x . (c:) . y) bs
convert' :: (ToString a, IOish m, GmEnv m) => a -> m String convert' :: (ToString a, IOish m, GmEnv m) => a -> m String
convert' x = flip convert x . outputOpts <$> options convert' x = flip convert x . optOutput <$> options
convert :: ToString a => OutputOpts -> a -> String convert :: ToString a => OutputOpts -> a -> String
convert opt@OutputOpts { outputStyle = LispStyle } x = toLisp opt x "\n" convert opt@OutputOpts { ooptStyle = LispStyle } x = toLisp opt x "\n"
convert opt@OutputOpts { outputStyle = PlainStyle } x convert opt@OutputOpts { ooptStyle = PlainStyle } x
| str == "\n" = "" | str == "\n" = ""
| otherwise = str | otherwise = str
where where
@ -43,7 +43,7 @@ lineSep :: OutputOpts -> String
lineSep oopts = interpret lsep lineSep oopts = interpret lsep
where where
interpret s = read $ "\"" ++ s ++ "\"" interpret s = read $ "\"" ++ s ++ "\""
LineSeparator lsep = lineSeparator oopts LineSeparator lsep = ooptLineSeparator oopts
-- | -- |
-- --

36
Language/Haskell/GhcMod/Cradle.hs
View File

@ -29,12 +29,16 @@ import Prelude
-- Find a cabal file by tracing ancestor directories. -- Find a cabal file by tracing ancestor directories.
-- Find a sandbox according to a cabal sandbox config -- Find a sandbox according to a cabal sandbox config
-- in a cabal directory. -- in a cabal directory.
findCradle :: OutputOpts -> IO Cradle findCradle :: (IOish m, GmOut m) => m Cradle
findCradle oopts = findCradle' oopts =<< getCurrentDirectory findCradle = findCradle' =<< liftIO getCurrentDirectory
findCradle' :: OutputOpts -> FilePath -> IO Cradle findCradle' :: (IOish m, GmOut m) => FilePath -> m Cradle
findCradle' oopts dir = run $ do findCradle' dir = run $
(stackCradle oopts dir `mplus` cabalCradle dir `mplus` sandboxCradle dir `mplus` plainCradle dir) msum [ stackCradle dir
, cabalCradle dir
, sandboxCradle dir
, plainCradle dir
]
where run a = fillTempDir =<< (fromJust <$> runMaybeT a) where run a = fillTempDir =<< (fromJust <$> runMaybeT a)
findSpecCradle :: FilePath -> IO Cradle findSpecCradle :: FilePath -> IO Cradle
@ -53,14 +57,14 @@ findSpecCradle dir = do
cleanupCradle :: Cradle -> IO () cleanupCradle :: Cradle -> IO ()
cleanupCradle crdl = removeDirectoryRecursive $ cradleTempDir crdl cleanupCradle crdl = removeDirectoryRecursive $ cradleTempDir crdl
fillTempDir :: MonadIO m => Cradle -> m Cradle fillTempDir :: IOish m => Cradle -> m Cradle
fillTempDir crdl = do fillTempDir crdl = do
tmpDir <- liftIO $ newTempDir (cradleRootDir crdl) tmpDir <- liftIO $ newTempDir (cradleRootDir crdl)
return crdl { cradleTempDir = tmpDir } return crdl { cradleTempDir = tmpDir }
cabalCradle :: FilePath -> MaybeT IO Cradle cabalCradle :: IOish m => FilePath -> MaybeT m Cradle
cabalCradle wdir = do cabalCradle wdir = do
cabalFile <- MaybeT $ findCabalFile wdir cabalFile <- MaybeT $ liftIO $ findCabalFile wdir
let cabalDir = takeDirectory cabalFile let cabalDir = takeDirectory cabalFile
@ -73,19 +77,19 @@ cabalCradle wdir = do
, cradleDistDir = "dist" , cradleDistDir = "dist"
} }
stackCradle :: OutputOpts -> FilePath -> MaybeT IO Cradle stackCradle :: (IOish m, GmOut m) => FilePath -> MaybeT m Cradle
stackCradle oopts wdir = do stackCradle wdir = do
cabalFile <- MaybeT $ findCabalFile wdir cabalFile <- MaybeT $ liftIO $ findCabalFile wdir
let cabalDir = takeDirectory cabalFile let cabalDir = takeDirectory cabalFile
_stackConfigFile <- MaybeT $ findStackConfigFile cabalDir _stackConfigFile <- MaybeT $ liftIO $ findStackConfigFile cabalDir
-- If dist/setup-config already exists the user probably wants to use cabal -- If dist/setup-config already exists the user probably wants to use cabal
-- rather than stack, or maybe that's just me ;) -- rather than stack, or maybe that's just me ;)
whenM (liftIO $ doesFileExist $ setupConfigPath "dist") $ mzero whenM (liftIO $ doesFileExist $ setupConfigPath "dist") $ mzero
distDir <- MaybeT $ getStackDistDir oopts cabalDir distDir <- MaybeT $ getStackDistDir cabalDir
return Cradle { return Cradle {
cradleProjectType = StackProject cradleProjectType = StackProject
@ -96,9 +100,9 @@ stackCradle oopts wdir = do
, cradleDistDir = distDir , cradleDistDir = distDir
} }
sandboxCradle :: FilePath -> MaybeT IO Cradle sandboxCradle :: IOish m => FilePath -> MaybeT m Cradle
sandboxCradle wdir = do sandboxCradle wdir = do
sbDir <- MaybeT $ findCabalSandboxDir wdir sbDir <- MaybeT $ liftIO $ findCabalSandboxDir wdir
return Cradle { return Cradle {
cradleProjectType = SandboxProject cradleProjectType = SandboxProject
, cradleCurrentDir = wdir , cradleCurrentDir = wdir
@ -108,7 +112,7 @@ sandboxCradle wdir = do
, cradleDistDir = "dist" , cradleDistDir = "dist"
} }
plainCradle :: FilePath -> MaybeT IO Cradle plainCradle :: IOish m => FilePath -> MaybeT m Cradle
plainCradle wdir = do plainCradle wdir = do
return $ Cradle { return $ Cradle {
cradleProjectType = PlainProject cradleProjectType = PlainProject

2
Language/Haskell/GhcMod/Debug.hs
View File

@ -39,7 +39,7 @@ debugInfo = do
fsep $ map text pkgOpts) fsep $ map text pkgOpts)
, "GHC System libraries: " ++ ghcLibDir , "GHC System libraries: " ++ ghcLibDir
, "GHC user options:\n" ++ render (nest 4 $ , "GHC user options:\n" ++ render (nest 4 $
fsep $ map text ghcUserOptions) fsep $ map text optGhcUserOptions)
] ++ cabal ] ++ cabal
cabalDebug :: IOish m => GhcModT m [String] cabalDebug :: IOish m => GhcModT m [String]

12
Language/Haskell/GhcMod/FillSig.hs
View File

@ -78,7 +78,7 @@ sig :: IOish m
-> GhcModT m String -> GhcModT m String
sig file lineNo colNo = sig file lineNo colNo =
runGmlT' [Left file] deferErrors $ ghandle fallback $ do runGmlT' [Left file] deferErrors $ ghandle fallback $ do
oopts <- outputOpts <$> options oopts <- outputOpts
style <- getStyle style <- getStyle
dflag <- G.getSessionDynFlags dflag <- G.getSessionDynFlags
modSum <- fileModSummaryWithMapping file modSum <- fileModSummaryWithMapping file
@ -97,7 +97,7 @@ sig file lineNo colNo =
in (rTy, fourInts loc, [initial ++ body]) in (rTy, fourInts loc, [initial ++ body])
where where
fallback (SomeException _) = do fallback (SomeException _) = do
oopts <- outputOpts <$> options oopts <- outputOpts
-- Code cannot be parsed by ghc module -- Code cannot be parsed by ghc module
-- Fallback: try to get information via haskell-src-exts -- Fallback: try to get information via haskell-src-exts
whenFound oopts (getSignatureFromHE file lineNo colNo) $ \x -> case x of whenFound oopts (getSignatureFromHE file lineNo colNo) $ \x -> case x of
@ -347,7 +347,7 @@ refine :: IOish m
refine file lineNo colNo (Expression expr) = refine file lineNo colNo (Expression expr) =
ghandle handler $ ghandle handler $
runGmlT' [Left file] deferErrors $ do runGmlT' [Left file] deferErrors $ do
oopts <- outputOpts <$> options oopts <- outputOpts
style <- getStyle style <- getStyle
dflag <- G.getSessionDynFlags dflag <- G.getSessionDynFlags
modSum <- fileModSummaryWithMapping file modSum <- fileModSummaryWithMapping file
@ -367,7 +367,7 @@ refine file lineNo colNo (Expression expr) =
handler (SomeException ex) = do handler (SomeException ex) = do
gmLog GmException "refining" $ gmLog GmException "refining" $
text "" $$ nest 4 (showDoc ex) text "" $$ nest 4 (showDoc ex)
emptyResult =<< outputOpts <$> options emptyResult =<< outputOpts
-- Look for the variable in the specified position -- Look for the variable in the specified position
findVar findVar
@ -424,7 +424,7 @@ auto :: IOish m
-> GhcModT m String -> GhcModT m String
auto file lineNo colNo = auto file lineNo colNo =
ghandle handler $ runGmlT' [Left file] deferErrors $ do ghandle handler $ runGmlT' [Left file] deferErrors $ do
oopts <- outputOpts <$> options oopts <- outputOpts
style <- getStyle style <- getStyle
dflag <- G.getSessionDynFlags dflag <- G.getSessionDynFlags
modSum <- fileModSummaryWithMapping file modSum <- fileModSummaryWithMapping file
@ -456,7 +456,7 @@ auto file lineNo colNo =
handler (SomeException ex) = do handler (SomeException ex) = do
gmLog GmException "auto-refining" $ gmLog GmException "auto-refining" $
text "" $$ nest 4 (showDoc ex) text "" $$ nest 4 (showDoc ex)
emptyResult =<< outputOpts <$> options emptyResult =<< outputOpts
-- Functions we do not want in completions -- Functions we do not want in completions
notWantedFuns :: [String] notWantedFuns :: [String]

6
Language/Haskell/GhcMod/HomeModuleGraph.hs
View File

@ -126,7 +126,7 @@ pruneUnreachable smp0 gmg@GmModuleGraph {..} = let
collapseMaybeSet :: Maybe (Set a) -> Set a collapseMaybeSet :: Maybe (Set a) -> Set a
collapseMaybeSet = maybe Set.empty id collapseMaybeSet = maybe Set.empty id
homeModuleGraph :: (IOish m, GmLog m, GmEnv m, GmState m) homeModuleGraph :: (IOish m, Gm m)
=> HscEnv -> Set ModulePath -> m GmModuleGraph => HscEnv -> Set ModulePath -> m GmModuleGraph
homeModuleGraph env smp = updateHomeModuleGraph env mempty smp smp homeModuleGraph env smp = updateHomeModuleGraph env mempty smp smp
@ -161,7 +161,7 @@ canonicalizeModuleGraph GmModuleGraph {..} = liftIO $ do
fmg (mp, smp) = liftM2 (,) (canonicalizeModulePath mp) (Set.fromList <$> mapM canonicalizeModulePath (Set.toList smp)) fmg (mp, smp) = liftM2 (,) (canonicalizeModulePath mp) (Set.fromList <$> mapM canonicalizeModulePath (Set.toList smp))
updateHomeModuleGraph :: (IOish m, GmLog m, GmEnv m, GmState m) updateHomeModuleGraph :: (IOish m, Gm m)
=> HscEnv => HscEnv
-> GmModuleGraph -> GmModuleGraph
-> Set ModulePath -- ^ Initial set of modules -> Set ModulePath -- ^ Initial set of modules
@ -187,7 +187,7 @@ mkModuleMap :: Set ModulePath -> Map ModuleName ModulePath
mkModuleMap smp = Map.fromList $ map (mpModule &&& id) $ Set.toList smp mkModuleMap smp = Map.fromList $ map (mpModule &&& id) $ Set.toList smp
updateHomeModuleGraph' updateHomeModuleGraph'
:: forall m. (MonadState S m, IOish m, GmLog m, GmEnv m, GmState m) :: forall m. (MonadState S m, IOish m, Gm m)
=> HscEnv => HscEnv
-> Set ModulePath -- ^ Initial set of modules -> Set ModulePath -- ^ Initial set of modules
-> m () -> m ()

5
Language/Haskell/GhcMod/Info.hs
View File

@ -3,7 +3,6 @@ module Language.Haskell.GhcMod.Info (
, types , types
) where ) where
import Control.Applicative
import Data.Function (on) import Data.Function (on)
import Data.List (sortBy) import Data.List (sortBy)
import Data.Maybe (catMaybes) import Data.Maybe (catMaybes)
@ -35,8 +34,8 @@ info :: IOish m
info file expr = info file expr =
ghandle handler $ ghandle handler $
runGmlT' [Left file] deferErrors $ runGmlT' [Left file] deferErrors $
withInteractiveContext $ withInteractiveContext $ do
convert . outputOpts <$> options <*> body convert' =<< body
where where
handler (SomeException ex) = do handler (SomeException ex) = do
gmLog GmException "info" $ text "" $$ nest 4 (showDoc ex) gmLog GmException "info" $ text "" $$ nest 4 (showDoc ex)

2
Language/Haskell/GhcMod/Lint.hs
View File

@ -20,7 +20,7 @@ lint :: IOish m
lint file = do lint file = do
opt <- options opt <- options
withMappedFile file $ \tempfile -> withMappedFile file $ \tempfile ->
liftIO (hlint $ tempfile : "--quiet" : hlintOpts opt) liftIO (hlint $ tempfile : "--quiet" : optHlintOpts opt)
>>= mapM (replaceFileName tempfile) >>= mapM (replaceFileName tempfile)
>>= ghandle handler . pack >>= ghandle handler . pack
where where

5
Language/Haskell/GhcMod/Logger.hs
View File

@ -30,7 +30,6 @@ import Language.Haskell.GhcMod.DynFlags (withDynFlags)
import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Error
import Language.Haskell.GhcMod.Utils (mkRevRedirMapFunc) import Language.Haskell.GhcMod.Utils (mkRevRedirMapFunc)
import Language.Haskell.GhcMod.Types
import qualified Language.Haskell.GhcMod.Gap as Gap import qualified Language.Haskell.GhcMod.Gap as Gap
import Prelude import Prelude
@ -76,13 +75,13 @@ appendLogRef rfm df (LogRef ref) _ sev src st msg = do
-- | Logged messages are returned as 'String'. -- | Logged messages are returned as 'String'.
-- Right is success and Left is failure. -- Right is success and Left is failure.
withLogger :: (GmGhc m, GmEnv m, GmState m) withLogger :: (GmGhc m, GmEnv m, GmOut m, GmState m)
=> (DynFlags -> DynFlags) => (DynFlags -> DynFlags)
-> m a -> m a
-> m (Either String (String, a)) -> m (Either String (String, a))
withLogger f action = do withLogger f action = do
env <- G.getSession env <- G.getSession
oopts <- outputOpts <$> options oopts <- outputOpts
let conv = convert oopts let conv = convert oopts
eres <- withLogger' env $ \setDf -> eres <- withLogger' env $ \setDf ->
withDynFlags (f . setDf) action withDynFlags (f . setDf) action

4
Language/Haskell/GhcMod/Logging.hs
View File

@ -65,7 +65,7 @@ decreaseLogLevel l = pred l
-- True -- True
-- >>> Just GmDebug <= Just GmException -- >>> Just GmDebug <= Just GmException
-- False -- False
gmLog :: (MonadIO m, GmLog m, GmEnv m) => GmLogLevel -> String -> Doc -> m () gmLog :: (MonadIO m, GmLog m, GmOut m) => GmLogLevel -> String -> Doc -> m ()
gmLog level loc' doc = do gmLog level loc' doc = do
GhcModLog { gmLogLevel = Just level' } <- gmlHistory GhcModLog { gmLogLevel = Just level' } <- gmlHistory
@ -78,7 +78,7 @@ gmLog level loc' doc = do
gmlJournal (GhcModLog Nothing (Last Nothing) [(level, loc', msgDoc)]) gmlJournal (GhcModLog Nothing (Last Nothing) [(level, loc', msgDoc)])
gmVomit :: (MonadIO m, GmLog m, GmEnv m) => String -> Doc -> String -> m () gmVomit :: (MonadIO m, GmLog m, GmOut m, GmEnv m) => String -> Doc -> String -> m ()
gmVomit filename doc content = do gmVomit filename doc content = do
gmLog GmVomit "" $ doc <+>: text content gmLog GmVomit "" $ doc <+>: text content

6
Language/Haskell/GhcMod/Modules.hs
View File

@ -14,13 +14,13 @@ import qualified GHC as G
---------------------------------------------------------------- ----------------------------------------------------------------
-- | Listing installed modules. -- | Listing installed modules.
modules :: (IOish m, GmEnv m, GmState m, GmLog m) => m String modules :: (IOish m, Gm m) => m String
modules = do modules = do
Options { detailed } <- options Options { optDetailed } <- options
df <- runGmPkgGhc G.getSessionDynFlags df <- runGmPkgGhc G.getSessionDynFlags
let mns = listVisibleModuleNames df let mns = listVisibleModuleNames df
pmnss = map (first moduleNameString) $ zip mns (modulePkg df `map` mns) pmnss = map (first moduleNameString) $ zip mns (modulePkg df `map` mns)
convert' $ nub [ if detailed then pkg ++ " " ++ mn else mn convert' $ nub [ if optDetailed then pkg ++ " " ++ mn else mn
| (mn, pkgs) <- pmnss, pkg <- pkgs ] | (mn, pkgs) <- pmnss, pkg <- pkgs ]
where where
modulePkg df = lookupModulePackageInAllPackages df modulePkg df = lookupModulePackageInAllPackages df

39
Language/Haskell/GhcMod/Monad.hs
View File

@ -16,7 +16,8 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module Language.Haskell.GhcMod.Monad ( module Language.Haskell.GhcMod.Monad (
runGhcModT runGmOutT
, runGhcModT
, runGhcModT' , runGhcModT'
, runGhcModT'' , runGhcModT''
, hoistGhcModT , hoistGhcModT
@ -51,24 +52,22 @@ import Exception (ExceptionMonad(..))
import System.Directory import System.Directory
import Prelude import Prelude
withCradle :: IOish m => OutputOpts -> FilePath -> (Cradle -> m a) -> m a withCradle :: (IOish m, GmOut m) => FilePath -> (Cradle -> m a) -> m a
withCradle oopts cradledir f = withCradle cradledir f =
gbracket (liftIO $ findCradle' oopts cradledir) (liftIO . cleanupCradle) f gbracket (findCradle' cradledir) (liftIO . cleanupCradle) f
withGhcModEnv :: IOish m => FilePath -> Options -> (GhcModEnv -> m a) -> m a withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> (GhcModEnv -> m a) -> m a
withGhcModEnv dir opts f = withGhcModEnv dir opts f =
withCradle (outputOpts opts) dir (withGhcModEnv' opts f) withCradle dir (withGhcModEnv' opts f)
withGhcModEnv' :: IOish m => Options -> (GhcModEnv -> m a) -> Cradle -> m a withGhcModEnv' :: (IOish m, GmOut m) => Options -> (GhcModEnv -> m a) -> Cradle -> m a
withGhcModEnv' opts f crdl = do withGhcModEnv' opts f crdl = do
olddir <- liftIO getCurrentDirectory olddir <- liftIO getCurrentDirectory
c <- liftIO newChan gbracket_ setup (teardown olddir) (f $ GhcModEnv opts crdl)
let outp = case linePrefix $ outputOpts opts of
Just _ -> GmOutputChan c
Nothing -> GmOutputStdio
gbracket_ (setup c) (teardown olddir) (f $ GhcModEnv opts crdl outp)
where where
setup c = liftIO $ do setup = do
c <- gmoChan <$> gmoAsk
liftIO $ do
setCurrentDirectory $ cradleRootDir crdl setCurrentDirectory $ cradleRootDir crdl
forkIO $ stdoutGateway c forkIO $ stdoutGateway c
@ -92,10 +91,12 @@ runGhcModT' :: IOish m
-> Options -> Options
-> GhcModT m a -> GhcModT m a
-> m (Either GhcModError a, GhcModLog) -> m (Either GhcModError a, GhcModLog)
runGhcModT' dir opt action = liftIO (canonicalizePath dir) >>= \dir' -> runGhcModT' dir opt action = liftIO (canonicalizePath dir) >>= \dir' -> do
gmo <- GhcModOut (optOutput opt) <$> liftIO newChan
runGmOutT gmo $
withGhcModEnv dir' opt $ \env -> withGhcModEnv dir' opt $ \env ->
first (fst <$>) <$> runGhcModT'' env defaultGhcModState first (fst <$>) <$> runGhcModT'' env defaultGhcModState
(gmSetLogLevel (logLevel $ outputOpts opt) >> action) (gmSetLogLevel (ooptLogLevel $ optOutput opt) >> action)
-- | @hoistGhcModT result@. Embed a GhcModT computation's result into a GhcModT -- | @hoistGhcModT result@. Embed a GhcModT computation's result into a GhcModT
-- computation. Note that if the computation that returned @result@ modified the -- computation. Note that if the computation that returned @result@ modified the
@ -108,6 +109,7 @@ hoistGhcModT (r,l) = do
Left e -> throwError e Left e -> throwError e
Right a -> return a Right a -> return a
-- | Run a computation inside @GhcModT@ providing the RWST environment and -- | Run a computation inside @GhcModT@ providing the RWST environment and
-- initial state. This is a low level function, use it only if you know what to -- initial state. This is a low level function, use it only if you know what to
-- do with 'GhcModEnv' and 'GhcModState'. -- do with 'GhcModEnv' and 'GhcModState'.
@ -117,6 +119,9 @@ runGhcModT'' :: IOish m
=> GhcModEnv => GhcModEnv
-> GhcModState -> GhcModState
-> GhcModT m a -> GhcModT m a
-> m (Either GhcModError (a, GhcModState), GhcModLog) -> GmOutT m (Either GhcModError (a, GhcModState), GhcModLog)
runGhcModT'' r s a = do runGhcModT'' r s a = do
flip runReaderT r $ runJournalT $ runErrorT $ runStateT (unGhcModT a) s flip runReaderT r $ runJournalT $ runErrorT $ runStateT (unGmT a) s
runGmOutT :: IOish m => GhcModOut -> GmOutT m a -> m a
runGmOutT gmo ma = flip runReaderT gmo $ unGmOutT ma

220
Language/Haskell/GhcMod/Monad/Types.hs
View File

@ -22,7 +22,9 @@
module Language.Haskell.GhcMod.Monad.Types ( module Language.Haskell.GhcMod.Monad.Types (
-- * Monad Types -- * Monad Types
GhcModT(..) GhcModT
, GmOutT(..)
, GmT(..)
, GmlT(..) , GmlT(..)
, LightGhc(..) , LightGhc(..)
, GmGhc , GmGhc
@ -43,8 +45,10 @@ module Language.Haskell.GhcMod.Monad.Types (
, GmEnv(..) , GmEnv(..)
, GmState(..) , GmState(..)
, GmLog(..) , GmLog(..)
, GmOut(..)
, cradle , cradle
, options , options
, outputOpts
, withOptions , withOptions
, getCompilerMode , getCompilerMode
, setCompilerMode , setCompilerMode
@ -113,17 +117,25 @@ import Prelude
import qualified MonadUtils as GHC (MonadIO(..)) import qualified MonadUtils as GHC (MonadIO(..))
-- | This is basically a newtype wrapper around 'StateT', 'ErrorT', 'JournalT' type GhcModT m = GmT (GmOutT m)
-- and 'ReaderT' with custom instances for 'GhcMonad' and it's constraints that
-- means you can run (almost) all functions from the GHC API on top of 'GhcModT' newtype GmOutT m a = GmOutT {
-- transparently. unGmOutT :: ReaderT GhcModOut m a
-- } deriving ( Functor
-- The inner monad @m@ should have instances for 'MonadIO' and , Applicative
-- 'MonadBaseControl' 'IO', in the common case this is simply 'IO'. Most @mtl@ , Alternative
-- monads already have 'MonadBaseControl' 'IO' instances, see the , Monad
-- @monad-control@ package. , MonadPlus
newtype GhcModT m a = GhcModT { , MonadTrans
unGhcModT :: StateT GhcModState , MTL.MonadIO
#if DIFFERENT_MONADIO
, GHC.MonadIO
#endif
, GmLog
)
newtype GmT m a = GmT {
unGmT :: StateT GhcModState
(ErrorT GhcModError (ErrorT GhcModError
(JournalT GhcModLog (JournalT GhcModLog
(ReaderT GhcModEnv m) ) ) a (ReaderT GhcModEnv m) ) ) a
@ -145,7 +157,6 @@ newtype GmlT m a = GmlT { unGmlT :: GhcModT m a }
, Alternative , Alternative
, Monad , Monad
, MonadPlus , MonadPlus
, MonadTrans
, MTL.MonadIO , MTL.MonadIO
#if DIFFERENT_MONADIO #if DIFFERENT_MONADIO
, GHC.MonadIO , GHC.MonadIO
@ -166,6 +177,9 @@ newtype LightGhc a = LightGhc { unLightGhc :: ReaderT (IORef HscEnv) IO a }
#endif #endif
) )
--------------------------------------------------
-- Miscellaneous instances
#if DIFFERENT_MONADIO #if DIFFERENT_MONADIO
instance MTL.MonadIO m => GHC.MonadIO (ReaderT x m) where instance MTL.MonadIO m => GHC.MonadIO (ReaderT x m) where
liftIO = MTL.liftIO liftIO = MTL.liftIO
@ -191,13 +205,26 @@ instance MonadIO m => MonadIO (JournalT x m) where
liftIO = MTL.liftIO liftIO = MTL.liftIO
instance MonadIO m => MonadIO (MaybeT m) where instance MonadIO m => MonadIO (MaybeT m) where
liftIO = MTL.liftIO liftIO = MTL.liftIO
instance MonadIOC m => MonadIO (GhcModT m) where instance MonadIOC m => MonadIO (GmOutT m) where
liftIO = MTL.liftIO
instance MonadIOC m => MonadIO (GmT m) where
liftIO = MTL.liftIO liftIO = MTL.liftIO
instance MonadIOC m => MonadIO (GmlT m) where instance MonadIOC m => MonadIO (GmlT m) where
liftIO = MTL.liftIO liftIO = MTL.liftIO
instance MonadIO LightGhc where instance MonadIO LightGhc where
liftIO = MTL.liftIO 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 class Monad m => GmEnv m where
gmeAsk :: m GhcModEnv gmeAsk :: m GhcModEnv
gmeAsk = gmeReader id gmeAsk = gmeReader id
@ -208,18 +235,32 @@ class Monad m => GmEnv m where
gmeLocal :: (GhcModEnv -> GhcModEnv) -> m a -> m a gmeLocal :: (GhcModEnv -> GhcModEnv) -> m a -> m a
{-# MINIMAL (gmeAsk | gmeReader), gmeLocal #-} {-# MINIMAL (gmeAsk | gmeReader), gmeLocal #-}
type Gm m = (GmEnv m, GmState m, GmLog m) instance Monad m => GmEnv (GmT m) where
gmeAsk = GmT ask
gmeReader = GmT . reader
gmeLocal f a = GmT $ local f (unGmT a)
instance Monad m => GmEnv (GhcModT m) where instance GmEnv m => GmEnv (GmOutT m) where
gmeAsk = GhcModT ask gmeAsk = lift gmeAsk
gmeReader = GhcModT . reader gmeReader = lift . gmeReader
gmeLocal f a = GhcModT $ local f (unGhcModT a) gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma))
instance GmEnv m => GmEnv (StateT s m) where instance GmEnv m => GmEnv (StateT s m) where
gmeAsk = lift gmeAsk gmeAsk = lift gmeAsk
gmeReader = lift . gmeReader gmeReader = lift . gmeReader
gmeLocal f (StateT a) = StateT $ \s -> gmeLocal f (a s) 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 class Monad m => GmState m where
gmsGet :: m GhcModState gmsGet :: m GhcModState
gmsGet = gmsState (\s -> (s, s)) gmsGet = gmsState (\s -> (s, s))
@ -245,16 +286,17 @@ instance Monad m => GmState (StateT GhcModState m) where
gmsPut = put gmsPut = put
gmsState = state gmsState = state
instance Monad m => GmState (GhcModT m) where instance Monad m => GmState (GmT m) where
gmsGet = GhcModT get gmsGet = GmT get
gmsPut = GhcModT . put gmsPut = GmT . put
gmsState = GhcModT . state gmsState = GmT . state
instance GmState m => GmState (MaybeT m) where instance GmState m => GmState (MaybeT m) where
gmsGet = MaybeT $ Just `liftM` gmsGet gmsGet = MaybeT $ Just `liftM` gmsGet
gmsPut = MaybeT . (Just `liftM`) . gmsPut gmsPut = MaybeT . (Just `liftM`) . gmsPut
gmsState = MaybeT . (Just `liftM`) . gmsState gmsState = MaybeT . (Just `liftM`) . gmsState
-- GmLog -----------------------------------------
class Monad m => GmLog m where class Monad m => GmLog m where
gmlJournal :: GhcModLog -> m () gmlJournal :: GhcModLog -> m ()
gmlHistory :: m GhcModLog gmlHistory :: m GhcModLog
@ -265,10 +307,10 @@ instance Monad m => GmLog (JournalT GhcModLog m) where
gmlHistory = history gmlHistory = history
gmlClear = clear gmlClear = clear
instance Monad m => GmLog (GhcModT m) where instance Monad m => GmLog (GmT m) where
gmlJournal = GhcModT . lift . lift . journal gmlJournal = GmT . lift . lift . journal
gmlHistory = GhcModT $ lift $ lift history gmlHistory = GmT $ lift $ lift history
gmlClear = GhcModT $ lift $ lift clear gmlClear = GmT $ lift $ lift clear
instance (Monad m, GmLog m) => GmLog (ReaderT r m) where instance (Monad m, GmLog m) => GmLog (ReaderT r m) where
gmlJournal = lift . gmlJournal gmlJournal = lift . gmlJournal
@ -280,19 +322,32 @@ instance (Monad m, GmLog m) => GmLog (StateT s m) where
gmlHistory = lift gmlHistory gmlHistory = lift gmlHistory
gmlClear = lift gmlClear gmlClear = lift gmlClear
instance Monad m => MonadJournal GhcModLog (GhcModT m) where -- GmOut -----------------------------------------
journal !w = GhcModT $ lift $ lift $ (journal w) class Monad m => GmOut m where
history = GhcModT $ lift $ lift $ history gmoAsk :: m GhcModOut
clear = GhcModT $ lift $ lift $ clear
instance MonadTrans GhcModT where instance Monad m => GmOut (GmOutT m) where
lift = GhcModT . lift . lift . lift . lift gmoAsk = GmOutT ask
instance forall r m. MonadReader r m => MonadReader r (GhcModT m) where 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 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)) local f ma = gmLiftWithInner (\run -> local f (run ma))
ask = gmLiftInner ask ask = gmLiftInner ask
instance (Monoid w, MonadWriter w m) => MonadWriter w (GhcModT m) where instance (Monoid w, MonadWriter w m) => MonadWriter w (GmT m) where
tell = gmLiftInner . tell tell = gmLiftInner . tell
listen ma = listen ma =
liftWith (\run -> listen (run ma)) >>= \(sta, w) -> liftWith (\run -> listen (run ma)) >>= \(sta, w) ->
@ -300,63 +355,91 @@ instance (Monoid w, MonadWriter w m) => MonadWriter w (GhcModT m) where
pass maww = maww >>= gmLiftInner . pass . return pass maww = maww >>= gmLiftInner . pass . return
instance MonadState s m => MonadState s (GhcModT m) where instance MonadState s m => MonadState s (GmT m) where
get = GhcModT $ lift $ lift $ lift get get = GmT $ lift $ lift $ lift get
put = GhcModT . lift . lift . lift . put put = GmT . lift . lift . lift . put
state = GhcModT . lift . lift . lift . state 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 instance (MonadBaseControl IO m) => MonadBase IO (GmlT m) where
liftBase = GmlT . liftBase liftBase = GmlT . liftBase
instance (MonadBaseControl IO m) => MonadBaseControl IO (GmlT m) where instance (MonadBaseControl IO m) => MonadBaseControl IO (GmlT m) where
type StM (GmlT m) a = StM (GhcModT m) a type StM (GmlT m) a = StM (GmT m) a
liftBaseWith = defaultLiftBaseWith liftBaseWith = defaultLiftBaseWith
restoreM = defaultRestoreM restoreM = defaultRestoreM
{-# INLINE liftBaseWith #-} {-# INLINE liftBaseWith #-}
{-# INLINE restoreM #-} {-# INLINE restoreM #-}
instance MonadTransControl GmlT where instance MonadTransControl GmlT where
type StT GmlT a = StT GhcModT a type StT GmlT a = StT GmT a
liftWith = defaultLiftWith GmlT unGmlT liftWith f = GmlT $
restoreT = defaultRestoreT GmlT liftWith $ \runGm ->
liftWith $ \runEnv ->
f $ \ma -> runEnv $ runGm $ unGmlT ma
restoreT = GmlT . restoreT . restoreT
instance (MonadBaseControl IO m) => MonadBase IO (GhcModT m) where
liftBase = GhcModT . liftBase
instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where -- GmT ------------------------------------------
type StM (GhcModT m) a =
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 StM (StateT GhcModState
(ErrorT GhcModError (ErrorT GhcModError
(JournalT GhcModLog (JournalT GhcModLog
(ReaderT GhcModEnv m) ) ) ) a (ReaderT GhcModEnv m) ) ) ) a
liftBaseWith f = GmT (liftBaseWith $ \runInBase ->
liftBaseWith f = GhcModT (liftBaseWith $ \runInBase -> f $ runInBase . unGmT)
f $ runInBase . unGhcModT) restoreM = GmT . restoreM
restoreM = GhcModT . restoreM
{-# INLINE liftBaseWith #-} {-# INLINE liftBaseWith #-}
{-# INLINE restoreM #-} {-# INLINE restoreM #-}
instance MonadTransControl GhcModT where instance MonadTransControl GmT where
type StT GhcModT a = (Either GhcModError (a, GhcModState), GhcModLog) type StT GmT a = (Either GhcModError (a, GhcModState), GhcModLog)
liftWith f = GmT $
liftWith f = GhcModT $
liftWith $ \runS -> liftWith $ \runS ->
liftWith $ \runE -> liftWith $ \runE ->
liftWith $ \runJ -> liftWith $ \runJ ->
liftWith $ \runR -> liftWith $ \runR ->
f $ \ma -> runR $ runJ $ runE $ runS $ unGhcModT ma f $ \ma -> runR $ runJ $ runE $ runS $ unGmT ma
restoreT = GhcModT . restoreT . restoreT . restoreT . restoreT restoreT = GmT . restoreT . restoreT . restoreT . restoreT
{-# INLINE liftWith #-} {-# INLINE liftWith #-}
{-# INLINE restoreT #-} {-# INLINE restoreT #-}
gmLiftInner :: Monad m => m a -> GhcModT m a gmLiftInner :: Monad m => m a -> GmT m a
gmLiftInner = GhcModT . lift . lift . lift . lift gmLiftInner = GmT . lift . lift . lift . lift
gmLiftWithInner :: (MonadTransControl t, Monad m, Monad (t m)) gmLiftWithInner :: (MonadTransControl t, Monad m, Monad (t m))
=> (Run t -> m (StT t a)) -> t m a => (Run t -> m (StT t a)) -> t m a
gmLiftWithInner f = liftWith f >>= restoreT . return gmLiftWithInner f = liftWith f >>= restoreT . return
--------------------------------------------------
-- GHC API instances -----------------------------
-- GHC cannot prove the following instances to be decidable automatically using -- GHC cannot prove the following instances to be decidable automatically using
-- the FlexibleContexts extension as they violate the second Paterson Condition, -- the FlexibleContexts extension as they violate the second Paterson Condition,
-- namely that: The assertion has fewer constructors and variables (taken -- namely that: The assertion has fewer constructors and variables (taken
@ -369,8 +452,6 @@ instance (MonadIO m, MonadBaseControl IO m) => GhcMonad (GmlT m) where
getSession = gmlGetSession getSession = gmlGetSession
setSession = gmlSetSession setSession = gmlSetSession
-- ---------------------------------------------------------------------
gmlGetSession :: (MonadIO m, MonadBaseControl IO m) => GmlT m HscEnv gmlGetSession :: (MonadIO m, MonadBaseControl IO m) => GmlT m HscEnv
gmlGetSession = do gmlGetSession = do
ref <- gmgsSession . fromJust . gmGhcSession <$> gmsGet ref <- gmgsSession . fromJust . gmGhcSession <$> gmsGet
@ -381,7 +462,6 @@ gmlSetSession a = do
ref <- gmgsSession . fromJust . gmGhcSession <$> gmsGet ref <- gmgsSession . fromJust . gmGhcSession <$> gmsGet
GHC.liftIO $ flip writeIORef a ref GHC.liftIO $ flip writeIORef a ref
-- ---------------------------------------------------------------------
instance GhcMonad LightGhc where instance GhcMonad LightGhc where
getSession = (GHC.liftIO . readIORef) =<< LightGhc ask getSession = (GHC.liftIO . readIORef) =<< LightGhc ask
setSession a = (GHC.liftIO . flip writeIORef a) =<< LightGhc ask setSession a = (GHC.liftIO . flip writeIORef a) =<< LightGhc ask
@ -394,7 +474,14 @@ instance HasDynFlags LightGhc where
getDynFlags = hsc_dflags <$> getSession getDynFlags = hsc_dflags <$> getSession
#endif #endif
instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (GhcModT m) where instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (GmOutT m) where
gcatch act handler = control $ \run ->
run act `gcatch` (run . handler)
gmask = liftBaseOp gmask . liftRestore
where liftRestore f r = f $ liftBaseOp_ r
instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (GmT m) where
gcatch act handler = control $ \run -> gcatch act handler = control $ \run ->
run act `gcatch` (run . handler) run act `gcatch` (run . handler)
@ -437,6 +524,9 @@ instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (ReaderT s m) wher
options :: GmEnv m => m Options options :: GmEnv m => m Options
options = gmOptions `liftM` gmeAsk options = gmOptions `liftM` gmeAsk
outputOpts :: GmOut m => m OutputOpts
outputOpts = gmoOptions `liftM` gmoAsk
cradle :: GmEnv m => m Cradle cradle :: GmEnv m => m Cradle
cradle = gmCradle `liftM` gmeAsk cradle = gmCradle `liftM` gmeAsk

84
Language/Haskell/GhcMod/Output.hs
View File

@ -25,7 +25,6 @@ module Language.Haskell.GhcMod.Output (
, gmReadProcess , gmReadProcess
, gmUnsafePutStr , gmUnsafePutStr
, gmUnsafeErrStr , gmUnsafeErrStr
, gmUnsafeReadProcess
, stdoutGateway , stdoutGateway
) where ) where
@ -64,38 +63,46 @@ toGmLines "" = GmLines GmPartial ""
toGmLines s | isNewline (last s) = GmLines GmTerminated s toGmLines s | isNewline (last s) = GmLines GmTerminated s
toGmLines s = GmLines GmPartial s toGmLines s = GmLines GmPartial s
outputFns :: (GmEnv m, MonadIO m') outputFns :: (GmOut m, MonadIO m')
=> m (GmLines String -> m' (), GmLines String -> m' ()) => m (GmLines String -> m' (), GmLines String -> m' ())
outputFns = do outputFns =
oopts <- outputOpts `liftM` options outputFns' <$> gmoAsk
env <- gmeAsk
return $ outputFns' oopts (gmOutput env)
outputFns' :: MonadIO m' pfxFns :: Maybe (String, String) -> (GmLines String -> GmLines String, GmLines String -> GmLines String)
=> OutputOpts pfxFns lpfx = case lpfx of
-> GmOutput
-> (GmLines String -> m' (), GmLines String -> m' ())
outputFns' opts output = let
OutputOpts {..} = opts
pfx f = withLines f
outPfx, errPfx :: GmLines String -> GmLines String
(outPfx, errPfx) =
case linePrefix of
Nothing -> ( id, id ) Nothing -> ( id, id )
Just (op, ep) -> ( fmap $ pfx (op++), fmap $ pfx (ep++) ) Just (op, ep) -> ( fmap $ pfx (op++), fmap $ pfx (ep++) )
where
pfx f = withLines f
stdioOutputFns :: MonadIO m => Maybe (String, String) -> (GmLines String -> m (), GmLines String -> m ())
stdioOutputFns lpfx = let
(outPfx, errPfx) = pfxFns lpfx
in in
case output of
GmOutputStdio ->
( liftIO . putStr . unGmLine . outPfx ( liftIO . putStr . unGmLine . outPfx
, liftIO . hPutStr stderr . unGmLine . errPfx) , liftIO . hPutStr stderr . unGmLine . errPfx)
GmOutputChan c ->
( liftIO . writeChan c . (,) GmOut . outPfx chanOutputFns :: MonadIO m
, liftIO . writeChan c . (,) GmErr .errPfx) => Chan (GmStream, GmLines String)
-> Maybe (String, String)
-> (GmLines String -> m (), GmLines String -> m ())
chanOutputFns c lpfx = let
(outPfx, errPfx) = pfxFns lpfx
in
( liftIO . writeChan c . (,) GmOutStream . outPfx
, liftIO . writeChan c . (,) GmErrStream . errPfx)
outputFns' ::
MonadIO m => GhcModOut -> (GmLines String -> m (), GmLines String -> m ())
outputFns' (GhcModOut oopts c) = let
OutputOpts {..} = oopts
in
case ooptLinePrefix of
Nothing -> stdioOutputFns ooptLinePrefix
Just _ -> chanOutputFns c ooptLinePrefix
gmPutStr, gmPutStrLn, gmErrStr, gmErrStrLn gmPutStr, gmPutStrLn, gmErrStr, gmErrStrLn
:: (MonadIO m, GmEnv m) => String -> m () :: (MonadIO m, GmOut m) => String -> m ()
gmPutStr str = do gmPutStr str = do
putOut <- fst `liftM` outputFns putOut <- fst `liftM` outputFns
@ -111,21 +118,16 @@ gmErrStr str = do
-- | Only use these when you're sure there are no other writers on stdout -- | Only use these when you're sure there are no other writers on stdout
gmUnsafePutStr, gmUnsafeErrStr gmUnsafePutStr, gmUnsafeErrStr
:: MonadIO m => OutputOpts -> String -> m () :: MonadIO m => OutputOpts -> String -> m ()
gmUnsafePutStr oopts = (fst $ outputFns' oopts GmOutputStdio) . toGmLines gmUnsafePutStr oopts = (fst $ stdioOutputFns (ooptLinePrefix oopts)) . toGmLines
gmUnsafeErrStr oopts = (snd $ outputFns' oopts GmOutputStdio) . toGmLines gmUnsafeErrStr oopts = (snd $ stdioOutputFns (ooptLinePrefix oopts)) . toGmLines
gmUnsafeReadProcess :: OutputOpts -> FilePath -> [String] -> String -> IO String gmReadProcess :: GmOut m => m (FilePath -> [String] -> String -> IO String)
gmUnsafeReadProcess oopts =
readProcessStderrChan' (snd $ outputFns' oopts GmOutputStdio)
gmReadProcess :: GmEnv m => m (FilePath -> [String] -> String -> IO String)
gmReadProcess = do gmReadProcess = do
GhcModEnv {..} <- gmeAsk GhcModOut {..} <- gmoAsk
case gmOutput of case ooptLinePrefix gmoOptions of
GmOutputChan _ -> Just _ ->
readProcessStderrChan readProcessStderrChan
GmOutputStdio -> Nothing ->
return $ readProcess return $ readProcess
stdoutGateway :: Chan (GmStream, GmLines String) -> IO () stdoutGateway :: Chan (GmStream, GmLines String) -> IO ()
@ -136,8 +138,8 @@ stdoutGateway chan = go ("", "")
case ty of case ty of
GmTerminated -> GmTerminated ->
case stream of case stream of
GmOut -> putStr (obuf++l) >> hFlush stdout >> go ("", ebuf) GmOutStream -> putStr (obuf++l) >> hFlush stdout >> go ("", ebuf)
GmErr -> putStr (ebuf++l) >> hFlush stdout >> go (obuf, "") GmErrStream -> putStr (ebuf++l) >> hFlush stdout >> go (obuf, "")
GmPartial -> case reverse $ lines l of GmPartial -> case reverse $ lines l of
[] -> go buf [] -> go buf
[x] -> go (appendBuf stream buf x) [x] -> go (appendBuf stream buf x)
@ -146,12 +148,12 @@ stdoutGateway chan = go ("", "")
hFlush stdout hFlush stdout
go (appendBuf stream buf x) go (appendBuf stream buf x)
appendBuf GmOut (obuf, ebuf) s = (obuf++s, ebuf) appendBuf GmOutStream (obuf, ebuf) s = (obuf++s, ebuf)
appendBuf GmErr (obuf, ebuf) s = (obuf, ebuf++s) appendBuf GmErrStream (obuf, ebuf) s = (obuf, ebuf++s)
readProcessStderrChan :: readProcessStderrChan ::
GmEnv m => m (FilePath -> [String] -> String -> IO String) GmOut m => m (FilePath -> [String] -> String -> IO String)
readProcessStderrChan = do readProcessStderrChan = do
(_, e :: GmLines String -> IO ()) <- outputFns (_, e :: GmLines String -> IO ()) <- outputFns
return $ readProcessStderrChan' e return $ readProcessStderrChan' e

33
Language/Haskell/GhcMod/PathsAndFiles.hs
View File

@ -24,6 +24,7 @@ import Control.Applicative
import Control.Exception as E import Control.Exception as E
import Control.Monad import Control.Monad
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Class
import Data.List import Data.List
import Data.Char import Data.Char
import Data.Maybe import Data.Maybe
@ -35,6 +36,7 @@ import System.Process
import System.Info.Extra import System.Info.Extra
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Caching import Language.Haskell.GhcMod.Caching
import Language.Haskell.GhcMod.Output import Language.Haskell.GhcMod.Output
import qualified Language.Haskell.GhcMod.Utils as U import qualified Language.Haskell.GhcMod.Utils as U
@ -77,22 +79,22 @@ findCabalFile dir = do
findStackConfigFile :: FilePath -> IO (Maybe FilePath) findStackConfigFile :: FilePath -> IO (Maybe FilePath)
findStackConfigFile dir = mightExist (dir </> "stack.yaml") findStackConfigFile dir = mightExist (dir </> "stack.yaml")
getStackDistDir :: OutputOpts -> FilePath -> IO (Maybe FilePath) getStackDistDir :: (IOish m, GmOut m) => FilePath -> m (Maybe FilePath)
getStackDistDir oopts projdir = U.withDirectory_ projdir $ runMaybeT $ do getStackDistDir projdir = U.withDirectory_ projdir $ runMaybeT $ do
takeWhile (/='\n') <$> readStack oopts ["path", "--dist-dir"] takeWhile (/='\n') <$> readStack ["path", "--dist-dir"]
getStackGhcPath :: OutputOpts -> FilePath -> IO (Maybe FilePath) getStackGhcPath :: (IOish m, GmOut m) => FilePath -> m (Maybe FilePath)
getStackGhcPath oopts = findExecutablesInStackBinPath oopts "ghc" getStackGhcPath = findExecutablesInStackBinPath "ghc"
getStackGhcPkgPath :: OutputOpts -> FilePath -> IO (Maybe FilePath) getStackGhcPkgPath :: (IOish m, GmOut m) => FilePath -> m (Maybe FilePath)
getStackGhcPkgPath oopts = findExecutablesInStackBinPath oopts "ghc-pkg" getStackGhcPkgPath = findExecutablesInStackBinPath "ghc-pkg"
findExecutablesInStackBinPath :: OutputOpts -> String -> FilePath -> IO (Maybe FilePath) findExecutablesInStackBinPath :: (IOish m, GmOut m) => String -> FilePath -> m (Maybe FilePath)
findExecutablesInStackBinPath oopts exe projdir = findExecutablesInStackBinPath exe projdir =
U.withDirectory_ projdir $ runMaybeT $ do U.withDirectory_ projdir $ runMaybeT $ do
path <- splitSearchPath . takeWhile (/='\n') path <- splitSearchPath . takeWhile (/='\n')
<$> readStack oopts ["path", "--bin-path"] <$> readStack ["path", "--bin-path"]
MaybeT $ listToMaybe <$> findExecutablesInDirectories' path exe MaybeT $ liftIO $ listToMaybe <$> findExecutablesInDirectories' path exe
findExecutablesInDirectories' :: [FilePath] -> String -> IO [FilePath] findExecutablesInDirectories' :: [FilePath] -> String -> IO [FilePath]
findExecutablesInDirectories' path binary = findExecutablesInDirectories' path binary =
@ -103,11 +105,12 @@ findExecutablesInDirectories' path binary =
exeExtension = if isWindows then "exe" else "" exeExtension = if isWindows then "exe" else ""
readStack :: OutputOpts -> [String] -> MaybeT IO String readStack :: (IOish m, GmOut m) => [String] -> MaybeT m String
readStack oopts args = do readStack args = do
stack <- MaybeT $ findExecutable "stack" stack <- MaybeT $ liftIO $ findExecutable "stack"
readProc <- lift gmReadProcess
liftIO $ flip E.catch (\(e :: IOError) -> throw $ GMEStackBootrap $ show e) $ do liftIO $ flip E.catch (\(e :: IOError) -> throw $ GMEStackBootrap $ show e) $ do
evaluate =<< gmUnsafeReadProcess oopts stack args "" evaluate =<< readProc stack args ""
-- | Get path to sandbox config file -- | Get path to sandbox config file
getSandboxDb :: Cradle -> IO (Maybe GhcPkgDb) getSandboxDb :: Cradle -> IO (Maybe GhcPkgDb)

16
Language/Haskell/GhcMod/Target.hs
View File

@ -57,7 +57,7 @@ import Prelude hiding ((.))
import System.Directory import System.Directory
import System.FilePath import System.FilePath
runGmPkgGhc :: (IOish m, GmEnv m, GmState m, GmLog m) => LightGhc a -> m a runGmPkgGhc :: (IOish m, Gm m) => LightGhc a -> m a
runGmPkgGhc action = do runGmPkgGhc action = do
pkgOpts <- packageGhcOptions pkgOpts <- packageGhcOptions
withLightHscEnv pkgOpts $ \env -> liftIO $ runLightGhc env action withLightHscEnv pkgOpts $ \env -> liftIO $ runLightGhc env action
@ -116,14 +116,14 @@ runGmlTWith :: IOish m
-> GhcModT m b -> GhcModT m b
runGmlTWith efnmns' mdf wrapper action = do runGmlTWith efnmns' mdf wrapper action = do
crdl <- cradle crdl <- cradle
Options { ghcUserOptions } <- options Options { optGhcUserOptions } <- options
let (fns, mns) = partitionEithers efnmns' let (fns, mns) = partitionEithers efnmns'
ccfns = map (cradleCurrentDir crdl </>) fns ccfns = map (cradleCurrentDir crdl </>) fns
cfns <- mapM getCanonicalFileNameSafe ccfns cfns <- mapM getCanonicalFileNameSafe ccfns
let serfnmn = Set.fromList $ map Right mns ++ map Left cfns let serfnmn = Set.fromList $ map Right mns ++ map Left cfns
opts <- targetGhcOptions crdl serfnmn opts <- targetGhcOptions crdl serfnmn
let opts' = opts ++ ["-O0"] ++ ghcUserOptions let opts' = opts ++ ["-O0"] ++ optGhcUserOptions
gmVomit gmVomit
"session-ghc-options" "session-ghc-options"
@ -260,7 +260,7 @@ findCandidates scns = foldl1 Set.intersection scns
pickComponent :: Set ChComponentName -> ChComponentName pickComponent :: Set ChComponentName -> ChComponentName
pickComponent scn = Set.findMin scn pickComponent scn = Set.findMin scn
packageGhcOptions :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m) packageGhcOptions :: (Applicative m, IOish m, Gm m)
=> m [GHCOption] => m [GHCOption]
packageGhcOptions = do packageGhcOptions = do
crdl <- cradle crdl <- cradle
@ -282,7 +282,7 @@ sandboxOpts crdl = do
getSandboxPackageDbStack = getSandboxPackageDbStack =
([GlobalDb] ++) . maybe [UserDb] return <$> getSandboxDb crdl ([GlobalDb] ++) . maybe [UserDb] return <$> getSandboxDb crdl
resolveGmComponent :: (IOish m, GmLog m, GmEnv m, GmState m) resolveGmComponent :: (IOish m, Gm m)
=> Maybe [CompilationUnit] -- ^ Updated modules => Maybe [CompilationUnit] -- ^ Updated modules
-> GmComponent 'GMCRaw (Set ModulePath) -> GmComponent 'GMCRaw (Set ModulePath)
-> m (GmComponent 'GMCResolved (Set ModulePath)) -> m (GmComponent 'GMCResolved (Set ModulePath))
@ -308,7 +308,7 @@ resolveGmComponent mums c@GmComponent {..} = do
[ "-optP-include", "-optP" ++ distDir </> macrosHeaderPath ] [ "-optP-include", "-optP" ++ distDir </> macrosHeaderPath ]
] ]
resolveEntrypoint :: (IOish m, GmEnv m, GmLog m, GmState m) resolveEntrypoint :: (IOish m, Gm m)
=> Cradle => Cradle
-> GmComponent 'GMCRaw ChEntrypoint -> GmComponent 'GMCRaw ChEntrypoint
-> m (GmComponent 'GMCRaw (Set ModulePath)) -> m (GmComponent 'GMCRaw (Set ModulePath))
@ -341,7 +341,7 @@ chModToMod :: ChModuleName -> ModuleName
chModToMod (ChModuleName mn) = mkModuleName mn chModToMod (ChModuleName mn) = mkModuleName mn
resolveModule :: (IOish m, GmEnv m, GmLog m, GmState m) => resolveModule :: (IOish m, Gm m) =>
HscEnv -> [FilePath] -> CompilationUnit -> m (Maybe ModulePath) HscEnv -> [FilePath] -> CompilationUnit -> m (Maybe ModulePath)
resolveModule env _srcDirs (Right mn) = resolveModule env _srcDirs (Right mn) =
liftIO $ traverse canonicalizeModulePath =<< findModulePath env mn liftIO $ traverse canonicalizeModulePath =<< findModulePath env mn
@ -373,7 +373,7 @@ resolveModule env srcDirs (Left fn') = do
type CompilationUnit = Either FilePath ModuleName type CompilationUnit = Either FilePath ModuleName
resolveGmComponents :: (IOish m, GmState m, GmLog m, GmEnv m) resolveGmComponents :: (IOish m, Gm m)
=> Maybe [CompilationUnit] => Maybe [CompilationUnit]
-- ^ Updated modules -- ^ Updated modules
-> [GmComponent 'GMCRaw (Set ModulePath)] -> [GmComponent 'GMCRaw (Set ModulePath)]

59
Language/Haskell/GhcMod/Types.hs
View File

@ -90,51 +90,51 @@ data Programs = Programs {
data OutputOpts = OutputOpts { data OutputOpts = OutputOpts {
-- | Verbosity -- | Verbosity
logLevel :: GmLogLevel ooptLogLevel :: GmLogLevel
, outputStyle :: OutputStyle , ooptStyle :: OutputStyle
-- | Line separator string. -- | Line separator string.
, lineSeparator :: LineSeparator , ooptLineSeparator :: LineSeparator
-- | Stdout/err line multiplexing using prefix encoding. @fst@ is stdout, -- | Stdout/err line multiplexing using prefix encoding. @fst@ is stdout,
-- @snd@ is stderr prefix. -- @snd@ is stderr prefix.
, linePrefix :: Maybe (String, String) , ooptLinePrefix :: Maybe (String, String)
} deriving (Show) } deriving (Show)
data Options = Options { data Options = Options {
outputOpts :: OutputOpts optOutput :: OutputOpts
, programs :: Programs , optPrograms :: Programs
-- | GHC command line options set on the @ghc-mod@ command line -- | GHC command line options set on the @ghc-mod@ command line
, ghcUserOptions:: [GHCOption] , optGhcUserOptions :: [GHCOption]
-- | If 'True', 'browse' also returns operators. -- | If 'True', 'browse' also returns operators.
, operators :: Bool , optOperators :: Bool
-- | If 'True', 'browse' also returns types. -- | If 'True', 'browse' also returns types.
, detailed :: Bool , optDetailed :: Bool
-- | If 'True', 'browse' will return fully qualified name -- | If 'True', 'browse' will return fully qualified name
, qualified :: Bool , optQualified :: Bool
, hlintOpts :: [String] , optHlintOpts :: [String]
, fileMappings :: [(FilePath, Maybe FilePath)] , optFileMappings :: [(FilePath, Maybe FilePath)]
} deriving (Show) } deriving (Show)
-- | A default 'Options'. -- | A default 'Options'.
defaultOptions :: Options defaultOptions :: Options
defaultOptions = Options { defaultOptions = Options {
outputOpts = OutputOpts { optOutput = OutputOpts {
outputStyle = PlainStyle ooptLogLevel = GmWarning
, lineSeparator = LineSeparator "\0" , ooptStyle = PlainStyle
, linePrefix = Nothing , ooptLineSeparator = LineSeparator "\0"
, logLevel = GmWarning , ooptLinePrefix = Nothing
} }
, programs = Programs { , optPrograms = Programs {
ghcProgram = "ghc" ghcProgram = "ghc"
, ghcPkgProgram = "ghc-pkg" , ghcPkgProgram = "ghc-pkg"
, cabalProgram = "cabal" , cabalProgram = "cabal"
, stackProgram = "stack" , stackProgram = "stack"
} }
, ghcUserOptions = [] , optGhcUserOptions = []
, operators = False , optOperators = False
, detailed = False , optDetailed = False
, qualified = False , optQualified = False
, hlintOpts = [] , optHlintOpts = []
, fileMappings = [] , optFileMappings = []
} }
---------------------------------------------------------------- ----------------------------------------------------------------
@ -158,7 +158,7 @@ data Cradle = Cradle {
} deriving (Eq, Show) } deriving (Eq, Show)
data GmStream = GmOut | GmErr data GmStream = GmOutStream | GmErrStream
deriving (Show) deriving (Show)
data GmLineType = GmTerminated | GmPartial data GmLineType = GmTerminated | GmPartial
@ -170,13 +170,14 @@ data GmLines a = GmLines GmLineType a
unGmLine :: GmLines a -> a unGmLine :: GmLines a -> a
unGmLine (GmLines _ s) = s unGmLine (GmLines _ s) = s
data GmOutput = GmOutputStdio
| GmOutputChan (Chan (GmStream, GmLines String))
data GhcModEnv = GhcModEnv { data GhcModEnv = GhcModEnv {
gmOptions :: Options gmOptions :: Options
, gmCradle :: Cradle , gmCradle :: Cradle
, gmOutput :: GmOutput }
data GhcModOut = GhcModOut {
gmoOptions :: OutputOpts
, gmoChan :: Chan (GmStream, GmLines String)
} }
data GhcModLog = GhcModLog { data GhcModLog = GhcModLog {

38
src/GHCMod.hs
View File

@ -251,27 +251,27 @@ globalArgSpec =
[ option "v" ["verbose"] "Increase or set log level. (0-7)" $ [ option "v" ["verbose"] "Increase or set log level. (0-7)" $
optArg "LEVEL" $ \ml o -> Right $ case ml of optArg "LEVEL" $ \ml o -> Right $ case ml of
Nothing -> Nothing ->
modify (lLogLevel . lOutputOpts) increaseLogLevel o modify (lOoptLogLevel . lOptOutput) increaseLogLevel o
Just l -> Just l ->
set (lLogLevel . lOutputOpts) (toEnum $ min 7 $ read l) o set (lOoptLogLevel . lOptOutput) (toEnum $ min 7 $ read l) o
, option "s" [] "Be silent, set log level to 0" $ , option "s" [] "Be silent, set log level to 0" $
NoArg $ \o -> Right $ set (lLogLevel . lOutputOpts) (toEnum 0) o NoArg $ \o -> Right $ set (lOoptLogLevel . lOptOutput) (toEnum 0) o
, option "l" ["tolisp"] "Format output as an S-Expression" $ , option "l" ["tolisp"] "Format output as an S-Expression" $
NoArg $ \o -> Right $ set (lOutputStyle . lOutputOpts) LispStyle o NoArg $ \o -> Right $ set (lOoptStyle . lOptOutput) LispStyle o
, option "b" ["boundary", "line-seperator"] "Output line separator"$ , option "b" ["boundary", "line-seperator"] "Output line separator"$
reqArg "SEP" $ \s o -> Right $ set (lLineSeparator . lOutputOpts) (LineSeparator s) o reqArg "SEP" $ \s o -> Right $ set (lOoptLineSeparator . lOptOutput) (LineSeparator s) o
, option "" ["line-prefix"] "Output line separator"$ , option "" ["line-prefix"] "Output line separator"$
reqArg "OUT,ERR" $ \s o -> let reqArg "OUT,ERR" $ \s o -> let
[out, err] = splitOn "," s [out, err] = splitOn "," s
in Right $ set (lLinePrefix . lOutputOpts) (Just (out, err)) o in Right $ set (lOoptLinePrefix . lOptOutput) (Just (out, err)) o
, option "g" ["ghcOpt", "ghc-option"] "Option to be passed to GHC" $ , option "g" ["ghcOpt", "ghc-option"] "Option to be passed to GHC" $
reqArg "OPT" $ \g o -> Right $ reqArg "OPT" $ \g o -> Right $
o { ghcUserOptions = g : ghcUserOptions o } o { optGhcUserOptions = g : optGhcUserOptions o }
{- {-
File map docs: File map docs:
@ -313,19 +313,19 @@ Exposed functions:
(s,"") -> (s, Nothing) (s,"") -> (s, Nothing)
(f,t) -> (f, Just t) (f,t) -> (f, Just t)
in in
Right $ o { fileMappings = m : fileMappings o } Right $ o { optFileMappings = m : optFileMappings o }
, option "" ["with-ghc"] "GHC executable to use" $ , option "" ["with-ghc"] "GHC executable to use" $
reqArg "PATH" $ \p o -> Right $ set (lGhcProgram . lPrograms) p o reqArg "PATH" $ \p o -> Right $ set (lGhcProgram . lOptPrograms) p o
, option "" ["with-ghc-pkg"] "ghc-pkg executable to use (only needed when guessing from GHC path fails)" $ , option "" ["with-ghc-pkg"] "ghc-pkg executable to use (only needed when guessing from GHC path fails)" $
reqArg "PATH" $ \p o -> Right $ set (lGhcPkgProgram . lPrograms) p o reqArg "PATH" $ \p o -> Right $ set (lGhcPkgProgram . lOptPrograms) p o
, option "" ["with-cabal"] "cabal-install executable to use" $ , option "" ["with-cabal"] "cabal-install executable to use" $
reqArg "PATH" $ \p o -> Right $ set (lCabalProgram . lPrograms) p o reqArg "PATH" $ \p o -> Right $ set (lCabalProgram . lOptPrograms) p o
, option "" ["with-stack"] "stack executable to use" $ , option "" ["with-stack"] "stack executable to use" $
reqArg "PATH" $ \p o -> Right $ set (lStackProgram . lPrograms) p o reqArg "PATH" $ \p o -> Right $ set (lStackProgram . lOptPrograms) p o
, option "" ["version"] "print version information" $ , option "" ["version"] "print version information" $
NoArg $ \_ -> Left ["version"] NoArg $ \_ -> Left ["version"]
@ -406,7 +406,7 @@ progMain (globalOptions,cmdArgs) = hndle $ runGhcModT globalOptions $ handler $
case globalCommands cmdArgs of case globalCommands cmdArgs of
Just s -> gmPutStr s Just s -> gmPutStr s
Nothing -> do Nothing -> do
forM_ (reverse $ fileMappings globalOptions) $ uncurry loadMMappedFiles forM_ (reverse $ optFileMappings globalOptions) $ uncurry loadMMappedFiles
ghcCommands cmdArgs ghcCommands cmdArgs
where where
hndle action = do hndle action = do
@ -559,7 +559,7 @@ exitError msg = gmErrStrLn (dropWhileEnd (=='\n') msg) >> liftIO exitFailure
exitError' :: Options -> String -> IO a exitError' :: Options -> String -> IO a
exitError' opts msg = do exitError' opts msg = do
gmUnsafeErrStr (outputOpts opts) msg gmUnsafeErrStr (optOutput opts) msg
liftIO exitFailure liftIO exitFailure
fatalError :: String -> a fatalError :: String -> a
@ -654,24 +654,24 @@ locAction' cmd _ _ = throw $ InvalidCommandLine (Left cmd)
modulesArgSpec :: [OptDescr (Options -> Either [String] Options)] modulesArgSpec :: [OptDescr (Options -> Either [String] Options)]
modulesArgSpec = modulesArgSpec =
[ option "d" ["detailed"] "Print package modules belong to." $ [ option "d" ["detailed"] "Print package modules belong to." $
NoArg $ \o -> Right $ o { detailed = True } NoArg $ \o -> Right $ o { optDetailed = True }
] ]
hlintArgSpec :: [OptDescr (Options -> Either [String] Options)] hlintArgSpec :: [OptDescr (Options -> Either [String] Options)]
hlintArgSpec = hlintArgSpec =
[ option "h" ["hlintOpt"] "Option to be passed to hlint" $ [ option "h" ["hlintOpt"] "Option to be passed to hlint" $
reqArg "hlintOpt" $ \h o -> Right $ o { hlintOpts = h : hlintOpts o } reqArg "hlintOpt" $ \h o -> Right $ o { optHlintOpts = h : optHlintOpts o }
] ]
browseArgSpec :: [OptDescr (Options -> Either [String] Options)] browseArgSpec :: [OptDescr (Options -> Either [String] Options)]
browseArgSpec = browseArgSpec =
[ option "o" ["operators"] "Also print operators." $ [ option "o" ["operators"] "Also print operators." $
NoArg $ \o -> Right $ o { operators = True } NoArg $ \o -> Right $ o { optOperators = True }
, option "d" ["detailed"] "Print symbols with accompanying signature." $ , option "d" ["detailed"] "Print symbols with accompanying signature." $
NoArg $ \o -> Right $ o { detailed = True } NoArg $ \o -> Right $ o { optDetailed = True }
, option "q" ["qualified"] "Qualify symbols" $ , option "q" ["qualified"] "Qualify symbols" $
NoArg $ \o -> Right $ o { qualified = True } NoArg $ \o -> Right $ o { optQualified = True }
] ]
nukeCaches :: IOish m => GhcModT m () nukeCaches :: IOish m => GhcModT m ()

4
test/BrowseSpec.hs
View File

@ -17,12 +17,12 @@ spec = do
describe "browse -d Data.Either" $ do describe "browse -d Data.Either" $ do
it "contains functions (e.g. `either') including their type signature" $ do it "contains functions (e.g. `either') including their type signature" $ do
syms <- run defaultOptions { detailed = True } syms <- run defaultOptions { optDetailed = True }
$ lines <$> browse "Data.Either" $ lines <$> browse "Data.Either"
syms `shouldContain` ["either :: (a -> c) -> (b -> c) -> Either a b -> c"] syms `shouldContain` ["either :: (a -> c) -> (b -> c) -> Either a b -> c"]
it "contains type constructors (e.g. `Left') including their type signature" $ do it "contains type constructors (e.g. `Left') including their type signature" $ do
syms <- run defaultOptions { detailed = True} syms <- run defaultOptions { optDetailed = True}
$ lines <$> browse "Data.Either" $ lines <$> browse "Data.Either"
syms `shouldContain` ["Left :: a -> Either a b"] syms `shouldContain` ["Left :: a -> Either a b"]

2
test/CabalHelperSpec.hs
View File

@ -61,7 +61,7 @@ spec = do
let tdir = "test/data/stack-project" let tdir = "test/data/stack-project"
[ghcOpts] <- map gmcGhcOpts . filter ((==ChExeName "new-template-exe") . gmcName) <$> runD' tdir getComponents [ghcOpts] <- map gmcGhcOpts . filter ((==ChExeName "new-template-exe") . gmcName) <$> runD' tdir getComponents
let pkgs = pkgOptions ghcOpts let pkgs = pkgOptions ghcOpts
pkgs `shouldBe` ["base", "bytestring"] sort pkgs `shouldBe` ["base", "bytestring"]
it "extracts build dependencies" $ do it "extracts build dependencies" $ do
let tdir = "test/data/cabal-project" let tdir = "test/data/cabal-project"

7
test/CradleSpec.hs
View File

@ -7,6 +7,7 @@ import Language.Haskell.GhcMod.Types
import System.Directory (canonicalizePath) import System.Directory (canonicalizePath)
import System.FilePath (pathSeparator) import System.FilePath (pathSeparator)
import Test.Hspec import Test.Hspec
import TestUtils
import Prelude import Prelude
import Dir import Dir
@ -36,14 +37,14 @@ spec = do
it "returns the current directory" $ do it "returns the current directory" $ do
withDirectory_ "/" $ do withDirectory_ "/" $ do
curDir <- stripLastDot <$> canonicalizePath "/" curDir <- stripLastDot <$> canonicalizePath "/"
res <- clean_ $ findCradle (outputOpts defaultOptions) res <- clean_ $ runGmOutDef findCradle
cradleCurrentDir res `shouldBe` curDir cradleCurrentDir res `shouldBe` curDir
cradleRootDir res `shouldBe` curDir cradleRootDir res `shouldBe` curDir
cradleCabalFile res `shouldBe` Nothing cradleCabalFile res `shouldBe` Nothing
it "finds a cabal file and a sandbox" $ do it "finds a cabal file and a sandbox" $ do
withDirectory "test/data/cabal-project/subdir1/subdir2" $ \dir -> do withDirectory "test/data/cabal-project/subdir1/subdir2" $ \dir -> do
res <- relativeCradle dir <$> clean_ (findCradle (outputOpts defaultOptions)) res <- relativeCradle dir <$> clean_ (runGmOutDef findCradle)
cradleCurrentDir res `shouldBe` cradleCurrentDir res `shouldBe`
"test/data/cabal-project/subdir1/subdir2" "test/data/cabal-project/subdir1/subdir2"
@ -55,7 +56,7 @@ spec = do
it "works even if a sandbox config file is broken" $ do it "works even if a sandbox config file is broken" $ do
withDirectory "test/data/broken-sandbox" $ \dir -> do withDirectory "test/data/broken-sandbox" $ \dir -> do
res <- relativeCradle dir <$> clean_ (findCradle (outputOpts defaultOptions)) res <- relativeCradle dir <$> clean_ (runGmOutDef findCradle)
cradleCurrentDir res `shouldBe` cradleCurrentDir res `shouldBe`
"test" </> "data" </> "broken-sandbox" "test" </> "data" </> "broken-sandbox"

2
test/InfoSpec.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module InfoSpec where module InfoSpec where
import Control.Applicative ((<$>)) import Control.Applicative
import Data.List (isPrefixOf) import Data.List (isPrefixOf)
import Language.Haskell.GhcMod import Language.Haskell.GhcMod
#if __GLASGOW_HASKELL__ < 706 #if __GLASGOW_HASKELL__ < 706

16
test/TestUtils.hs
View File

@ -5,6 +5,7 @@ module TestUtils (
, runD' , runD'
, runE , runE
, runNullLog , runNullLog
, runGmOutDef
, shouldReturnError , shouldReturnError
, isPkgDbAt , isPkgDbAt
, isPkgConfDAt , isPkgConfDAt
@ -19,6 +20,7 @@ import Language.Haskell.GhcMod.Types
import Control.Arrow import Control.Arrow
import Control.Category import Control.Category
import Control.Concurrent
import Control.Applicative import Control.Applicative
import Control.Monad.Error (ErrorT, runErrorT) import Control.Monad.Error (ErrorT, runErrorT)
import Control.Monad.Trans.Journal import Control.Monad.Trans.Journal
@ -46,7 +48,7 @@ withSpecCradle :: IOish m => FilePath -> (Cradle -> m a) -> m a
withSpecCradle cradledir f = withSpecCradle cradledir f =
gbracket (liftIO $ findSpecCradle cradledir) (liftIO . cleanupCradle) f gbracket (liftIO $ findSpecCradle cradledir) (liftIO . cleanupCradle) f
withGhcModEnvSpec :: IOish m => FilePath -> Options -> (GhcModEnv -> m a) -> m a withGhcModEnvSpec :: (IOish m, GmOut m) => FilePath -> Options -> (GhcModEnv -> m a) -> m a
withGhcModEnvSpec dir opt f = withSpecCradle dir $ withGhcModEnv' opt f withGhcModEnvSpec dir opt f = withSpecCradle dir $ withGhcModEnv' opt f
runGhcModTSpec :: Options -> GhcModT IO a -> IO (Either GhcModError a, GhcModLog) runGhcModTSpec :: Options -> GhcModT IO a -> IO (Either GhcModError a, GhcModLog)
@ -56,10 +58,12 @@ runGhcModTSpec opt action = do
runGhcModTSpec' :: IOish m runGhcModTSpec' :: IOish m
=> FilePath -> Options -> GhcModT m b -> m (Either GhcModError b, GhcModLog) => FilePath -> Options -> GhcModT m b -> m (Either GhcModError b, GhcModLog)
runGhcModTSpec' dir opt action = liftIO (canonicalizePath dir) >>= \dir' -> runGhcModTSpec' dir opt action = liftIO (canonicalizePath dir) >>= \dir' -> do
gmo <- GhcModOut (optOutput opt) <$> liftIO newChan
runGmOutT gmo $
withGhcModEnvSpec dir' opt $ \env -> do withGhcModEnvSpec dir' opt $ \env -> do
first (fst <$>) <$> runGhcModT'' env defaultGhcModState first (fst <$>) <$> runGhcModT'' env defaultGhcModState
(gmSetLogLevel (logLevel $ outputOpts opt) >> action) (gmSetLogLevel (ooptLogLevel $ optOutput opt) >> action)
-- | Run GhcMod -- | Run GhcMod
run :: Options -> GhcModT IO a -> IO a run :: Options -> GhcModT IO a -> IO a
@ -75,7 +79,7 @@ runD' dir =
extract . runGhcModTSpec' dir (setLogLevel testLogLevel defaultOptions) extract . runGhcModTSpec' dir (setLogLevel testLogLevel defaultOptions)
setLogLevel :: GmLogLevel -> Options -> Options setLogLevel :: GmLogLevel -> Options -> Options
setLogLevel = set (lLogLevel . lOutputOpts) setLogLevel = set (lOoptLogLevel . lOptOutput)
runE :: ErrorT e IO a -> IO (Either e a) runE :: ErrorT e IO a -> IO (Either e a)
runE = runErrorT runE = runErrorT
@ -86,6 +90,10 @@ runNullLog action = do
liftIO $ print w liftIO $ print w
return a return a
runGmOutDef :: IOish m => GmOutT m a -> m a
runGmOutDef =
runGmOutT (GhcModOut (optOutput defaultOptions) (error "no chan"))
shouldReturnError :: Show a shouldReturnError :: Show a
=> IO (Either GhcModError a, GhcModLog) => IO (Either GhcModError a, GhcModLog)
-> Expectation -> Expectation