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

Sandwich new Monad layer GmOutT into transformer stack

Browse Source 
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
let
removeOps
| operators opt = id
| optOperators opt = id
| otherwise = filter (isNotOp . getOccString)
mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo
@ -90,17 +90,17 @@ showExport opt minfo e = do
mtype' <- mtype
return $ concat $ catMaybes [mqualified, Just $ formatOp $ getOccString e, mtype']
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
| detailed opt = do
| optDetailed opt = do
tyInfo <- G.modInfoLookupName minfo e
-- If nothing found, load dependent module and lookup global
tyResult <- maybe (inOtherModule e) (return . Just) tyInfo
dflag <- G.getSessionDynFlags
return $ do
typeName <- tyResult >>= showThing dflag
(" :: " ++ typeName) `justIf` detailed opt
(" :: " ++ typeName) `justIf` optDetailed opt
| otherwise = return Nothing
formatOp nm
| 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
-- access home modules
getGhcMergedPkgOptions :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m)
getGhcMergedPkgOptions :: (Applicative m, IOish m, Gm m)
=> m [GHCOption]
getGhcMergedPkgOptions = chCached $ \distdir -> Cached {
cacheLens = Just (lGmcMergedPkgOptions . lGmCaches),
@ -65,7 +65,7 @@ getGhcMergedPkgOptions = chCached $ \distdir -> Cached {
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 {
cacheLens = Just (lGmcPackageDbStack . lGmCaches),
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
-- 'resolveGmComponents'.
getComponents :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m)
getComponents :: (Applicative m, IOish m, Gm m)
=> m [GmComponent 'GMCRaw ChEntrypoint]
getComponents = chCached$ \distdir -> Cached {
cacheLens = Just (lGmcComponents . lGmCaches),
@ -116,7 +116,7 @@ getComponents = chCached$ \distdir -> Cached {
, a == a'
]
prepareCabalHelper :: (IOish m, GmEnv m, GmLog m) => m ()
prepareCabalHelper :: (IOish m, GmEnv m, GmOut m, GmLog m) => m ()
prepareCabalHelper = do
crdl <- cradle
let projdir = cradleRootDir crdl
@ -147,19 +147,19 @@ getStackPackageDbStack = do
localDb <- liftIO $ readProcess stack ["path", "--local-pkg-db"] ""
return $ map (PackageDb . takeWhile (/='\n')) [snapshotDb, localDb]
patchStackPrograms :: IOish m => OutputOpts -> Cradle -> Programs -> m Programs
patchStackPrograms _oopts crdl progs
patchStackPrograms :: (IOish m, GmOut m) => Cradle -> Programs -> m Programs
patchStackPrograms crdl progs
| cradleProjectType crdl /= StackProject = return progs
patchStackPrograms oopts crdl progs = do
patchStackPrograms crdl progs = do
let projdir = cradleRootDir crdl
Just ghc <- liftIO $ getStackGhcPath oopts projdir
Just ghcPkg <- liftIO $ getStackGhcPkgPath oopts projdir
Just ghc <- getStackGhcPath projdir
Just ghcPkg <- getStackGhcPkgPath projdir
return $ progs {
ghcProgram = ghc
, 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
crdl <- cradle
opts <- options
@ -177,7 +177,7 @@ withCabal action = do
pkgDbStackOutOfSync <-
case mCusPkgDbStack of
Just cusPkgDbStack -> do
pkgDb <- runQuery'' readProc (helperProgs $ programs opts) projdir distdir $
pkgDb <- runQuery'' readProc (helperProgs $ optPrograms opts) projdir distdir $
map chPkgToGhcPkg <$> packageDbStack
return $ pkgDb /= cusPkgDbStack
@ -199,10 +199,10 @@ withCabal action = do
|| isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $
case projType of
CabalProject ->
cabalReconfigure readProc (programs opts) crdl projdir distdir
cabalReconfigure readProc (optPrograms opts) crdl projdir distdir
StackProject ->
stackReconfigure crdl (programs opts)
stackReconfigure crdl (optPrograms opts)
_ ->
error $ "withCabal: unsupported project type: " ++ show projType
@ -216,7 +216,7 @@ withCabal action = do
[ "--with-ghc=" ++ T.ghcProgram progs ]
-- Only pass ghc-pkg if it was actually set otherwise we
-- 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 ]
else []
++ map pkgDbArg cusPkgStack
@ -277,7 +277,7 @@ helperProgs progs = CH.Programs {
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
chCached c = do
root <- cradleRootDir <$> cradle
@ -289,10 +289,8 @@ chCached c = do
-- changes the cache files will be gone anyways ;)
cacheInputData root = do
opts <- options
let oopts = outputOpts opts
progs = programs opts
crdl <- cradle
progs' <- patchStackPrograms oopts crdl progs
progs' <- patchStackPrograms crdl (optPrograms opts)
return $ ( helperProgs progs'
, root
, (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.Maybe (isJust)
import Data.Functor
import qualified Data.Text as T
import qualified Data.Text.IO as T (readFile)
import System.FilePath
@ -50,7 +49,7 @@ splits :: IOish m
-> GhcModT m String
splits file lineNo colNo =
ghandle handler $ runGmlT' [Left file] deferErrors $ do
oopts <- outputOpts <$> options
oopts <- outputOpts
crdl <- cradle
style <- getStyle
dflag <- G.getSessionDynFlags
@ -70,7 +69,7 @@ splits file lineNo colNo =
handler (SomeException ex) = do
gmLog GmException "splits" $
text "" $$ nest 4 (showDoc ex)
emptyResult =<< outputOpts <$> options
emptyResult =<< outputOpts
----------------------------------------------------------------
-- 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
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 opt@OutputOpts { outputStyle = LispStyle } x = toLisp opt x "\n"
convert opt@OutputOpts { outputStyle = PlainStyle } x
convert opt@OutputOpts { ooptStyle = LispStyle } x = toLisp opt x "\n"
convert opt@OutputOpts { ooptStyle = PlainStyle } x
| str == "\n" = ""
| otherwise = str
where
@ -43,7 +43,7 @@ lineSep :: OutputOpts -> String
lineSep oopts = interpret lsep
where
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 sandbox according to a cabal sandbox config
-- in a cabal directory.
findCradle :: OutputOpts -> IO Cradle
findCradle oopts = findCradle' oopts =<< getCurrentDirectory
findCradle :: (IOish m, GmOut m) => m Cradle
findCradle = findCradle' =<< liftIO getCurrentDirectory
findCradle' :: OutputOpts -> FilePath -> IO Cradle
findCradle' oopts dir = run $ do
(stackCradle oopts dir `mplus` cabalCradle dir `mplus` sandboxCradle dir `mplus` plainCradle dir)
findCradle' :: (IOish m, GmOut m) => FilePath -> m Cradle
findCradle' dir = run $
msum [ stackCradle dir
, cabalCradle dir
, sandboxCradle dir
, plainCradle dir
]
where run a = fillTempDir =<< (fromJust <$> runMaybeT a)
findSpecCradle :: FilePath -> IO Cradle
@ -53,14 +57,14 @@ findSpecCradle dir = do
cleanupCradle :: Cradle -> IO ()
cleanupCradle crdl = removeDirectoryRecursive $ cradleTempDir crdl
fillTempDir :: MonadIO m => Cradle -> m Cradle
fillTempDir :: IOish m => Cradle -> m Cradle
fillTempDir crdl = do
tmpDir <- liftIO $ newTempDir (cradleRootDir crdl)
return crdl { cradleTempDir = tmpDir }
cabalCradle :: FilePath -> MaybeT IO Cradle
cabalCradle :: IOish m => FilePath -> MaybeT m Cradle
cabalCradle wdir = do
cabalFile <- MaybeT $ findCabalFile wdir
cabalFile <- MaybeT $ liftIO $ findCabalFile wdir
let cabalDir = takeDirectory cabalFile
@ -73,19 +77,19 @@ cabalCradle wdir = do
, cradleDistDir = "dist"
}
stackCradle :: OutputOpts -> FilePath -> MaybeT IO Cradle
stackCradle oopts wdir = do
cabalFile <- MaybeT $ findCabalFile wdir
stackCradle :: (IOish m, GmOut m) => FilePath -> MaybeT m Cradle
stackCradle wdir = do
cabalFile <- MaybeT $ liftIO $ findCabalFile wdir
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
-- rather than stack, or maybe that's just me ;)
whenM (liftIO $ doesFileExist $ setupConfigPath "dist") $ mzero
distDir <- MaybeT $ getStackDistDir oopts cabalDir
distDir <- MaybeT $ getStackDistDir cabalDir
return Cradle {
cradleProjectType = StackProject
@ -96,9 +100,9 @@ stackCradle oopts wdir = do
, cradleDistDir = distDir
}
sandboxCradle :: FilePath -> MaybeT IO Cradle
sandboxCradle :: IOish m => FilePath -> MaybeT m Cradle
sandboxCradle wdir = do
sbDir <- MaybeT $ findCabalSandboxDir wdir
sbDir <- MaybeT $ liftIO $ findCabalSandboxDir wdir
return Cradle {
cradleProjectType = SandboxProject
, cradleCurrentDir = wdir
@ -108,7 +112,7 @@ sandboxCradle wdir = do
, cradleDistDir = "dist"
}
plainCradle :: FilePath -> MaybeT IO Cradle
plainCradle :: IOish m => FilePath -> MaybeT m Cradle
plainCradle wdir = do
return $ Cradle {
cradleProjectType = PlainProject

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

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

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

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

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

@ -3,7 +3,6 @@ module Language.Haskell.GhcMod.Info (
, types
) where
import Control.Applicative
import Data.Function (on)
import Data.List (sortBy)
import Data.Maybe (catMaybes)
@ -35,8 +34,8 @@ info :: IOish m
info file expr =
ghandle handler $
runGmlT' [Left file] deferErrors $
withInteractiveContext $
convert . outputOpts <$> options <*> body
withInteractiveContext $ do
convert' =<< body
where
handler (SomeException ex) = do
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
opt <- options
withMappedFile file $ \tempfile ->
liftIO (hlint $ tempfile : "--quiet" : hlintOpts opt)
liftIO (hlint $ tempfile : "--quiet" : optHlintOpts opt)
>>= mapM (replaceFileName tempfile)
>>= ghandle handler . pack
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.Error
import Language.Haskell.GhcMod.Utils (mkRevRedirMapFunc)
import Language.Haskell.GhcMod.Types
import qualified Language.Haskell.GhcMod.Gap as Gap
import Prelude
@ -76,13 +75,13 @@ appendLogRef rfm df (LogRef ref) _ sev src st msg = do
-- | Logged messages are returned as 'String'.
-- 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)
-> m a
-> m (Either String (String, a))
withLogger f action = do
env <- G.getSession
oopts <- outputOpts <$> options
oopts <- outputOpts
let conv = convert oopts
eres <- withLogger' env $ \setDf ->
withDynFlags (f . setDf) action

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

@ -65,7 +65,7 @@ decreaseLogLevel l = pred l
-- True
-- >>> Just GmDebug <= Just GmException
-- 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
GhcModLog { gmLogLevel = Just level' } <- gmlHistory
@ -78,7 +78,7 @@ gmLog level loc' doc = do
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
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.
modules :: (IOish m, GmEnv m, GmState m, GmLog m) => m String
modules :: (IOish m, Gm m) => m String
modules = do
Options { detailed } <- options
Options { optDetailed } <- options
df <- runGmPkgGhc G.getSessionDynFlags
let mns = listVisibleModuleNames df
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 ]
where
modulePkg df = lookupModulePackageInAllPackages df

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

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

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

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

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

@ -25,7 +25,6 @@ module Language.Haskell.GhcMod.Output (
, gmReadProcess
, gmUnsafePutStr
, gmUnsafeErrStr
, gmUnsafeReadProcess
, stdoutGateway
) where
@ -64,38 +63,46 @@ toGmLines "" = GmLines GmPartial ""
toGmLines s | isNewline (last s) = GmLines GmTerminated s
toGmLines s = GmLines GmPartial s
outputFns :: (GmEnv m, MonadIO m')
outputFns :: (GmOut m, MonadIO m')
=> m (GmLines String -> m' (), GmLines String -> m' ())
outputFns = do
oopts <- outputOpts `liftM` options
env <- gmeAsk
return $ outputFns' oopts (gmOutput env)
outputFns =
outputFns' <$> gmoAsk
outputFns' :: MonadIO m'
=> OutputOpts
-> GmOutput
-> (GmLines String -> m' (), GmLines String -> m' ())
outputFns' opts output = let
OutputOpts {..} = opts
pfxFns :: Maybe (String, String) -> (GmLines String -> GmLines String, GmLines String -> GmLines String)
pfxFns lpfx = case lpfx of
Nothing -> ( id, id )
Just (op, ep) -> ( fmap $ pfx (op++), fmap $ pfx (ep++) )
where
pfx f = withLines f
pfx f = withLines f
stdioOutputFns :: MonadIO m => Maybe (String, String) -> (GmLines String -> m (), GmLines String -> m ())
stdioOutputFns lpfx = let
(outPfx, errPfx) = pfxFns lpfx
in
( liftIO . putStr . unGmLine . outPfx
, liftIO . hPutStr stderr . unGmLine . errPfx)
outPfx, errPfx :: GmLines String -> GmLines String
(outPfx, errPfx) =
case linePrefix of
Nothing -> ( id, id )
Just (op, ep) -> ( fmap $ pfx (op++), fmap $ pfx (ep++) )
chanOutputFns :: MonadIO m
=> 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 output of
GmOutputStdio ->
( liftIO . putStr . unGmLine . outPfx
, liftIO . hPutStr stderr . unGmLine . errPfx)
GmOutputChan c ->
( liftIO . writeChan c . (,) GmOut . outPfx
, liftIO . writeChan c . (,) GmErr .errPfx)
case ooptLinePrefix of
Nothing -> stdioOutputFns ooptLinePrefix
Just _ -> chanOutputFns c ooptLinePrefix
gmPutStr, gmPutStrLn, gmErrStr, gmErrStrLn
:: (MonadIO m, GmEnv m) => String -> m ()
:: (MonadIO m, GmOut m) => String -> m ()
gmPutStr str = do
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
gmUnsafePutStr, gmUnsafeErrStr
:: MonadIO m => OutputOpts -> String -> m ()
gmUnsafePutStr oopts = (fst $ outputFns' oopts GmOutputStdio) . toGmLines
gmUnsafeErrStr oopts = (snd $ outputFns' oopts GmOutputStdio) . toGmLines
gmUnsafePutStr oopts = (fst $ stdioOutputFns (ooptLinePrefix oopts)) . toGmLines
gmUnsafeErrStr oopts = (snd $ stdioOutputFns (ooptLinePrefix oopts)) . toGmLines
gmUnsafeReadProcess :: OutputOpts -> FilePath -> [String] -> String -> IO String
gmUnsafeReadProcess oopts =
readProcessStderrChan' (snd $ outputFns' oopts GmOutputStdio)
gmReadProcess :: GmEnv m => m (FilePath -> [String] -> String -> IO String)
gmReadProcess :: GmOut m => m (FilePath -> [String] -> String -> IO String)
gmReadProcess = do
GhcModEnv {..} <- gmeAsk
case gmOutput of
GmOutputChan _ ->
GhcModOut {..} <- gmoAsk
case ooptLinePrefix gmoOptions of
Just _ ->
readProcessStderrChan
GmOutputStdio ->
Nothing ->
return $ readProcess
stdoutGateway :: Chan (GmStream, GmLines String) -> IO ()
@ -136,8 +138,8 @@ stdoutGateway chan = go ("", "")
case ty of
GmTerminated ->
case stream of
GmOut -> putStr (obuf++l) >> hFlush stdout >> go ("", ebuf)
GmErr -> putStr (ebuf++l) >> hFlush stdout >> go (obuf, "")
GmOutStream -> putStr (obuf++l) >> hFlush stdout >> go ("", ebuf)
GmErrStream -> putStr (ebuf++l) >> hFlush stdout >> go (obuf, "")
GmPartial -> case reverse $ lines l of
[] -> go buf
[x] -> go (appendBuf stream buf x)
@ -146,12 +148,12 @@ stdoutGateway chan = go ("", "")
hFlush stdout
go (appendBuf stream buf x)
appendBuf GmOut (obuf, ebuf) s = (obuf++s, ebuf)
appendBuf GmErr (obuf, ebuf) s = (obuf, ebuf++s)
appendBuf GmOutStream (obuf, ebuf) s = (obuf++s, ebuf)
appendBuf GmErrStream (obuf, ebuf) s = (obuf, ebuf++s)
readProcessStderrChan ::
GmEnv m => m (FilePath -> [String] -> String -> IO String)
GmOut m => m (FilePath -> [String] -> String -> IO String)
readProcessStderrChan = do
(_, e :: GmLines String -> IO ()) <- outputFns
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.Monad
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Class
import Data.List
import Data.Char
import Data.Maybe
@ -35,6 +36,7 @@ import System.Process
import System.Info.Extra
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Caching
import Language.Haskell.GhcMod.Output
import qualified Language.Haskell.GhcMod.Utils as U
@ -77,22 +79,22 @@ findCabalFile dir = do
findStackConfigFile :: FilePath -> IO (Maybe FilePath)
findStackConfigFile dir = mightExist (dir </> "stack.yaml")
getStackDistDir :: OutputOpts -> FilePath -> IO (Maybe FilePath)
getStackDistDir oopts projdir = U.withDirectory_ projdir $ runMaybeT $ do
takeWhile (/='\n') <$> readStack oopts ["path", "--dist-dir"]
getStackDistDir :: (IOish m, GmOut m) => FilePath -> m (Maybe FilePath)
getStackDistDir projdir = U.withDirectory_ projdir $ runMaybeT $ do
takeWhile (/='\n') <$> readStack ["path", "--dist-dir"]
getStackGhcPath :: OutputOpts -> FilePath -> IO (Maybe FilePath)
getStackGhcPath oopts = findExecutablesInStackBinPath oopts "ghc"
getStackGhcPath :: (IOish m, GmOut m) => FilePath -> m (Maybe FilePath)
getStackGhcPath = findExecutablesInStackBinPath "ghc"
getStackGhcPkgPath :: OutputOpts -> FilePath -> IO (Maybe FilePath)
getStackGhcPkgPath oopts = findExecutablesInStackBinPath oopts "ghc-pkg"
getStackGhcPkgPath :: (IOish m, GmOut m) => FilePath -> m (Maybe FilePath)
getStackGhcPkgPath = findExecutablesInStackBinPath "ghc-pkg"
findExecutablesInStackBinPath :: OutputOpts -> String -> FilePath -> IO (Maybe FilePath)
findExecutablesInStackBinPath oopts exe projdir =
findExecutablesInStackBinPath :: (IOish m, GmOut m) => String -> FilePath -> m (Maybe FilePath)
findExecutablesInStackBinPath exe projdir =
U.withDirectory_ projdir $ runMaybeT $ do
path <- splitSearchPath . takeWhile (/='\n')
<$> readStack oopts ["path", "--bin-path"]
MaybeT $ listToMaybe <$> findExecutablesInDirectories' path exe
<$> readStack ["path", "--bin-path"]
MaybeT $ liftIO $ listToMaybe <$> findExecutablesInDirectories' path exe
findExecutablesInDirectories' :: [FilePath] -> String -> IO [FilePath]
findExecutablesInDirectories' path binary =
@ -103,11 +105,12 @@ findExecutablesInDirectories' path binary =
exeExtension = if isWindows then "exe" else ""
readStack :: OutputOpts -> [String] -> MaybeT IO String
readStack oopts args = do
stack <- MaybeT $ findExecutable "stack"
readStack :: (IOish m, GmOut m) => [String] -> MaybeT m String
readStack args = do
stack <- MaybeT $ liftIO $ findExecutable "stack"
readProc <- lift gmReadProcess
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
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.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
pkgOpts <- packageGhcOptions
withLightHscEnv pkgOpts $ \env -> liftIO $ runLightGhc env action
@ -116,14 +116,14 @@ runGmlTWith :: IOish m
-> GhcModT m b
runGmlTWith efnmns' mdf wrapper action = do
crdl <- cradle
Options { ghcUserOptions } <- options
Options { optGhcUserOptions } <- options
let (fns, mns) = partitionEithers efnmns'
ccfns = map (cradleCurrentDir crdl </>) fns
cfns <- mapM getCanonicalFileNameSafe ccfns
let serfnmn = Set.fromList $ map Right mns ++ map Left cfns
opts <- targetGhcOptions crdl serfnmn
let opts' = opts ++ ["-O0"] ++ ghcUserOptions
let opts' = opts ++ ["-O0"] ++ optGhcUserOptions
gmVomit
"session-ghc-options"
@ -260,7 +260,7 @@ findCandidates scns = foldl1 Set.intersection scns
pickComponent :: Set ChComponentName -> ChComponentName
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]
packageGhcOptions = do
crdl <- cradle
@ -282,7 +282,7 @@ sandboxOpts crdl = do
getSandboxPackageDbStack =
([GlobalDb] ++) . maybe [UserDb] return <$> getSandboxDb crdl
resolveGmComponent :: (IOish m, GmLog m, GmEnv m, GmState m)
resolveGmComponent :: (IOish m, Gm m)
=> Maybe [CompilationUnit] -- ^ Updated modules
-> GmComponent 'GMCRaw (Set ModulePath)
-> m (GmComponent 'GMCResolved (Set ModulePath))
@ -308,7 +308,7 @@ resolveGmComponent mums c@GmComponent {..} = do
[ "-optP-include", "-optP" ++ distDir </> macrosHeaderPath ]
]
resolveEntrypoint :: (IOish m, GmEnv m, GmLog m, GmState m)
resolveEntrypoint :: (IOish m, Gm m)
=> Cradle
-> GmComponent 'GMCRaw ChEntrypoint
-> m (GmComponent 'GMCRaw (Set ModulePath))
@ -341,7 +341,7 @@ chModToMod :: ChModuleName -> ModuleName
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)
resolveModule env _srcDirs (Right mn) =
liftIO $ traverse canonicalizeModulePath =<< findModulePath env mn
@ -373,7 +373,7 @@ resolveModule env srcDirs (Left fn') = do
type CompilationUnit = Either FilePath ModuleName
resolveGmComponents :: (IOish m, GmState m, GmLog m, GmEnv m)
resolveGmComponents :: (IOish m, Gm m)
=> Maybe [CompilationUnit]
-- ^ Updated modules
-> [GmComponent 'GMCRaw (Set ModulePath)]

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

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

38
src/GHCMod.hs
View File

@ -251,27 +251,27 @@ globalArgSpec =
[ option "v" ["verbose"] "Increase or set log level. (0-7)" $
optArg "LEVEL" $ \ml o -> Right $ case ml of
Nothing ->
modify (lLogLevel . lOutputOpts) increaseLogLevel o
modify (lOoptLogLevel . lOptOutput) increaseLogLevel o
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" $
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" $
NoArg $ \o -> Right $ set (lOutputStyle . lOutputOpts) LispStyle o
NoArg $ \o -> Right $ set (lOoptStyle . lOptOutput) LispStyle o
, 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"$
reqArg "OUT,ERR" $ \s o -> let
[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" $
reqArg "OPT" $ \g o -> Right $
o { ghcUserOptions = g : ghcUserOptions o }
o { optGhcUserOptions = g : optGhcUserOptions o }
{-
File map docs:
@ -313,19 +313,19 @@ Exposed functions:
(s,"") -> (s, Nothing)
(f,t) -> (f, Just t)
in
Right $ o { fileMappings = m : fileMappings o }
Right $ o { optFileMappings = m : optFileMappings o }
, 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)" $
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" $
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" $
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" $
NoArg $ \_ -> Left ["version"]
@ -406,7 +406,7 @@ progMain (globalOptions,cmdArgs) = hndle $ runGhcModT globalOptions $ handler $
case globalCommands cmdArgs of
Just s -> gmPutStr s
Nothing -> do
forM_ (reverse $ fileMappings globalOptions) $ uncurry loadMMappedFiles
forM_ (reverse $ optFileMappings globalOptions) $ uncurry loadMMappedFiles
ghcCommands cmdArgs
where
hndle action = do
@ -559,7 +559,7 @@ exitError msg = gmErrStrLn (dropWhileEnd (=='\n') msg) >> liftIO exitFailure
exitError' :: Options -> String -> IO a
exitError' opts msg = do
gmUnsafeErrStr (outputOpts opts) msg
gmUnsafeErrStr (optOutput opts) msg
liftIO exitFailure
fatalError :: String -> a
@ -654,24 +654,24 @@ locAction' cmd _ _ = throw $ InvalidCommandLine (Left cmd)
modulesArgSpec :: [OptDescr (Options -> Either [String] Options)]
modulesArgSpec =
[ 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 =
[ 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 =
[ 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." $
NoArg $ \o -> Right $ o { detailed = True }
NoArg $ \o -> Right $ o { optDetailed = True }
, option "q" ["qualified"] "Qualify symbols" $
NoArg $ \o -> Right $ o { qualified = True }
NoArg $ \o -> Right $ o { optQualified = True }
]
nukeCaches :: IOish m => GhcModT m ()

4
test/BrowseSpec.hs
View File

@ -17,12 +17,12 @@ spec = do
describe "browse -d Data.Either" $ 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"
syms `shouldContain` ["either :: (a -> c) -> (b -> c) -> Either a b -> c"]
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"
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"
[ghcOpts] <- map gmcGhcOpts . filter ((==ChExeName "new-template-exe") . gmcName) <$> runD' tdir getComponents
let pkgs = pkgOptions ghcOpts
pkgs `shouldBe` ["base", "bytestring"]
sort pkgs `shouldBe` ["base", "bytestring"]
it "extracts build dependencies" $ do
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.FilePath (pathSeparator)
import Test.Hspec
import TestUtils
import Prelude
import Dir
@ -36,14 +37,14 @@ spec = do
it "returns the current directory" $ do
withDirectory_ "/" $ do
curDir <- stripLastDot <$> canonicalizePath "/"
res <- clean_ $ findCradle (outputOpts defaultOptions)
res <- clean_ $ runGmOutDef findCradle
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_ (findCradle (outputOpts defaultOptions))
res <- relativeCradle dir <$> clean_ (runGmOutDef findCradle)
cradleCurrentDir res `shouldBe`
"test/data/cabal-project/subdir1/subdir2"
@ -55,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_ (findCradle (outputOpts defaultOptions))
res <- relativeCradle dir <$> clean_ (runGmOutDef findCradle)
cradleCurrentDir res `shouldBe`
"test" </> "data" </> "broken-sandbox"

2
test/InfoSpec.hs
View File

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

16
test/TestUtils.hs
View File

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