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

Merge branch 'dev-monad-refac'

Browse Source
This commit is contained in:
Daniel Gröber 2015-09-01 10:34:00 +02:00
commit e32eaf1434
33 changed files with 645 additions and 388 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Language/Haskell/GhcMod.hs
View File

@ -62,8 +62,8 @@ module Language.Haskell.GhcMod (
, gmErrStr , gmErrStr
, gmPutStrLn , gmPutStrLn
, gmErrStrLn , gmErrStrLn
, gmUnsafePutStrLn , gmUnsafePutStr
, gmUnsafeErrStrLn , gmUnsafeErrStr
-- * FileMapping -- * FileMapping
, loadMappedFile , loadMappedFile
, loadMappedFileSource , loadMappedFileSource

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"

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

@ -34,10 +34,10 @@ import Data.Maybe
import Data.Monoid import Data.Monoid
import Data.Serialize (Serialize) import Data.Serialize (Serialize)
import Data.Traversable import Data.Traversable
import Distribution.Helper import Distribution.Helper hiding (Programs(..))
import qualified Distribution.Helper as CH
import qualified Language.Haskell.GhcMod.Types as T import qualified Language.Haskell.GhcMod.Types as T
import Language.Haskell.GhcMod.Types hiding (ghcProgram, ghcPkgProgram, import Language.Haskell.GhcMod.Types
cabalProgram)
import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.Utils
import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.PathsAndFiles
@ -45,13 +45,15 @@ import Language.Haskell.GhcMod.Logging
import Language.Haskell.GhcMod.Output import Language.Haskell.GhcMod.Output
import System.FilePath import System.FilePath
import System.Directory (findExecutable) import System.Directory (findExecutable)
import System.Process
import System.Exit
import Prelude hiding ((.)) import Prelude hiding ((.))
import Paths_ghc_mod as GhcMod 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),
@ -63,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,
@ -84,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),
@ -114,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
@ -145,7 +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]
withCabal :: (IOish m, GmEnv m, GmLog m) => m a -> m a patchStackPrograms :: (IOish m, GmOut m) => Cradle -> Programs -> m Programs
patchStackPrograms crdl progs
| cradleProjectType crdl /= StackProject = return progs
patchStackPrograms crdl progs = do
let projdir = cradleRootDir crdl
Just ghc <- getStackGhcPath projdir
Just ghcPkg <- getStackGhcPkgPath projdir
return $ progs {
ghcProgram = ghc
, ghcPkgProgram = ghcPkg
}
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
@ -163,7 +177,7 @@ withCabal action = do
pkgDbStackOutOfSync <- pkgDbStackOutOfSync <-
case mCusPkgDbStack of case mCusPkgDbStack of
Just cusPkgDbStack -> do Just cusPkgDbStack -> do
pkgDb <- runQuery'' readProc (helperProgs opts) projdir distdir $ pkgDb <- runQuery'' readProc (helperProgs $ optPrograms opts) projdir distdir $
map chPkgToGhcPkg <$> packageDbStack map chPkgToGhcPkg <$> packageDbStack
return $ pkgDb /= cusPkgDbStack return $ pkgDb /= cusPkgDbStack
@ -185,31 +199,54 @@ withCabal action = do
|| isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $ || isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $
case projType of case projType of
CabalProject -> CabalProject ->
cabalReconfigure readProc opts crdl projdir distdir cabalReconfigure readProc (optPrograms opts) crdl projdir distdir
StackProject -> StackProject ->
-- https://github.com/commercialhaskell/stack/issues/820
gmLog GmWarning "" $ strDoc $ "Stack project configuration is out of date, please reconfigure manually using 'stack build'" stackReconfigure crdl (optPrograms opts)
_ -> _ ->
error $ "withCabal: unsupported project type: " ++ show projType error $ "withCabal: unsupported project type: " ++ show projType
action action
where where
cabalReconfigure readProc opts crdl projdir distdir = do cabalReconfigure readProc progs crdl projdir distdir = do
withDirectory_ (cradleRootDir crdl) $ do withDirectory_ (cradleRootDir crdl) $ do
cusPkgStack <- maybe [] ((PackageDb "clear"):) <$> getCustomPkgDbStack cusPkgStack <- maybe [] ((PackageDb "clear"):) <$> getCustomPkgDbStack
let progOpts = let progOpts =
[ "--with-ghc=" ++ T.ghcProgram opts ] [ "--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 opts /= T.ghcPkgProgram defaultOptions ++ if T.ghcPkgProgram progs /= T.ghcPkgProgram (optPrograms defaultOptions)
then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram opts ] then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram progs ]
else [] else []
++ map pkgDbArg cusPkgStack ++ map pkgDbArg cusPkgStack
liftIO $ void $ readProc (T.cabalProgram opts) ("configure":progOpts) "" liftIO $ void $ readProc (T.cabalProgram progs) ("configure":progOpts) ""
gmLog GmDebug "" $ strDoc $ "writing Cabal autogen files" gmLog GmDebug "" $ strDoc $ "writing Cabal autogen files"
liftIO $ writeAutogenFiles readProc projdir distdir liftIO $ writeAutogenFiles readProc projdir distdir
stackReconfigure crdl progs = do
withDirectory_ (cradleRootDir crdl) $ do
supported <- haveStackSupport
if supported
then do
spawn [T.stackProgram progs, "build", "--only-dependencies"]
spawn [T.stackProgram progs, "build", "--only-configure"]
else
gmLog GmWarning "" $ strDoc $ "Stack project configuration is out of date, please reconfigure manually using 'stack build' as your stack version is too old (need at least 1.4.0.0)"
spawn [] = return ()
spawn (exe:args) = do
readProc <- gmReadProcess
liftIO $ void $ readProc exe args ""
haveStackSupport = do
(rv, _, _) <-
liftIO $ readProcessWithExitCode "stack" ["--numeric-version"] ""
case rv of
ExitSuccess -> return True
ExitFailure _ -> return False
pkgDbArg :: GhcPkgDb -> String pkgDbArg :: GhcPkgDb -> String
pkgDbArg GlobalDb = "--package-db=global" pkgDbArg GlobalDb = "--package-db=global"
@ -233,14 +270,14 @@ isSetupConfigOutOfDate :: Maybe TimedFile -> Maybe TimedFile -> Bool
isSetupConfigOutOfDate worldCabalFile worldCabalConfig = do isSetupConfigOutOfDate worldCabalFile worldCabalConfig = do
worldCabalConfig < worldCabalFile worldCabalConfig < worldCabalFile
helperProgs :: Options -> Programs helperProgs :: Programs -> CH.Programs
helperProgs opts = Programs { helperProgs progs = CH.Programs {
cabalProgram = T.cabalProgram opts, cabalProgram = T.cabalProgram progs,
ghcProgram = T.ghcProgram opts, ghcProgram = T.ghcProgram progs,
ghcPkgProgram = T.ghcPkgProgram opts 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
@ -251,8 +288,10 @@ chCached c = do
-- we don't need to include the disdir in the cache input because when it -- we don't need to include the disdir in the cache input because when it
-- changes the cache files will be gone anyways ;) -- changes the cache files will be gone anyways ;)
cacheInputData root = do cacheInputData root = do
opt <- options opts <- options
return $ ( helperProgs opt crdl <- cradle
progs' <- patchStackPrograms crdl (optPrograms opts)
return $ ( helperProgs progs'
, root , root
, (gmVer, chVer) , (gmVer, chVer)
) )

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

@ -9,6 +9,7 @@ import Data.Maybe (isJust)
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
import Prelude
import qualified DataCon as Ty import qualified DataCon as Ty
import GHC (GhcMonad, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L)) import GHC (GhcMonad, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))
@ -48,12 +49,12 @@ 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
opt <- options oopts <- outputOpts
crdl <- cradle crdl <- cradle
style <- getStyle style <- getStyle
dflag <- G.getSessionDynFlags dflag <- G.getSessionDynFlags
modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl </> file) modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl </> file)
whenFound' opt (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> case x of whenFound' oopts (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> case x of
(SplitInfo varName bndLoc (varLoc,varT) _matches) -> do (SplitInfo varName bndLoc (varLoc,varT) _matches) -> do
let varName' = showName dflag style varName -- Convert name to string let varName' = showName dflag style varName -- Convert name to string
t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $ t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $
@ -68,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 =<< options emptyResult =<< outputOpts
---------------------------------------------------------------- ----------------------------------------------------------------
-- a. Code for getting the information of the variable -- a. Code for getting the information of the variable

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

@ -25,99 +25,99 @@ 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 <$> options convert' x = flip convert x . optOutput <$> options
convert :: ToString a => Options -> a -> String convert :: ToString a => OutputOpts -> a -> String
convert opt@Options { outputStyle = LispStyle } x = toLisp opt x "\n" convert opt@OutputOpts { ooptStyle = LispStyle } x = toLisp opt x "\n"
convert opt@Options { outputStyle = PlainStyle } x convert opt@OutputOpts { ooptStyle = PlainStyle } x
| str == "\n" = "" | str == "\n" = ""
| otherwise = str | otherwise = str
where where
str = toPlain opt x "\n" str = toPlain opt x "\n"
class ToString a where class ToString a where
toLisp :: Options -> a -> Builder toLisp :: OutputOpts -> a -> Builder
toPlain :: Options -> a -> Builder toPlain :: OutputOpts -> a -> Builder
lineSep :: Options -> String lineSep :: OutputOpts -> String
lineSep opt = interpret lsep lineSep oopts = interpret lsep
where where
interpret s = read $ "\"" ++ s ++ "\"" interpret s = read $ "\"" ++ s ++ "\""
LineSeparator lsep = lineSeparator opt LineSeparator lsep = ooptLineSeparator oopts
-- | -- |
-- --
-- >>> toLisp defaultOptions "fo\"o" "" -- >>> toLisp (outputOpts defaultOptions) "fo\"o" ""
-- "\"fo\\\"o\"" -- "\"fo\\\"o\""
-- >>> toPlain defaultOptions "foo" "" -- >>> toPlain (outputOpts defaultOptions) "foo" ""
-- "foo" -- "foo"
instance ToString String where instance ToString String where
toLisp opt = quote opt toLisp oopts = quote oopts
toPlain opt = replace '\n' (lineSep opt) toPlain oopts = replace '\n' (lineSep oopts)
-- | -- |
-- --
-- >>> toLisp defaultOptions ["foo", "bar", "ba\"z"] "" -- >>> toLisp (outputOpts defaultOptions) ["foo", "bar", "ba\"z"] ""
-- "(\"foo\" \"bar\" \"ba\\\"z\")" -- "(\"foo\" \"bar\" \"ba\\\"z\")"
-- >>> toPlain defaultOptions ["foo", "bar", "baz"] "" -- >>> toPlain (outputOpts defaultOptions) ["foo", "bar", "baz"] ""
-- "foo\nbar\nbaz" -- "foo\nbar\nbaz"
instance ToString [String] where instance ToString [String] where
toLisp opt = toSexp1 opt toLisp oopts = toSexp1 oopts
toPlain opt = inter '\n' . map (toPlain opt) toPlain oopts = inter '\n' . map (toPlain oopts)
instance ToString [ModuleString] where instance ToString [ModuleString] where
toLisp opt = toLisp opt . map getModuleString toLisp oopts = toLisp oopts . map getModuleString
toPlain opt = toPlain opt . map getModuleString toPlain oopts = toPlain oopts . map getModuleString
-- | -- |
-- --
-- >>> let inp = [((1,2,3,4),"foo"),((5,6,7,8),"bar")] :: [((Int,Int,Int,Int),String)] -- >>> let inp = [((1,2,3,4),"foo"),((5,6,7,8),"bar")] :: [((Int,Int,Int,Int),String)]
-- >>> toLisp defaultOptions inp "" -- >>> toLisp (outputOpts defaultOptions) inp ""
-- "((1 2 3 4 \"foo\") (5 6 7 8 \"bar\"))" -- "((1 2 3 4 \"foo\") (5 6 7 8 \"bar\"))"
-- >>> toPlain defaultOptions inp "" -- >>> toPlain (outputOpts defaultOptions) inp ""
-- "1 2 3 4 \"foo\"\n5 6 7 8 \"bar\"" -- "1 2 3 4 \"foo\"\n5 6 7 8 \"bar\""
instance ToString [((Int,Int,Int,Int),String)] where instance ToString [((Int,Int,Int,Int),String)] where
toLisp opt = toSexp2 . map toS toLisp oopts = toSexp2 . map toS
where where
toS x = ('(' :) . tupToString opt x . (')' :) toS x = ('(' :) . tupToString oopts x . (')' :)
toPlain opt = inter '\n' . map (tupToString opt) toPlain oopts = inter '\n' . map (tupToString oopts)
instance ToString ((Int,Int,Int,Int),String) where instance ToString ((Int,Int,Int,Int),String) where
toLisp opt x = ('(' :) . tupToString opt x . (')' :) toLisp oopts x = ('(' :) . tupToString oopts x . (')' :)
toPlain opt x = tupToString opt x toPlain oopts x = tupToString oopts x
instance ToString ((Int,Int,Int,Int),[String]) where instance ToString ((Int,Int,Int,Int),[String]) where
toLisp opt (x,s) = ('(' :) . fourIntsToString opt x . toLisp oopts (x,s) = ('(' :) . fourIntsToString x .
(' ' :) . toLisp opt s . (')' :) (' ' :) . toLisp oopts s . (')' :)
toPlain opt (x,s) = fourIntsToString opt x . ('\n' :) . toPlain opt s toPlain oopts (x,s) = fourIntsToString x . ('\n' :) . toPlain oopts s
instance ToString (String, (Int,Int,Int,Int),[String]) where instance ToString (String, (Int,Int,Int,Int),[String]) where
toLisp opt (s,x,y) = toSexp2 [toLisp opt s, ('(' :) . fourIntsToString opt x . (')' :), toLisp opt y] toLisp oopts (s,x,y) = toSexp2 [toLisp oopts s, ('(' :) . fourIntsToString x . (')' :), toLisp oopts y]
toPlain opt (s,x,y) = inter '\n' [toPlain opt s, fourIntsToString opt x, toPlain opt y] toPlain oopts (s,x,y) = inter '\n' [toPlain oopts s, fourIntsToString x, toPlain oopts y]
toSexp1 :: Options -> [String] -> Builder toSexp1 :: OutputOpts -> [String] -> Builder
toSexp1 opt ss = ('(' :) . inter ' ' (map (quote opt) ss) . (')' :) toSexp1 oopts ss = ('(' :) . inter ' ' (map (quote oopts) ss) . (')' :)
toSexp2 :: [Builder] -> Builder toSexp2 :: [Builder] -> Builder
toSexp2 ss = ('(' :) . inter ' ' ss . (')' :) toSexp2 ss = ('(' :) . inter ' ' ss . (')' :)
fourIntsToString :: Options -> (Int,Int,Int,Int) -> Builder fourIntsToString :: (Int,Int,Int,Int) -> Builder
fourIntsToString _ (a,b,c,d) = (show a ++) . (' ' :) fourIntsToString (a,b,c,d) = (show a ++) . (' ' :)
. (show b ++) . (' ' :) . (show b ++) . (' ' :)
. (show c ++) . (' ' :) . (show c ++) . (' ' :)
. (show d ++) . (show d ++)
tupToString :: Options -> ((Int,Int,Int,Int),String) -> Builder tupToString :: OutputOpts -> ((Int,Int,Int,Int),String) -> Builder
tupToString opt ((a,b,c,d),s) = (show a ++) . (' ' :) tupToString oopts ((a,b,c,d),s) = (show a ++) . (' ' :)
. (show b ++) . (' ' :) . (show b ++) . (' ' :)
. (show c ++) . (' ' :) . (show c ++) . (' ' :)
. (show d ++) . (' ' :) . (show d ++) . (' ' :)
. quote opt s -- fixme: quote is not necessary . quote oopts s -- fixme: quote is not necessary
quote :: Options -> String -> Builder quote :: OutputOpts -> String -> Builder
quote opt str = ("\"" ++) . (quote' str ++) . ("\"" ++) quote oopts str = ("\"" ++) . (quote' str ++) . ("\"" ++)
where where
lsep = lineSep opt lsep = lineSep oopts
quote' [] = [] quote' [] = []
quote' (x:xs) quote' (x:xs)
| x == '\n' = lsep ++ quote' xs | x == '\n' = lsep ++ quote' xs
@ -128,13 +128,13 @@ quote opt str = ("\"" ++) . (quote' str ++) . ("\"" ++)
---------------------------------------------------------------- ----------------------------------------------------------------
-- Empty result to be returned when no info can be gathered -- Empty result to be returned when no info can be gathered
emptyResult :: Monad m => Options -> m String emptyResult :: Monad m => OutputOpts -> m String
emptyResult opt = return $ convert opt ([] :: [String]) emptyResult oopts = return $ convert oopts ([] :: [String])
-- Return an emptyResult when Nothing -- Return an emptyResult when Nothing
whenFound :: (Monad m, ToString b) => Options -> m (Maybe a) -> (a -> b) -> m String whenFound :: (Monad m, ToString b) => OutputOpts -> m (Maybe a) -> (a -> b) -> m String
whenFound opt from f = maybe (emptyResult opt) (return . convert opt . f) =<< from whenFound oopts from f = maybe (emptyResult oopts) (return . convert oopts . f) =<< from
-- Return an emptyResult when Nothing, inside a monad -- Return an emptyResult when Nothing, inside a monad
whenFound' :: (Monad m, ToString b) => Options -> m (Maybe a) -> (a -> m b) -> m String whenFound' :: (Monad m, ToString b) => OutputOpts -> m (Maybe a) -> (a -> m b) -> m String
whenFound' opt from f = maybe (emptyResult opt) (\x -> do y <- f x ; return (convert opt y)) =<< from whenFound' oopts from f = maybe (emptyResult oopts) (\x -> do y <- f x ; return (convert oopts y)) =<< from

32
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 :: IO Cradle findCradle :: (IOish m, GmOut m) => m Cradle
findCradle = findCradle' =<< getCurrentDirectory findCradle = findCradle' =<< liftIO getCurrentDirectory
findCradle' :: FilePath -> IO Cradle findCradle' :: (IOish m, GmOut m) => FilePath -> m Cradle
findCradle' dir = run $ do findCradle' dir = run $
(stackCradle 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,13 +77,13 @@ cabalCradle wdir = do
, cradleDistDir = "dist" , cradleDistDir = "dist"
} }
stackCradle :: FilePath -> MaybeT IO Cradle stackCradle :: (IOish m, GmOut m) => FilePath -> MaybeT m Cradle
stackCradle 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 ;)
@ -96,9 +100,9 @@ stackCradle 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

3
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]
@ -53,6 +53,7 @@ cabalDebug = do
return $ return $
[ "Cabal file: " ++ show cradleCabalFile [ "Cabal file: " ++ show cradleCabalFile
, "Cabal Project Type: " ++ show cradleProjectType
, "Cabal entrypoints:\n" ++ render (nest 4 $ , "Cabal entrypoints:\n" ++ render (nest 4 $
mapDoc gmComponentNameDoc smpDoc entrypoints) mapDoc gmComponentNameDoc smpDoc entrypoints)
, "Cabal components:\n" ++ render (nest 4 $ , "Cabal components:\n" ++ render (nest 4 $

7
Language/Haskell/GhcMod/Error.hs
View File

@ -126,12 +126,12 @@ gmeDoc e = case e of
compsDoc sc = fsep $ punctuate comma $ compsDoc sc = fsep $ punctuate comma $
map gmComponentNameDoc $ Set.toList sc map gmComponentNameDoc $ Set.toList sc
GMEProcess cmd args emsg -> let c = showCommandForUser cmd args in GMEProcess _fn cmd args emsg -> let c = showCommandForUser cmd args in
case emsg of case emsg of
Right err -> Right err ->
text (printf "Launching system command `%s` failed: " c) text (printf "Launching system command `%s` failed: " c)
<> gmeDoc err <> gmeDoc err
Left (_out, _err, rv) -> text $ Left rv -> text $
printf "Launching system command `%s` failed (exited with %d)" c rv printf "Launching system command `%s` failed (exited with %d)" c rv
GMENoCabalFile -> GMENoCabalFile ->
text "No cabal file found." text "No cabal file found."
@ -140,6 +140,9 @@ gmeDoc e = case e of
++ intercalate "\", \"" cfs ++"\"." ++ intercalate "\", \"" cfs ++"\"."
GMECabalStateFile csfe -> GMECabalStateFile csfe ->
gmCsfeDoc csfe gmCsfeDoc csfe
GMEStackBootrap msg ->
(text $ "Boostrapping stack project failed")
<+>: text msg
ghcExceptionDoc :: GhcException -> Doc ghcExceptionDoc :: GhcException -> Doc
ghcExceptionDoc e@(CmdLineError _) = ghcExceptionDoc e@(CmdLineError _) =

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

@ -9,15 +9,27 @@ module Language.Haskell.GhcMod.FillSig (
import Data.Char (isSymbol) import Data.Char (isSymbol)
import Data.Function (on) import Data.Function (on)
import Data.Functor
import Data.List (find, nub, sortBy) import Data.List (find, nub, sortBy)
import qualified Data.Map as M import qualified Data.Map as M
import Data.Maybe (catMaybes) import Data.Maybe (catMaybes)
import Text.PrettyPrint (($$), text, nest) import Text.PrettyPrint (($$), text, nest)
import Prelude
import Exception (ghandle, SomeException(..)) import Exception (ghandle, SomeException(..))
import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags,
SrcSpan, Type, GenLocated(L)) SrcSpan, Type, GenLocated(L))
import qualified GHC as G import qualified GHC as G
import qualified Name as G import qualified Name as G
import Outputable (PprStyle)
import qualified Type as Ty
import qualified HsBinds as Ty
import qualified Class as Ty
import qualified Var as Ty
import qualified HsPat as Ty
import qualified Language.Haskell.Exts.Annotated as HE
import Djinn.GHC
import qualified Language.Haskell.GhcMod.Gap as Gap import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.DynFlags import Language.Haskell.GhcMod.DynFlags
@ -28,14 +40,6 @@ import Language.Haskell.GhcMod.Pretty (showDoc)
import Language.Haskell.GhcMod.Doc import Language.Haskell.GhcMod.Doc
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.FileMapping (fileModSummaryWithMapping) import Language.Haskell.GhcMod.FileMapping (fileModSummaryWithMapping)
import Outputable (PprStyle)
import qualified Type as Ty
import qualified HsBinds as Ty
import qualified Class as Ty
import qualified Var as Ty
import qualified HsPat as Ty
import qualified Language.Haskell.Exts.Annotated as HE
import Djinn.GHC
#if __GLASGOW_HASKELL__ >= 710 #if __GLASGOW_HASKELL__ >= 710
import GHC (unLoc) import GHC (unLoc)
@ -74,11 +78,11 @@ 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
opt <- options oopts <- outputOpts
style <- getStyle style <- getStyle
dflag <- G.getSessionDynFlags dflag <- G.getSessionDynFlags
modSum <- fileModSummaryWithMapping file modSum <- fileModSummaryWithMapping file
whenFound opt (getSignature modSum lineNo colNo) $ \s -> whenFound oopts (getSignature modSum lineNo colNo) $ \s ->
case s of case s of
Signature loc names ty -> Signature loc names ty ->
("function", fourInts loc, map (initialBody dflag style ty) names) ("function", fourInts loc, map (initialBody dflag style ty) names)
@ -93,10 +97,10 @@ sig file lineNo colNo =
in (rTy, fourInts loc, [initial ++ body]) in (rTy, fourInts loc, [initial ++ body])
where where
fallback (SomeException _) = do fallback (SomeException _) = do
opt <- 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 opt (getSignatureFromHE file lineNo colNo) $ \x -> case x of whenFound oopts (getSignatureFromHE file lineNo colNo) $ \x -> case x of
HESignature loc names ty -> HESignature loc names ty ->
("function", fourIntsHE loc, map (initialBody undefined undefined ty) names) ("function", fourIntsHE loc, map (initialBody undefined undefined ty) names)
HEFamSignature loc flavour name vars -> HEFamSignature loc flavour name vars ->
@ -343,14 +347,14 @@ 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
opt <- options oopts <- outputOpts
style <- getStyle style <- getStyle
dflag <- G.getSessionDynFlags dflag <- G.getSessionDynFlags
modSum <- fileModSummaryWithMapping file modSum <- fileModSummaryWithMapping file
p <- G.parseModule modSum p <- G.parseModule modSum
tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
ety <- G.exprType expr ety <- G.exprType expr
whenFound opt (findVar dflag style tcm tcs lineNo colNo) $ whenFound oopts (findVar dflag style tcm tcs lineNo colNo) $
\(loc, name, rty, paren) -> \(loc, name, rty, paren) ->
let eArgs = getFnArgs ety let eArgs = getFnArgs ety
rArgs = getFnArgs rty rArgs = getFnArgs rty
@ -363,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 =<< options emptyResult =<< outputOpts
-- Look for the variable in the specified position -- Look for the variable in the specified position
findVar findVar
@ -420,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
opt <- options oopts <- outputOpts
style <- getStyle style <- getStyle
dflag <- G.getSessionDynFlags dflag <- G.getSessionDynFlags
modSum <- fileModSummaryWithMapping file modSum <- fileModSummaryWithMapping file
@ -429,7 +433,7 @@ auto file lineNo colNo =
tm_typechecked_source = tcs tm_typechecked_source = tcs
, tm_checked_module_info = minfo , tm_checked_module_info = minfo
} <- G.typecheckModule p } <- G.typecheckModule p
whenFound' opt (findVar dflag style tcm tcs lineNo colNo) $ \(loc, _name, rty, paren) -> do whenFound' oopts (findVar dflag style tcm tcs lineNo colNo) $ \(loc, _name, rty, paren) -> do
topLevel <- getEverythingInTopLevel minfo topLevel <- getEverythingInTopLevel minfo
let (f,pats) = getPatsForVariable tcs (lineNo,colNo) let (f,pats) = getPatsForVariable tcs (lineNo,colNo)
-- Remove self function to prevent recursion, and id to trim -- Remove self function to prevent recursion, and id to trim
@ -452,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 =<< 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 <$> 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

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

@ -75,14 +75,14 @@ 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
opts <- options oopts <- outputOpts
let conv = convert opts let conv = convert oopts
eres <- withLogger' env $ \setDf -> eres <- withLogger' env $ \setDf ->
withDynFlags (f . setDf) action withDynFlags (f . setDf) action
return $ either (Left . conv) (Right . first conv) eres return $ either (Left . conv) (Right . first conv) eres

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

48
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,25 +52,24 @@ import Exception (ExceptionMonad(..))
import System.Directory import System.Directory
import Prelude import Prelude
withCradle :: IOish m => FilePath -> (Cradle -> m a) -> m a withCradle :: (IOish m, GmOut m) => FilePath -> (Cradle -> m a) -> m a
withCradle cradledir f = withCradle cradledir f =
gbracket (liftIO $ findCradle' 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 opt f = withCradle dir (withGhcModEnv' opt f) withGhcModEnv dir 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' opt 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 opt of
Just _ -> GmOutputChan c
Nothing -> GmOutputStdio
gbracket_ (setup c) (teardown olddir) (f $ GhcModEnv opt crdl outp)
where where
setup c = liftIO $ do setup = do
setCurrentDirectory $ cradleRootDir crdl c <- gmoChan <$> gmoAsk
forkIO $ stdoutGateway c liftIO $ do
setCurrentDirectory $ cradleRootDir crdl
forkIO $ stdoutGateway c
teardown olddir tid = liftIO $ do teardown olddir tid = liftIO $ do
setCurrentDirectory olddir setCurrentDirectory olddir
@ -91,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
withGhcModEnv dir' opt $ \env -> gmo <- GhcModOut (optOutput opt) <$> liftIO newChan
first (fst <$>) <$> runGhcModT'' env defaultGhcModState runGmOutT gmo $
(gmSetLogLevel (logLevel opt) >> action) 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 -- | @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
@ -107,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'.
@ -116,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

226
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,20 +117,28 @@ 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
(ErrorT GhcModError #if DIFFERENT_MONADIO
(JournalT GhcModLog , GHC.MonadIO
(ReaderT GhcModEnv m) ) ) a #endif
, GmLog
)
newtype GmT m a = GmT {
unGmT :: StateT GhcModState
(ErrorT GhcModError
(JournalT GhcModLog
(ReaderT GhcModEnv m) ) ) a
} deriving ( Functor } deriving ( Functor
, Applicative , Applicative
, Alternative , Alternative
@ -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

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

@ -22,9 +22,9 @@ module Language.Haskell.GhcMod.Output (
, gmErrStr , gmErrStr
, gmPutStrLn , gmPutStrLn
, gmErrStrLn , gmErrStrLn
, gmUnsafePutStrLn
, gmUnsafeErrStrLn
, gmReadProcess , gmReadProcess
, gmUnsafePutStr
, gmUnsafeErrStr
, stdoutGateway , stdoutGateway
) where ) where
@ -36,6 +36,7 @@ import Control.Monad
import Control.DeepSeq import Control.DeepSeq
import Control.Exception import Control.Exception
import Control.Concurrent import Control.Concurrent
import Prelude
import Language.Haskell.GhcMod.Types hiding (LineSeparator) import Language.Haskell.GhcMod.Types hiding (LineSeparator)
import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Monad.Types
@ -62,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 =
opts <- options outputFns' <$> gmoAsk
env <- gmeAsk
return $ outputFns' opts (gmOutput env)
outputFns' :: MonadIO m' pfxFns :: Maybe (String, String) -> (GmLines String -> GmLines String, GmLines String -> GmLines String)
=> Options pfxFns lpfx = case lpfx of
-> GmOutput Nothing -> ( id, id )
-> (GmLines String -> m' (), GmLines String -> m' ()) Just (op, ep) -> ( fmap $ pfx (op++), fmap $ pfx (ep++) )
outputFns' opts output = let where
Options {..} = opts 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 chanOutputFns :: MonadIO m
(outPfx, errPfx) = => Chan (GmStream, GmLines String)
case linePrefix of -> Maybe (String, String)
Nothing -> ( id, id ) -> (GmLines String -> m (), GmLines String -> m ())
Just (op, ep) -> ( fmap $ pfx (op++), fmap $ pfx (ep++) ) 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 in
case output of case ooptLinePrefix of
GmOutputStdio -> Nothing -> stdioOutputFns ooptLinePrefix
( liftIO . putStr . unGmLine . outPfx Just _ -> chanOutputFns c ooptLinePrefix
, liftIO . hPutStr stderr . unGmLine . errPfx)
GmOutputChan c ->
( liftIO . writeChan c . (,) GmOut . outPfx
, liftIO . writeChan c . (,) GmErr .errPfx)
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
@ -107,18 +116,18 @@ gmErrStr str = do
putErr $ toGmLines str putErr $ toGmLines str
-- | 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
gmUnsafePutStrLn, gmUnsafeErrStrLn gmUnsafePutStr, gmUnsafeErrStr
:: MonadIO m => Options -> String -> m () :: MonadIO m => OutputOpts -> String -> m ()
gmUnsafePutStrLn opts = (fst $ outputFns' opts GmOutputStdio) . toGmLines gmUnsafePutStr oopts = (fst $ stdioOutputFns (ooptLinePrefix oopts)) . toGmLines
gmUnsafeErrStrLn opts = (snd $ outputFns' opts GmOutputStdio) . toGmLines gmUnsafeErrStr oopts = (snd $ stdioOutputFns (ooptLinePrefix oopts)) . toGmLines
gmReadProcess :: GmEnv m => m (FilePath -> [String] -> String -> IO String) gmReadProcess :: GmOut 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 ()
@ -129,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)
@ -139,15 +148,20 @@ 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) <- outputFns (_, e :: GmLines String -> IO ()) <- outputFns
return $ go e return $ readProcessStderrChan' e
readProcessStderrChan' ::
(GmLines String -> IO ())
-> FilePath -> [String] -> String -> IO String
readProcessStderrChan' pute = go pute
where where
go :: (GmLines String -> IO ()) -> FilePath -> [String] -> String -> IO String go :: (GmLines String -> IO ()) -> FilePath -> [String] -> String -> IO String
go putErr exe args input = do go putErr exe args input = do
@ -176,7 +190,7 @@ readProcessStderrChan = do
res <- waitForProcess h res <- waitForProcess h
case res of case res of
ExitFailure rv -> ExitFailure rv ->
processFailedException "readProcessStderrChan" exe args rv throw $ GMEProcess "readProcessStderrChan" exe args $ Left rv
ExitSuccess -> ExitSuccess ->
return output return output
where where
@ -192,9 +206,3 @@ withForkWait async body = do
tid <- forkIO $ try (restore async) >>= putMVar waitVar tid <- forkIO $ try (restore async) >>= putMVar waitVar
let wait = takeMVar waitVar >>= either throwIO return let wait = takeMVar waitVar >>= either throwIO return
restore (body wait) `onException` killThread tid restore (body wait) `onException` killThread tid
processFailedException :: String -> String -> [String] -> Int -> IO a
processFailedException fn exe args rv =
error $ concat [ fn, ": ", exe, " "
, intercalate " " (map show args)
, " (exit " ++ show rv ++ ")"]

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

@ -21,8 +21,10 @@ module Language.Haskell.GhcMod.PathsAndFiles (
import Config (cProjectVersion) import Config (cProjectVersion)
import Control.Applicative import Control.Applicative
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
@ -31,10 +33,12 @@ import Distribution.Helper (buildPlatform)
import System.Directory import System.Directory
import System.FilePath import System.FilePath
import System.Process import System.Process
import System.Info.Extra
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Caching import Language.Haskell.GhcMod.Caching
import Language.Haskell.GhcMod.Output
import qualified Language.Haskell.GhcMod.Utils as U import qualified Language.Haskell.GhcMod.Utils as U
import Utils (mightExist) import Utils (mightExist)
import Prelude import Prelude
@ -75,10 +79,38 @@ 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 :: FilePath -> IO (Maybe FilePath) getStackDistDir :: (IOish m, GmOut m) => FilePath -> m (Maybe FilePath)
getStackDistDir dir = U.withDirectory_ dir $ runMaybeT $ do getStackDistDir projdir = U.withDirectory_ projdir $ runMaybeT $ do
stack <- MaybeT $ findExecutable "stack" takeWhile (/='\n') <$> readStack ["path", "--dist-dir"]
liftIO $ takeWhile (/='\n') <$> readProcess stack ["path", "--dist-dir"] ""
getStackGhcPath :: (IOish m, GmOut m) => FilePath -> m (Maybe FilePath)
getStackGhcPath = findExecutablesInStackBinPath "ghc"
getStackGhcPkgPath :: (IOish m, GmOut m) => FilePath -> m (Maybe FilePath)
getStackGhcPkgPath = findExecutablesInStackBinPath "ghc-pkg"
findExecutablesInStackBinPath :: (IOish m, GmOut m) => String -> FilePath -> m (Maybe FilePath)
findExecutablesInStackBinPath exe projdir =
U.withDirectory_ projdir $ runMaybeT $ do
path <- splitSearchPath . takeWhile (/='\n')
<$> readStack ["path", "--bin-path"]
MaybeT $ liftIO $ listToMaybe <$> findExecutablesInDirectories' path exe
findExecutablesInDirectories' :: [FilePath] -> String -> IO [FilePath]
findExecutablesInDirectories' path binary =
U.findFilesWith' isExecutable path (binary <.> exeExtension)
where isExecutable file = do
perms <- getPermissions file
return $ executable perms
exeExtension = if isWindows then "exe" else ""
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 =<< 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)]

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

@ -1,4 +1,4 @@
{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, RankNTypes,
StandaloneDeriving, DefaultSignatures, FlexibleInstances, TemplateHaskell #-} StandaloneDeriving, DefaultSignatures, FlexibleInstances, TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-} {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-}
module Language.Haskell.GhcMod.Types ( module Language.Haskell.GhcMod.Types (
@ -27,7 +27,8 @@ import Data.Maybe
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import Data.IORef import Data.IORef
import Data.Label.Derive import Data.Label.Derive
import Distribution.Helper import Distribution.Helper hiding (Programs(..))
import qualified Distribution.Helper as CabalHelper
import Exception (ExceptionMonad) import Exception (ExceptionMonad)
#if __GLASGOW_HASKELL__ < 708 #if __GLASGOW_HASKELL__ < 708
import qualified MonadUtils as GHC (MonadIO(..)) import qualified MonadUtils as GHC (MonadIO(..))
@ -74,49 +75,66 @@ data FileMapping = FileMapping {fmPath :: FilePath, fmTemp :: Bool}
type FileMappingMap = Map FilePath FileMapping type FileMappingMap = Map FilePath FileMapping
data Options = Options { data ProgramSource = ProgramSourceUser | ProgramSourceStack
outputStyle :: OutputStyle
-- | Line separator string. data Programs = Programs {
, lineSeparator :: LineSeparator
-- | Stdout/err line multiplexing using prefix encoding. @fst@ is stdout,
-- @snd@ is stderr prefix.
, linePrefix :: Maybe (String, String)
-- | Verbosity
, logLevel :: GmLogLevel
-- | @ghc@ program name. -- | @ghc@ program name.
, ghcProgram :: FilePath ghcProgram :: FilePath
-- | @ghc-pkg@ program name. -- | @ghc-pkg@ program name.
, ghcPkgProgram :: FilePath , ghcPkgProgram :: FilePath
-- | @cabal@ program name. -- | @cabal@ program name.
, cabalProgram :: FilePath , cabalProgram :: FilePath
-- | @stack@ program name.
, stackProgram :: FilePath
} deriving (Show)
data OutputOpts = OutputOpts {
-- | Verbosity
ooptLogLevel :: GmLogLevel
, ooptStyle :: OutputStyle
-- | Line separator string.
, ooptLineSeparator :: LineSeparator
-- | Stdout/err line multiplexing using prefix encoding. @fst@ is stdout,
-- @snd@ is stderr prefix.
, ooptLinePrefix :: Maybe (String, String)
} deriving (Show)
data Options = Options {
optOutput :: OutputOpts
, 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 {
outputStyle = PlainStyle optOutput = OutputOpts {
, lineSeparator = LineSeparator "\0" ooptLogLevel = GmWarning
, linePrefix = Nothing , ooptStyle = PlainStyle
, logLevel = GmWarning , ooptLineSeparator = LineSeparator "\0"
, ghcProgram = "ghc" , ooptLinePrefix = Nothing
, ghcPkgProgram = "ghc-pkg" }
, cabalProgram = "cabal" , optPrograms = Programs {
, ghcUserOptions = [] ghcProgram = "ghc"
, operators = False , ghcPkgProgram = "ghc-pkg"
, detailed = False , cabalProgram = "cabal"
, qualified = False , stackProgram = "stack"
, hlintOpts = [] }
, fileMappings = [] , optGhcUserOptions = []
, optOperators = False
, optDetailed = False
, optQualified = False
, optHlintOpts = []
, optFileMappings = []
} }
---------------------------------------------------------------- ----------------------------------------------------------------
@ -140,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
@ -152,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 {
@ -354,9 +373,9 @@ data GhcModError
| GMECabalCompAssignment [(Either FilePath ModuleName, Set ChComponentName)] | GMECabalCompAssignment [(Either FilePath ModuleName, Set ChComponentName)]
-- ^ Could not find a consistent component assignment for modules -- ^ Could not find a consistent component assignment for modules
| GMEProcess String [String] (Either (String, String, Int) GhcModError) | GMEProcess String String [String] (Either Int GhcModError)
-- ^ Launching an operating system process failed. Fields in -- ^ Launching an operating system process failed. Fields in
-- order: command, arguments, (stdout, stderr, exitcode) -- order: function, command, arguments, (stdout, stderr, exitcode)
| GMENoCabalFile | GMENoCabalFile
-- ^ No cabal file found. -- ^ No cabal file found.
@ -366,6 +385,9 @@ data GhcModError
| GMECabalStateFile GMConfigStateFileError | GMECabalStateFile GMConfigStateFileError
-- ^ Reading Cabal's state configuration file falied somehow. -- ^ Reading Cabal's state configuration file falied somehow.
| GMEStackBootrap String
-- ^ Bootstrapping @stack@ environment failed (process exited with failure)
deriving (Eq,Show,Typeable) deriving (Eq,Show,Typeable)
instance Error GhcModError where instance Error GhcModError where
@ -386,10 +408,13 @@ data GMConfigStateFileError
deriving instance Generic Version deriving instance Generic Version
instance Serialize Version instance Serialize Version
instance Serialize Programs instance Serialize CabalHelper.Programs
instance Serialize ChModuleName instance Serialize ChModuleName
instance Serialize ChComponentName instance Serialize ChComponentName
instance Serialize ChEntrypoint instance Serialize ChEntrypoint
mkLabel ''GhcModCaches mkLabel ''GhcModCaches
mkLabel ''GhcModState mkLabel ''GhcModState
mkLabel ''Options
mkLabel ''OutputOpts
mkLabel ''Programs

11
Language/Haskell/GhcMod/Utils.hs
View File

@ -197,3 +197,14 @@ mkRevRedirMapFunc = do
where where
mf :: FilePath -> FileMapping -> (FilePath, FilePath) mf :: FilePath -> FileMapping -> (FilePath, FilePath)
mf from to = (fmPath to, from) mf from to = (fmPath to, from)
findFilesWith' :: (FilePath -> IO Bool) -> [FilePath] -> String -> IO [FilePath]
findFilesWith' _ [] _ = return []
findFilesWith' f (d:ds) fileName = do
let file = d </> fileName
exist <- doesFileExist file
b <- if exist then f file else return False
if b then do
files <- findFilesWith' f ds fileName
return $ file : files
else findFilesWith' f ds fileName

14
ghc-mod.cabal
View File

@ -98,11 +98,9 @@ Library
GHC-Options: -Wall -fno-warn-deprecations GHC-Options: -Wall -fno-warn-deprecations
Default-Extensions: ScopedTypeVariables, RecordWildCards, NamedFieldPuns, Default-Extensions: ScopedTypeVariables, RecordWildCards, NamedFieldPuns,
ConstraintKinds, FlexibleContexts, ConstraintKinds, FlexibleContexts,
DataKinds, KindSignatures, TypeOperators DataKinds, KindSignatures, TypeOperators, ViewPatterns
Exposed-Modules: Language.Haskell.GhcMod Exposed-Modules: Language.Haskell.GhcMod
Language.Haskell.GhcMod.Internal Language.Haskell.GhcMod.Internal
Other-Modules: Paths_ghc_mod
Utils
Language.Haskell.GhcMod.Boot Language.Haskell.GhcMod.Boot
Language.Haskell.GhcMod.Browse Language.Haskell.GhcMod.Browse
Language.Haskell.GhcMod.CabalHelper Language.Haskell.GhcMod.CabalHelper
@ -142,6 +140,8 @@ Library
Language.Haskell.GhcMod.Types Language.Haskell.GhcMod.Types
Language.Haskell.GhcMod.Utils Language.Haskell.GhcMod.Utils
Language.Haskell.GhcMod.World Language.Haskell.GhcMod.World
Other-Modules: Paths_ghc_mod
Utils
Build-Depends: base >= 4.0 && < 5 Build-Depends: base >= 4.0 && < 5
, bytestring , bytestring
, cereal >= 0.4 , cereal >= 0.4
@ -169,7 +169,8 @@ Library
, haskell-src-exts , haskell-src-exts
, text , text
, djinn-ghc >= 0.0.2.2 , djinn-ghc >= 0.0.2.2
, fclabels , fclabels == 2.0.*
, extra == 1.4.*
if impl(ghc < 7.8) if impl(ghc < 7.8)
Build-Depends: convertible Build-Depends: convertible
if impl(ghc < 7.5) if impl(ghc < 7.5)
@ -181,7 +182,7 @@ Executable ghc-mod
Default-Language: Haskell2010 Default-Language: Haskell2010
Main-Is: GHCMod.hs Main-Is: GHCMod.hs
Other-Modules: Paths_ghc_mod Other-Modules: Paths_ghc_mod
GHC-Options: -Wall -fno-warn-deprecations GHC-Options: -Wall -fno-warn-deprecations -threaded
Default-Extensions: ConstraintKinds, FlexibleContexts Default-Extensions: ConstraintKinds, FlexibleContexts
HS-Source-Dirs: src HS-Source-Dirs: src
Build-Depends: base >= 4.0 && < 5 Build-Depends: base >= 4.0 && < 5
@ -194,6 +195,7 @@ Executable ghc-mod
, mtl >= 2.0 , mtl >= 2.0
, ghc , ghc
, ghc-mod , ghc-mod
, fclabels == 2.0.*
Executable ghc-modi Executable ghc-modi
Default-Language: Haskell2010 Default-Language: Haskell2010
@ -229,7 +231,7 @@ Test-Suite spec
Default-Language: Haskell2010 Default-Language: Haskell2010
Default-Extensions: ScopedTypeVariables, RecordWildCards, NamedFieldPuns, Default-Extensions: ScopedTypeVariables, RecordWildCards, NamedFieldPuns,
ConstraintKinds, FlexibleContexts, ConstraintKinds, FlexibleContexts,
DataKinds, KindSignatures, TypeOperators DataKinds, KindSignatures, TypeOperators, ViewPatterns
Main-Is: Main.hs Main-Is: Main.hs
Hs-Source-Dirs: test, . Hs-Source-Dirs: test, .
Ghc-Options: -Wall -fno-warn-deprecations Ghc-Options: -Wall -fno-warn-deprecations

86
src/GHCMod.hs
View File

@ -3,12 +3,13 @@
module Main where module Main where
import Config (cProjectVersion) import Config (cProjectVersion)
import MonadUtils (liftIO) import Control.Category
import Control.Applicative import Control.Applicative
import Control.Arrow import Control.Arrow
import Control.Monad import Control.Monad
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import Data.Version (showVersion) import Data.Version (showVersion)
import Data.Label
import Data.List import Data.List
import Data.List.Split import Data.List.Split
import Data.Char (isSpace) import Data.Char (isSpace)
@ -16,6 +17,7 @@ import Data.Maybe
import Exception import Exception
import Language.Haskell.GhcMod import Language.Haskell.GhcMod
import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO) import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO)
import Language.Haskell.GhcMod.Types
import Paths_ghc_mod import Paths_ghc_mod
import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..)) import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..))
import qualified System.Console.GetOpt as O import qualified System.Console.GetOpt as O
@ -23,10 +25,10 @@ import System.FilePath ((</>))
import System.Directory (setCurrentDirectory, getAppUserDataDirectory, import System.Directory (setCurrentDirectory, getAppUserDataDirectory,
removeDirectoryRecursive) removeDirectoryRecursive)
import System.Environment (getArgs) import System.Environment (getArgs)
import System.IO (stdout, hSetEncoding, utf8, hFlush) import System.IO
import System.Exit import System.Exit
import Text.PrettyPrint import Text.PrettyPrint
import Prelude import Prelude hiding ((.))
import Misc import Misc
@ -247,28 +249,29 @@ intToLogLevel = toEnum
globalArgSpec :: [OptDescr (Options -> Either [String] Options)] globalArgSpec :: [OptDescr (Options -> Either [String] Options)]
globalArgSpec = 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 $ o { optArg "LEVEL" $ \ml o -> Right $ case ml of
logLevel = case ml of Nothing ->
Nothing -> increaseLogLevel (logLevel o) modify (lOoptLogLevel . lOptOutput) increaseLogLevel o
Just l -> toEnum $ min 7 $ read l Just l ->
} 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 $ o { logLevel = toEnum 0 } 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 $ o { outputStyle = LispStyle } 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 $ o { lineSeparator = LineSeparator s } 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 $ o { linePrefix = Just (out, err) } 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:
@ -305,31 +308,34 @@ Exposed functions:
mapped. Works exactly the same as `unmap-file` interactive command mapped. Works exactly the same as `unmap-file` interactive command
-} -}
, option "" ["map-file"] "Redirect one file to another, --map-file \"file1.hs=file2.hs\"" $ , option "" ["map-file"] "Redirect one file to another, --map-file \"file1.hs=file2.hs\"" $
reqArg "OPT" $ \g o -> reqArg "OPT" $ \g o ->
let m = case second (drop 1) $ span (/='=') g of let m = case second (drop 1) $ span (/='=') g of
(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 "PROG" $ \p o -> Right $ o { ghcProgram = p } 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 "PROG" $ \p o -> Right $ o { ghcPkgProgram = p } 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 "PROG" $ \p o -> Right $ o { cabalProgram = p } reqArg "PATH" $ \p o -> Right $ set (lCabalProgram . lOptPrograms) p o
, option "" ["with-stack"] "stack executable to use" $
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"]
, option "" ["help"] "print this help message" $ , option "" ["help"] "print this help message" $
NoArg $ \_ -> Left ["help"] NoArg $ \_ -> Left ["help"]
] ]
parseGlobalArgs :: [String] -> Either InvalidCommandLine (Options, [String]) parseGlobalArgs :: [String] -> Either InvalidCommandLine (Options, [String])
parseGlobalArgs argv parseGlobalArgs argv
= case O.getOpt' RequireOrder globalArgSpec argv of = case O.getOpt' RequireOrder globalArgSpec argv of
@ -390,18 +396,21 @@ main = do
args <- getArgs args <- getArgs
case parseGlobalArgs args of case parseGlobalArgs args of
Left e -> throw e Left e -> throw e
Right res -> progMain res Right res@(globalOptions,_) -> catches (progMain res) [
Handler $ \(e :: GhcModError) ->
exitError' globalOptions $ renderStyle ghcModStyle (gmeDoc e)
]
progMain :: (Options,[String]) -> IO () progMain :: (Options,[String]) -> IO ()
progMain (globalOptions,cmdArgs) = hndle $ runGhcModT globalOptions $ handler $ do progMain (globalOptions,cmdArgs) = hndle $ runGhcModT globalOptions $ handler $ do
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
(e, _l) <- action (e, _l) <- liftIO . evaluate =<< action
case e of case e of
Right _ -> Right _ ->
return () return ()
@ -549,8 +558,9 @@ exitError :: IOish m => String -> GhcModT m a
exitError msg = gmErrStrLn (dropWhileEnd (=='\n') msg) >> liftIO exitFailure exitError msg = gmErrStrLn (dropWhileEnd (=='\n') msg) >> liftIO exitFailure
exitError' :: Options -> String -> IO a exitError' :: Options -> String -> IO a
exitError' opts msg = exitError' opts msg = do
gmUnsafeErrStrLn opts (dropWhileEnd (=='\n') msg) >> liftIO exitFailure gmUnsafeErrStr (optOutput opts) msg
liftIO exitFailure
fatalError :: String -> a fatalError :: String -> a
fatalError s = throw $ FatalError $ "ghc-mod: " ++ s fatalError s = throw $ FatalError $ "ghc-mod: " ++ s
@ -644,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 ()

5
test/BrowseSpec.hs
View File

@ -3,6 +3,7 @@ module BrowseSpec where
import Control.Applicative import Control.Applicative
import Language.Haskell.GhcMod import Language.Haskell.GhcMod
import Test.Hspec import Test.Hspec
import Prelude
import TestUtils import TestUtils
import Dir import Dir
@ -16,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"]

3
test/CabalHelperSpec.hs
View File

@ -10,6 +10,7 @@ import Test.Hspec
import System.Directory import System.Directory
import System.FilePath import System.FilePath
import System.Process (readProcess, system) import System.Process (readProcess, system)
import Prelude
import Dir import Dir
import TestUtils import TestUtils
@ -60,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"

8
test/CradleSpec.hs
View File

@ -7,6 +7,8 @@ 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 Dir import Dir
@ -35,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 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 res <- relativeCradle dir <$> clean_ (runGmOutDef findCradle)
cradleCurrentDir res `shouldBe` cradleCurrentDir res `shouldBe`
"test/data/cabal-project/subdir1/subdir2" "test/data/cabal-project/subdir1/subdir2"
@ -54,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 res <- relativeCradle dir <$> clean_ (runGmOutDef findCradle)
cradleCurrentDir res `shouldBe` cradleCurrentDir res `shouldBe`
"test" </> "data" </> "broken-sandbox" "test" </> "data" </> "broken-sandbox"

6
test/FileMappingSpec.hs
View File

@ -114,7 +114,7 @@ spec = do
it "should work even if file doesn't exist" $ do it "should work even if file doesn't exist" $ do
withDirectory_ "test/data/file-mapping" $ do withDirectory_ "test/data/file-mapping" $ do
let fm = [("Nonexistent.hs", "main = putStrLn \"Hello World!\"\n")] let fm = [("Nonexistent.hs", "main = putStrLn \"Hello World!\"\n")]
res <- run defaultOptions{logLevel=GmDebug} $ do res <- run defaultOptions $ do
mapM_ (uncurry loadMappedFileSource) fm mapM_ (uncurry loadMappedFileSource) fm
checkSyntax ["Nonexistent.hs"] checkSyntax ["Nonexistent.hs"]
res `shouldBe` "Nonexistent.hs:1:1:Warning: Top-level binding with no type signature: main :: IO ()\n" res `shouldBe` "Nonexistent.hs:1:1:Warning: Top-level binding with no type signature: main :: IO ()\n"
@ -224,7 +224,7 @@ spec = do
writeFile (tmpdir </> "Bar_Redir.hs") srcBar writeFile (tmpdir </> "Bar_Redir.hs") srcBar
let fm = [("Foo.hs", tmpdir </> "Foo_Redir.hs") let fm = [("Foo.hs", tmpdir </> "Foo_Redir.hs")
,("Bar.hs", tmpdir </> "Bar_Redir.hs")] ,("Bar.hs", tmpdir </> "Bar_Redir.hs")]
res <- run defaultOptions{logLevel = GmDebug} $ do res <- run defaultOptions $ do
mapM_ (uncurry loadMappedFile) fm mapM_ (uncurry loadMappedFile) fm
types "Bar.hs" 5 1 types "Bar.hs" 5 1
res `shouldBe` unlines ["5 1 5 20 \"[Char]\""] res `shouldBe` unlines ["5 1 5 20 \"[Char]\""]
@ -234,7 +234,7 @@ spec = do
withDirectory_ "test/data/file-mapping" $ do withDirectory_ "test/data/file-mapping" $ do
let fm = [("Foo.hs", srcFoo) let fm = [("Foo.hs", srcFoo)
,("Bar.hs", srcBar)] ,("Bar.hs", srcBar)]
res <- run defaultOptions{logLevel = GmDebug} $ do res <- run defaultOptions $ do
mapM_ (uncurry loadMappedFileSource) fm mapM_ (uncurry loadMappedFileSource) fm
types "Bar.hs" 5 1 types "Bar.hs" 5 1
res `shouldBe` unlines ["5 1 5 20 \"[Char]\""] res `shouldBe` unlines ["5 1 5 20 \"[Char]\""]

1
test/FlagSpec.hs
View File

@ -4,6 +4,7 @@ import Control.Applicative
import Language.Haskell.GhcMod import Language.Haskell.GhcMod
import Test.Hspec import Test.Hspec
import TestUtils import TestUtils
import Prelude
spec :: Spec spec :: Spec
spec = do spec = do

3
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
@ -12,6 +12,7 @@ import System.Environment (getExecutablePath)
import System.FilePath import System.FilePath
import Test.Hspec import Test.Hspec
import TestUtils import TestUtils
import Prelude
spec :: Spec spec :: Spec
spec = do spec = do

1
test/LangSpec.hs
View File

@ -4,6 +4,7 @@ import Control.Applicative
import Language.Haskell.GhcMod import Language.Haskell.GhcMod
import Test.Hspec import Test.Hspec
import TestUtils import TestUtils
import Prelude
spec :: Spec spec :: Spec
spec = do spec = do

1
test/ListSpec.hs
View File

@ -4,6 +4,7 @@ import Control.Applicative
import Language.Haskell.GhcMod import Language.Haskell.GhcMod
import Test.Hspec import Test.Hspec
import TestUtils import TestUtils
import Prelude
spec :: Spec spec :: Spec
spec = do spec = do

24
test/TestUtils.hs
View File

@ -5,6 +5,7 @@ module TestUtils (
, runD' , runD'
, runE , runE
, runNullLog , runNullLog
, runGmOutDef
, shouldReturnError , shouldReturnError
, isPkgDbAt , isPkgDbAt
, isPkgConfDAt , isPkgConfDAt
@ -18,14 +19,18 @@ import Language.Haskell.GhcMod.Cradle
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Control.Arrow import Control.Arrow
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
import Data.List.Split import Data.List.Split
import Data.Label
import Data.String import Data.String
import System.FilePath import System.FilePath
import System.Directory import System.Directory
import Test.Hspec import Test.Hspec
import Prelude hiding ((.))
import Exception import Exception
@ -43,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)
@ -53,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 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
@ -65,11 +72,14 @@ run opt a = extract $ runGhcModTSpec opt a
-- | Run GhcMod with default options -- | Run GhcMod with default options
runD :: GhcModT IO a -> IO a runD :: GhcModT IO a -> IO a
runD = runD =
extract . runGhcModTSpec defaultOptions { logLevel = testLogLevel } extract . runGhcModTSpec (setLogLevel testLogLevel defaultOptions)
runD' :: FilePath -> GhcModT IO a -> IO a runD' :: FilePath -> GhcModT IO a -> IO a
runD' dir = runD' dir =
extract . runGhcModTSpec' dir defaultOptions { logLevel = testLogLevel } extract . runGhcModTSpec' dir (setLogLevel testLogLevel defaultOptions)
setLogLevel :: GmLogLevel -> Options -> Options
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
@ -80,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