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

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

@ -34,10 +34,10 @@ import Data.Maybe
import Data.Monoid
import Data.Serialize (Serialize)
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 Language.Haskell.GhcMod.Types hiding (ghcProgram, ghcPkgProgram,
cabalProgram)
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Utils
import Language.Haskell.GhcMod.PathsAndFiles
@ -45,13 +45,15 @@ import Language.Haskell.GhcMod.Logging
import Language.Haskell.GhcMod.Output
import System.FilePath
import System.Directory (findExecutable)
import System.Process
import System.Exit
import Prelude hiding ((.))
import Paths_ghc_mod as GhcMod
-- | Only package related GHC options, sufficient for things that don't need to
-- access home modules
getGhcMergedPkgOptions :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m)
getGhcMergedPkgOptions :: (Applicative m, IOish m, Gm m)
=> m [GHCOption]
getGhcMergedPkgOptions = chCached $ \distdir -> Cached {
cacheLens = Just (lGmcMergedPkgOptions . lGmCaches),
@ -63,7 +65,7 @@ getGhcMergedPkgOptions = chCached $ \distdir -> Cached {
return ([setupConfigPath distdir], opts)
}
getCabalPackageDbStack :: (IOish m, GmEnv m, GmState m, GmLog m) => m [GhcPkgDb]
getCabalPackageDbStack :: (IOish m, Gm m) => m [GhcPkgDb]
getCabalPackageDbStack = chCached $ \distdir -> Cached {
cacheLens = Just (lGmcPackageDbStack . lGmCaches),
cacheFile = pkgDbStackCacheFile distdir,
@ -84,7 +86,7 @@ chPkgToGhcPkg (ChPkgSpecific f) = PackageDb f
--
-- The Component\'s 'gmcHomeModuleGraph' will be empty and has to be resolved by
-- 'resolveGmComponents'.
getComponents :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m)
getComponents :: (Applicative m, IOish m, Gm m)
=> m [GmComponent 'GMCRaw ChEntrypoint]
getComponents = chCached$ \distdir -> Cached {
cacheLens = Just (lGmcComponents . lGmCaches),
@ -114,7 +116,7 @@ getComponents = chCached$ \distdir -> Cached {
, a == a'
]
prepareCabalHelper :: (IOish m, GmEnv m, GmLog m) => m ()
prepareCabalHelper :: (IOish m, GmEnv m, GmOut m, GmLog m) => m ()
prepareCabalHelper = do
crdl <- cradle
let projdir = cradleRootDir crdl
@ -145,7 +147,19 @@ getStackPackageDbStack = do
localDb <- liftIO $ readProcess stack ["path", "--local-pkg-db"] ""
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
crdl <- cradle
opts <- options
@ -163,7 +177,7 @@ withCabal action = do
pkgDbStackOutOfSync <-
case mCusPkgDbStack of
Just cusPkgDbStack -> do
pkgDb <- runQuery'' readProc (helperProgs opts) projdir distdir $
pkgDb <- runQuery'' readProc (helperProgs $ optPrograms opts) projdir distdir $
map chPkgToGhcPkg <$> packageDbStack
return $ pkgDb /= cusPkgDbStack
@ -185,31 +199,54 @@ withCabal action = do
|| isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $
case projType of
CabalProject ->
cabalReconfigure readProc opts crdl projdir distdir
cabalReconfigure readProc (optPrograms opts) crdl projdir distdir
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
action
where
cabalReconfigure readProc opts crdl projdir distdir = do
cabalReconfigure readProc progs crdl projdir distdir = do
withDirectory_ (cradleRootDir crdl) $ do
cusPkgStack <- maybe [] ((PackageDb "clear"):) <$> getCustomPkgDbStack
let progOpts =
[ "--with-ghc=" ++ T.ghcProgram opts ]
[ "--with-ghc=" ++ T.ghcProgram progs ]
-- Only pass ghc-pkg if it was actually set otherwise we
-- might break cabal's guessing logic
++ if T.ghcPkgProgram opts /= T.ghcPkgProgram defaultOptions
then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram opts ]
++ if T.ghcPkgProgram progs /= T.ghcPkgProgram (optPrograms defaultOptions)
then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram progs ]
else []
++ 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"
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 GlobalDb = "--package-db=global"
@ -233,14 +270,14 @@ isSetupConfigOutOfDate :: Maybe TimedFile -> Maybe TimedFile -> Bool
isSetupConfigOutOfDate worldCabalFile worldCabalConfig = do
worldCabalConfig < worldCabalFile
helperProgs :: Options -> Programs
helperProgs opts = Programs {
cabalProgram = T.cabalProgram opts,
ghcProgram = T.ghcProgram opts,
ghcPkgProgram = T.ghcPkgProgram opts
}
helperProgs :: Programs -> CH.Programs
helperProgs progs = CH.Programs {
cabalProgram = T.cabalProgram progs,
ghcProgram = T.ghcProgram progs,
ghcPkgProgram = T.ghcPkgProgram progs
}
chCached :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m, Serialize a)
chCached :: (Applicative m, IOish m, Gm m, Serialize a)
=> (FilePath -> Cached m GhcModState ChCacheData a) -> m a
chCached c = do
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
-- changes the cache files will be gone anyways ;)
cacheInputData root = do
opt <- options
return $ ( helperProgs opt
opts <- options
crdl <- cradle
progs' <- patchStackPrograms crdl (optPrograms opts)
return $ ( helperProgs progs'
, root
, (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.IO as T (readFile)
import System.FilePath
import Prelude
import qualified DataCon as Ty
import GHC (GhcMonad, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))
@ -48,12 +49,12 @@ splits :: IOish m
-> GhcModT m String
splits file lineNo colNo =
ghandle handler $ runGmlT' [Left file] deferErrors $ do
opt <- options
oopts <- outputOpts
crdl <- cradle
style <- getStyle
dflag <- G.getSessionDynFlags
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
let varName' = showName dflag style varName -- Convert name to string
t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $
@ -68,7 +69,7 @@ splits file lineNo colNo =
handler (SomeException ex) = do
gmLog GmException "splits" $
text "" $$ nest 4 (showDoc ex)
emptyResult =<< options
emptyResult =<< outputOpts
----------------------------------------------------------------
-- 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
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 opt@Options { outputStyle = LispStyle } x = toLisp opt x "\n"
convert opt@Options { outputStyle = PlainStyle } x
convert :: ToString a => OutputOpts -> a -> String
convert opt@OutputOpts { ooptStyle = LispStyle } x = toLisp opt x "\n"
convert opt@OutputOpts { ooptStyle = PlainStyle } x
| str == "\n" = ""
| otherwise = str
where
str = toPlain opt x "\n"
class ToString a where
toLisp :: Options -> a -> Builder
toPlain :: Options -> a -> Builder
toLisp :: OutputOpts -> a -> Builder
toPlain :: OutputOpts -> a -> Builder
lineSep :: Options -> String
lineSep opt = interpret lsep
lineSep :: OutputOpts -> String
lineSep oopts = interpret lsep
where
interpret s = read $ "\"" ++ s ++ "\""
LineSeparator lsep = lineSeparator opt
LineSeparator lsep = ooptLineSeparator oopts
-- |
--
-- >>> toLisp defaultOptions "fo\"o" ""
-- >>> toLisp (outputOpts defaultOptions) "fo\"o" ""
-- "\"fo\\\"o\""
-- >>> toPlain defaultOptions "foo" ""
-- >>> toPlain (outputOpts defaultOptions) "foo" ""
-- "foo"
instance ToString String where
toLisp opt = quote opt
toPlain opt = replace '\n' (lineSep opt)
toLisp oopts = quote oopts
toPlain oopts = replace '\n' (lineSep oopts)
-- |
--
-- >>> toLisp defaultOptions ["foo", "bar", "ba\"z"] ""
-- >>> toLisp (outputOpts defaultOptions) ["foo", "bar", "ba\"z"] ""
-- "(\"foo\" \"bar\" \"ba\\\"z\")"
-- >>> toPlain defaultOptions ["foo", "bar", "baz"] ""
-- >>> toPlain (outputOpts defaultOptions) ["foo", "bar", "baz"] ""
-- "foo\nbar\nbaz"
instance ToString [String] where
toLisp opt = toSexp1 opt
toPlain opt = inter '\n' . map (toPlain opt)
toLisp oopts = toSexp1 oopts
toPlain oopts = inter '\n' . map (toPlain oopts)
instance ToString [ModuleString] where
toLisp opt = toLisp opt . map getModuleString
toPlain opt = toPlain opt . map getModuleString
toLisp oopts = toLisp oopts . 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)]
-- >>> toLisp defaultOptions inp ""
-- >>> toLisp (outputOpts defaultOptions) inp ""
-- "((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\""
instance ToString [((Int,Int,Int,Int),String)] where
toLisp opt = toSexp2 . map toS
toLisp oopts = toSexp2 . map toS
where
toS x = ('(' :) . tupToString opt x . (')' :)
toPlain opt = inter '\n' . map (tupToString opt)
toS x = ('(' :) . tupToString oopts x . (')' :)
toPlain oopts = inter '\n' . map (tupToString oopts)
instance ToString ((Int,Int,Int,Int),String) where
toLisp opt x = ('(' :) . tupToString opt x . (')' :)
toPlain opt x = tupToString opt x
toLisp oopts x = ('(' :) . tupToString oopts x . (')' :)
toPlain oopts x = tupToString oopts x
instance ToString ((Int,Int,Int,Int),[String]) where
toLisp opt (x,s) = ('(' :) . fourIntsToString opt x .
(' ' :) . toLisp opt s . (')' :)
toPlain opt (x,s) = fourIntsToString opt x . ('\n' :) . toPlain opt s
toLisp oopts (x,s) = ('(' :) . fourIntsToString x .
(' ' :) . toLisp oopts s . (')' :)
toPlain oopts (x,s) = fourIntsToString x . ('\n' :) . toPlain oopts s
instance ToString (String, (Int,Int,Int,Int),[String]) where
toLisp opt (s,x,y) = toSexp2 [toLisp opt s, ('(' :) . fourIntsToString opt x . (')' :), toLisp opt y]
toPlain opt (s,x,y) = inter '\n' [toPlain opt s, fourIntsToString opt x, toPlain opt y]
toLisp oopts (s,x,y) = toSexp2 [toLisp oopts s, ('(' :) . fourIntsToString x . (')' :), toLisp oopts y]
toPlain oopts (s,x,y) = inter '\n' [toPlain oopts s, fourIntsToString x, toPlain oopts y]
toSexp1 :: Options -> [String] -> Builder
toSexp1 opt ss = ('(' :) . inter ' ' (map (quote opt) ss) . (')' :)
toSexp1 :: OutputOpts -> [String] -> Builder
toSexp1 oopts ss = ('(' :) . inter ' ' (map (quote oopts) ss) . (')' :)
toSexp2 :: [Builder] -> Builder
toSexp2 ss = ('(' :) . inter ' ' ss . (')' :)
fourIntsToString :: Options -> (Int,Int,Int,Int) -> Builder
fourIntsToString _ (a,b,c,d) = (show a ++) . (' ' :)
. (show b ++) . (' ' :)
. (show c ++) . (' ' :)
. (show d ++)
fourIntsToString :: (Int,Int,Int,Int) -> Builder
fourIntsToString (a,b,c,d) = (show a ++) . (' ' :)
. (show b ++) . (' ' :)
. (show c ++) . (' ' :)
. (show d ++)
tupToString :: Options -> ((Int,Int,Int,Int),String) -> Builder
tupToString opt ((a,b,c,d),s) = (show a ++) . (' ' :)
. (show b ++) . (' ' :)
. (show c ++) . (' ' :)
. (show d ++) . (' ' :)
. quote opt s -- fixme: quote is not necessary
tupToString :: OutputOpts -> ((Int,Int,Int,Int),String) -> Builder
tupToString oopts ((a,b,c,d),s) = (show a ++) . (' ' :)
. (show b ++) . (' ' :)
. (show c ++) . (' ' :)
. (show d ++) . (' ' :)
. quote oopts s -- fixme: quote is not necessary
quote :: Options -> String -> Builder
quote opt str = ("\"" ++) . (quote' str ++) . ("\"" ++)
quote :: OutputOpts -> String -> Builder
quote oopts str = ("\"" ++) . (quote' str ++) . ("\"" ++)
where
lsep = lineSep opt
lsep = lineSep oopts
quote' [] = []
quote' (x: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
emptyResult :: Monad m => Options -> m String
emptyResult opt = return $ convert opt ([] :: [String])
emptyResult :: Monad m => OutputOpts -> m String
emptyResult oopts = return $ convert oopts ([] :: [String])
-- Return an emptyResult when Nothing
whenFound :: (Monad m, ToString b) => Options -> m (Maybe a) -> (a -> b) -> m String
whenFound opt from f = maybe (emptyResult opt) (return . convert opt . f) =<< from
whenFound :: (Monad m, ToString b) => OutputOpts -> m (Maybe a) -> (a -> b) -> m String
whenFound oopts from f = maybe (emptyResult oopts) (return . convert oopts . f) =<< from
-- Return an emptyResult when Nothing, inside a monad
whenFound' :: (Monad m, ToString b) => Options -> 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' :: (Monad m, ToString b) => OutputOpts -> m (Maybe a) -> (a -> m b) -> m String
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 sandbox according to a cabal sandbox config
-- in a cabal directory.
findCradle :: IO Cradle
findCradle = findCradle' =<< getCurrentDirectory
findCradle :: (IOish m, GmOut m) => m Cradle
findCradle = findCradle' =<< liftIO getCurrentDirectory
findCradle' :: FilePath -> IO Cradle
findCradle' dir = run $ do
(stackCradle dir `mplus` cabalCradle dir `mplus` sandboxCradle dir `mplus` plainCradle dir)
findCradle' :: (IOish m, GmOut m) => FilePath -> m Cradle
findCradle' dir = run $
msum [ stackCradle dir
, cabalCradle dir
, sandboxCradle dir
, plainCradle dir
]
where run a = fillTempDir =<< (fromJust <$> runMaybeT a)
findSpecCradle :: FilePath -> IO Cradle
@ -53,14 +57,14 @@ findSpecCradle dir = do
cleanupCradle :: Cradle -> IO ()
cleanupCradle crdl = removeDirectoryRecursive $ cradleTempDir crdl
fillTempDir :: MonadIO m => Cradle -> m Cradle
fillTempDir :: IOish m => Cradle -> m Cradle
fillTempDir crdl = do
tmpDir <- liftIO $ newTempDir (cradleRootDir crdl)
return crdl { cradleTempDir = tmpDir }
cabalCradle :: FilePath -> MaybeT IO Cradle
cabalCradle :: IOish m => FilePath -> MaybeT m Cradle
cabalCradle wdir = do
cabalFile <- MaybeT $ findCabalFile wdir
cabalFile <- MaybeT $ liftIO $ findCabalFile wdir
let cabalDir = takeDirectory cabalFile
@ -73,13 +77,13 @@ cabalCradle wdir = do
, cradleDistDir = "dist"
}
stackCradle :: FilePath -> MaybeT IO Cradle
stackCradle :: (IOish m, GmOut m) => FilePath -> MaybeT m Cradle
stackCradle wdir = do
cabalFile <- MaybeT $ findCabalFile wdir
cabalFile <- MaybeT $ liftIO $ findCabalFile wdir
let cabalDir = takeDirectory cabalFile
_stackConfigFile <- MaybeT $ findStackConfigFile cabalDir
_stackConfigFile <- MaybeT $ liftIO $ findStackConfigFile cabalDir
-- If dist/setup-config already exists the user probably wants to use cabal
-- rather than stack, or maybe that's just me ;)
@ -96,9 +100,9 @@ stackCradle wdir = do
, cradleDistDir = distDir
}
sandboxCradle :: FilePath -> MaybeT IO Cradle
sandboxCradle :: IOish m => FilePath -> MaybeT m Cradle
sandboxCradle wdir = do
sbDir <- MaybeT $ findCabalSandboxDir wdir
sbDir <- MaybeT $ liftIO $ findCabalSandboxDir wdir
return Cradle {
cradleProjectType = SandboxProject
, cradleCurrentDir = wdir
@ -108,7 +112,7 @@ sandboxCradle wdir = do
, cradleDistDir = "dist"
}
plainCradle :: FilePath -> MaybeT IO Cradle
plainCradle :: IOish m => FilePath -> MaybeT m Cradle
plainCradle wdir = do
return $ Cradle {
cradleProjectType = PlainProject

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

@ -39,7 +39,7 @@ debugInfo = do
fsep $ map text pkgOpts)
, "GHC System libraries: " ++ ghcLibDir
, "GHC user options:\n" ++ render (nest 4 $
fsep $ map text ghcUserOptions)
fsep $ map text optGhcUserOptions)
] ++ cabal
cabalDebug :: IOish m => GhcModT m [String]
@ -53,6 +53,7 @@ cabalDebug = do
return $
[ "Cabal file: " ++ show cradleCabalFile
, "Cabal Project Type: " ++ show cradleProjectType
, "Cabal entrypoints:\n" ++ render (nest 4 $
mapDoc gmComponentNameDoc smpDoc entrypoints)
, "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 $
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
Right err ->
text (printf "Launching system command `%s` failed: " c)
<> gmeDoc err
Left (_out, _err, rv) -> text $
Left rv -> text $
printf "Launching system command `%s` failed (exited with %d)" c rv
GMENoCabalFile ->
text "No cabal file found."
@ -140,6 +140,9 @@ gmeDoc e = case e of
++ intercalate "\", \"" cfs ++"\"."
GMECabalStateFile csfe ->
gmCsfeDoc csfe
GMEStackBootrap msg ->
(text $ "Boostrapping stack project failed")
<+>: text msg
ghcExceptionDoc :: GhcException -> Doc
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.Function (on)
import Data.Functor
import Data.List (find, nub, sortBy)
import qualified Data.Map as M
import Data.Maybe (catMaybes)
import Text.PrettyPrint (($$), text, nest)
import Prelude
import Exception (ghandle, SomeException(..))
import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags,
SrcSpan, Type, GenLocated(L))
import qualified GHC 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 Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.DynFlags
@ -28,14 +40,6 @@ import Language.Haskell.GhcMod.Pretty (showDoc)
import Language.Haskell.GhcMod.Doc
import Language.Haskell.GhcMod.Types
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
import GHC (unLoc)
@ -74,11 +78,11 @@ sig :: IOish m
-> GhcModT m String
sig file lineNo colNo =
runGmlT' [Left file] deferErrors $ ghandle fallback $ do
opt <- options
oopts <- outputOpts
style <- getStyle
dflag <- G.getSessionDynFlags
modSum <- fileModSummaryWithMapping file
whenFound opt (getSignature modSum lineNo colNo) $ \s ->
whenFound oopts (getSignature modSum lineNo colNo) $ \s ->
case s of
Signature loc names ty ->
("function", fourInts loc, map (initialBody dflag style ty) names)
@ -93,10 +97,10 @@ sig file lineNo colNo =
in (rTy, fourInts loc, [initial ++ body])
where
fallback (SomeException _) = do
opt <- options
oopts <- outputOpts
-- Code cannot be parsed by ghc module
-- 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 ->
("function", fourIntsHE loc, map (initialBody undefined undefined ty) names)
HEFamSignature loc flavour name vars ->
@ -343,14 +347,14 @@ refine :: IOish m
refine file lineNo colNo (Expression expr) =
ghandle handler $
runGmlT' [Left file] deferErrors $ do
opt <- options
oopts <- outputOpts
style <- getStyle
dflag <- G.getSessionDynFlags
modSum <- fileModSummaryWithMapping file
p <- G.parseModule modSum
tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
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) ->
let eArgs = getFnArgs ety
rArgs = getFnArgs rty
@ -363,7 +367,7 @@ refine file lineNo colNo (Expression expr) =
handler (SomeException ex) = do
gmLog GmException "refining" $
text "" $$ nest 4 (showDoc ex)
emptyResult =<< options
emptyResult =<< outputOpts
-- Look for the variable in the specified position
findVar
@ -420,7 +424,7 @@ auto :: IOish m
-> GhcModT m String
auto file lineNo colNo =
ghandle handler $ runGmlT' [Left file] deferErrors $ do
opt <- options
oopts <- outputOpts
style <- getStyle
dflag <- G.getSessionDynFlags
modSum <- fileModSummaryWithMapping file
@ -429,7 +433,7 @@ auto file lineNo colNo =
tm_typechecked_source = tcs
, tm_checked_module_info = minfo
} <- 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
let (f,pats) = getPatsForVariable tcs (lineNo,colNo)
-- Remove self function to prevent recursion, and id to trim
@ -452,7 +456,7 @@ auto file lineNo colNo =
handler (SomeException ex) = do
gmLog GmException "auto-refining" $
text "" $$ nest 4 (showDoc ex)
emptyResult =<< options
emptyResult =<< outputOpts
-- Functions we do not want in completions
notWantedFuns :: [String]

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

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

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

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

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

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

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'.
-- Right is success and Left is failure.
withLogger :: (GmGhc m, GmEnv m, GmState m)
withLogger :: (GmGhc m, GmEnv m, GmOut m, GmState m)
=> (DynFlags -> DynFlags)
-> m a
-> m (Either String (String, a))
withLogger f action = do
env <- G.getSession
opts <- options
let conv = convert opts
oopts <- outputOpts
let conv = convert oopts
eres <- withLogger' env $ \setDf ->
withDynFlags (f . setDf) action
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
-- >>> Just GmDebug <= Just GmException
-- False
gmLog :: (MonadIO m, GmLog m, GmEnv m) => GmLogLevel -> String -> Doc -> m ()
gmLog :: (MonadIO m, GmLog m, GmOut m) => GmLogLevel -> String -> Doc -> m ()
gmLog level loc' doc = do
GhcModLog { gmLogLevel = Just level' } <- gmlHistory
@ -78,7 +78,7 @@ gmLog level loc' doc = do
gmlJournal (GhcModLog Nothing (Last Nothing) [(level, loc', msgDoc)])
gmVomit :: (MonadIO m, GmLog m, GmEnv m) => String -> Doc -> String -> m ()
gmVomit :: (MonadIO m, GmLog m, GmOut m, GmEnv m) => String -> Doc -> String -> m ()
gmVomit filename doc content = do
gmLog GmVomit "" $ doc <+>: text content

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

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

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

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

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

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

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

@ -22,9 +22,9 @@ module Language.Haskell.GhcMod.Output (
, gmErrStr
, gmPutStrLn
, gmErrStrLn
, gmUnsafePutStrLn
, gmUnsafeErrStrLn
, gmReadProcess
, gmUnsafePutStr
, gmUnsafeErrStr
, stdoutGateway
) where
@ -36,6 +36,7 @@ import Control.Monad
import Control.DeepSeq
import Control.Exception
import Control.Concurrent
import Prelude
import Language.Haskell.GhcMod.Types hiding (LineSeparator)
import Language.Haskell.GhcMod.Monad.Types
@ -62,38 +63,46 @@ toGmLines "" = GmLines GmPartial ""
toGmLines s | isNewline (last s) = GmLines GmTerminated s
toGmLines s = GmLines GmPartial s
outputFns :: (GmEnv m, MonadIO m')
outputFns :: (GmOut m, MonadIO m')
=> m (GmLines String -> m' (), GmLines String -> m' ())
outputFns = do
opts <- options
env <- gmeAsk
return $ outputFns' opts (gmOutput env)
outputFns =
outputFns' <$> gmoAsk
outputFns' :: MonadIO m'
=> Options
-> GmOutput
-> (GmLines String -> m' (), GmLines String -> m' ())
outputFns' opts output = let
Options {..} = opts
pfxFns :: Maybe (String, String) -> (GmLines String -> GmLines String, GmLines String -> GmLines String)
pfxFns lpfx = case lpfx of
Nothing -> ( id, id )
Just (op, ep) -> ( fmap $ pfx (op++), fmap $ pfx (ep++) )
where
pfx f = withLines f
pfx f = withLines f
stdioOutputFns :: MonadIO m => Maybe (String, String) -> (GmLines String -> m (), GmLines String -> m ())
stdioOutputFns lpfx = let
(outPfx, errPfx) = pfxFns lpfx
in
( liftIO . putStr . unGmLine . outPfx
, liftIO . hPutStr stderr . unGmLine . errPfx)
outPfx, errPfx :: GmLines String -> GmLines String
(outPfx, errPfx) =
case linePrefix of
Nothing -> ( id, id )
Just (op, ep) -> ( fmap $ pfx (op++), fmap $ pfx (ep++) )
chanOutputFns :: MonadIO m
=> Chan (GmStream, GmLines String)
-> Maybe (String, String)
-> (GmLines String -> m (), GmLines String -> m ())
chanOutputFns c lpfx = let
(outPfx, errPfx) = pfxFns lpfx
in
( liftIO . writeChan c . (,) GmOutStream . outPfx
, liftIO . writeChan c . (,) GmErrStream . errPfx)
outputFns' ::
MonadIO m => GhcModOut -> (GmLines String -> m (), GmLines String -> m ())
outputFns' (GhcModOut oopts c) = let
OutputOpts {..} = oopts
in
case output of
GmOutputStdio ->
( liftIO . putStr . unGmLine . outPfx
, liftIO . hPutStr stderr . unGmLine . errPfx)
GmOutputChan c ->
( liftIO . writeChan c . (,) GmOut . outPfx
, liftIO . writeChan c . (,) GmErr .errPfx)
case ooptLinePrefix of
Nothing -> stdioOutputFns ooptLinePrefix
Just _ -> chanOutputFns c ooptLinePrefix
gmPutStr, gmPutStrLn, gmErrStr, gmErrStrLn
:: (MonadIO m, GmEnv m) => String -> m ()
:: (MonadIO m, GmOut m) => String -> m ()
gmPutStr str = do
putOut <- fst `liftM` outputFns
@ -107,18 +116,18 @@ gmErrStr str = do
putErr $ toGmLines str
-- | Only use these when you're sure there are no other writers on stdout
gmUnsafePutStrLn, gmUnsafeErrStrLn
:: MonadIO m => Options -> String -> m ()
gmUnsafePutStrLn opts = (fst $ outputFns' opts GmOutputStdio) . toGmLines
gmUnsafeErrStrLn opts = (snd $ outputFns' opts GmOutputStdio) . toGmLines
gmUnsafePutStr, gmUnsafeErrStr
:: MonadIO m => OutputOpts -> String -> m ()
gmUnsafePutStr oopts = (fst $ stdioOutputFns (ooptLinePrefix oopts)) . 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
GhcModEnv {..} <- gmeAsk
case gmOutput of
GmOutputChan _ ->
GhcModOut {..} <- gmoAsk
case ooptLinePrefix gmoOptions of
Just _ ->
readProcessStderrChan
GmOutputStdio ->
Nothing ->
return $ readProcess
stdoutGateway :: Chan (GmStream, GmLines String) -> IO ()
@ -129,8 +138,8 @@ stdoutGateway chan = go ("", "")
case ty of
GmTerminated ->
case stream of
GmOut -> putStr (obuf++l) >> hFlush stdout >> go ("", ebuf)
GmErr -> putStr (ebuf++l) >> hFlush stdout >> go (obuf, "")
GmOutStream -> putStr (obuf++l) >> hFlush stdout >> go ("", ebuf)
GmErrStream -> putStr (ebuf++l) >> hFlush stdout >> go (obuf, "")
GmPartial -> case reverse $ lines l of
[] -> go buf
[x] -> go (appendBuf stream buf x)
@ -139,15 +148,20 @@ stdoutGateway chan = go ("", "")
hFlush stdout
go (appendBuf stream buf x)
appendBuf GmOut (obuf, ebuf) s = (obuf++s, ebuf)
appendBuf GmErr (obuf, ebuf) s = (obuf, ebuf++s)
appendBuf GmOutStream (obuf, ebuf) s = (obuf++s, ebuf)
appendBuf GmErrStream (obuf, ebuf) s = (obuf, ebuf++s)
readProcessStderrChan ::
GmEnv m => m (FilePath -> [String] -> String -> IO String)
GmOut m => m (FilePath -> [String] -> String -> IO String)
readProcessStderrChan = do
(_, e) <- outputFns
return $ go e
(_, e :: GmLines String -> IO ()) <- outputFns
return $ readProcessStderrChan' e
readProcessStderrChan' ::
(GmLines String -> IO ())
-> FilePath -> [String] -> String -> IO String
readProcessStderrChan' pute = go pute
where
go :: (GmLines String -> IO ()) -> FilePath -> [String] -> String -> IO String
go putErr exe args input = do
@ -176,7 +190,7 @@ readProcessStderrChan = do
res <- waitForProcess h
case res of
ExitFailure rv ->
processFailedException "readProcessStderrChan" exe args rv
throw $ GMEProcess "readProcessStderrChan" exe args $ Left rv
ExitSuccess ->
return output
where
@ -192,9 +206,3 @@ withForkWait async body = do
tid <- forkIO $ try (restore async) >>= putMVar waitVar
let wait = takeMVar waitVar >>= either throwIO return
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 Control.Applicative
import Control.Exception as E
import Control.Monad
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Class
import Data.List
import Data.Char
import Data.Maybe
@ -31,10 +33,12 @@ import Distribution.Helper (buildPlatform)
import System.Directory
import System.FilePath
import System.Process
import System.Info.Extra
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.Output
import qualified Language.Haskell.GhcMod.Utils as U
import Utils (mightExist)
import Prelude
@ -75,10 +79,38 @@ findCabalFile dir = do
findStackConfigFile :: FilePath -> IO (Maybe FilePath)
findStackConfigFile dir = mightExist (dir </> "stack.yaml")
getStackDistDir :: FilePath -> IO (Maybe FilePath)
getStackDistDir dir = U.withDirectory_ dir $ runMaybeT $ do
stack <- MaybeT $ findExecutable "stack"
liftIO $ takeWhile (/='\n') <$> readProcess stack ["path", "--dist-dir"] ""
getStackDistDir :: (IOish m, GmOut m) => FilePath -> m (Maybe FilePath)
getStackDistDir projdir = U.withDirectory_ projdir $ runMaybeT $ do
takeWhile (/='\n') <$> readStack ["path", "--dist-dir"]
getStackGhcPath :: (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
getSandboxDb :: Cradle -> IO (Maybe GhcPkgDb)

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

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

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 #-}
{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-}
module Language.Haskell.GhcMod.Types (
@ -27,7 +27,8 @@ import Data.Maybe
import Data.Typeable (Typeable)
import Data.IORef
import Data.Label.Derive
import Distribution.Helper
import Distribution.Helper hiding (Programs(..))
import qualified Distribution.Helper as CabalHelper
import Exception (ExceptionMonad)
#if __GLASGOW_HASKELL__ < 708
import qualified MonadUtils as GHC (MonadIO(..))
@ -74,49 +75,66 @@ data FileMapping = FileMapping {fmPath :: FilePath, fmTemp :: Bool}
type FileMappingMap = Map FilePath FileMapping
data Options = Options {
outputStyle :: OutputStyle
-- | Line separator string.
, lineSeparator :: LineSeparator
-- | Stdout/err line multiplexing using prefix encoding. @fst@ is stdout,
-- @snd@ is stderr prefix.
, linePrefix :: Maybe (String, String)
-- | Verbosity
, logLevel :: GmLogLevel
data ProgramSource = ProgramSourceUser | ProgramSourceStack
data Programs = Programs {
-- | @ghc@ program name.
, ghcProgram :: FilePath
ghcProgram :: FilePath
-- | @ghc-pkg@ program name.
, ghcPkgProgram :: FilePath
-- | @cabal@ program name.
, 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
, ghcUserOptions:: [GHCOption]
, optGhcUserOptions :: [GHCOption]
-- | If 'True', 'browse' also returns operators.
, operators :: Bool
, optOperators :: Bool
-- | If 'True', 'browse' also returns types.
, detailed :: Bool
, optDetailed :: Bool
-- | If 'True', 'browse' will return fully qualified name
, qualified :: Bool
, hlintOpts :: [String]
, fileMappings :: [(FilePath, Maybe FilePath)]
, optQualified :: Bool
, optHlintOpts :: [String]
, optFileMappings :: [(FilePath, Maybe FilePath)]
} deriving (Show)
-- | A default 'Options'.
defaultOptions :: Options
defaultOptions = Options {
outputStyle = PlainStyle
, lineSeparator = LineSeparator "\0"
, linePrefix = Nothing
, logLevel = GmWarning
, ghcProgram = "ghc"
, ghcPkgProgram = "ghc-pkg"
, cabalProgram = "cabal"
, ghcUserOptions = []
, operators = False
, detailed = False
, qualified = False
, hlintOpts = []
, fileMappings = []
optOutput = OutputOpts {
ooptLogLevel = GmWarning
, ooptStyle = PlainStyle
, ooptLineSeparator = LineSeparator "\0"
, ooptLinePrefix = Nothing
}
, optPrograms = Programs {
ghcProgram = "ghc"
, ghcPkgProgram = "ghc-pkg"
, cabalProgram = "cabal"
, stackProgram = "stack"
}
, optGhcUserOptions = []
, optOperators = False
, optDetailed = False
, optQualified = False
, optHlintOpts = []
, optFileMappings = []
}
----------------------------------------------------------------
@ -140,7 +158,7 @@ data Cradle = Cradle {
} deriving (Eq, Show)
data GmStream = GmOut | GmErr
data GmStream = GmOutStream | GmErrStream
deriving (Show)
data GmLineType = GmTerminated | GmPartial
@ -152,13 +170,14 @@ data GmLines a = GmLines GmLineType a
unGmLine :: GmLines a -> a
unGmLine (GmLines _ s) = s
data GmOutput = GmOutputStdio
| GmOutputChan (Chan (GmStream, GmLines String))
data GhcModEnv = GhcModEnv {
gmOptions :: Options
, gmCradle :: Cradle
, gmOutput :: GmOutput
}
data GhcModOut = GhcModOut {
gmoOptions :: OutputOpts
, gmoChan :: Chan (GmStream, GmLines String)
}
data GhcModLog = GhcModLog {
@ -354,9 +373,9 @@ data GhcModError
| GMECabalCompAssignment [(Either FilePath ModuleName, Set ChComponentName)]
-- ^ 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
-- order: command, arguments, (stdout, stderr, exitcode)
-- order: function, command, arguments, (stdout, stderr, exitcode)
| GMENoCabalFile
-- ^ No cabal file found.
@ -366,6 +385,9 @@ data GhcModError
| GMECabalStateFile GMConfigStateFileError
-- ^ Reading Cabal's state configuration file falied somehow.
| GMEStackBootrap String
-- ^ Bootstrapping @stack@ environment failed (process exited with failure)
deriving (Eq,Show,Typeable)
instance Error GhcModError where
@ -386,10 +408,13 @@ data GMConfigStateFileError
deriving instance Generic Version
instance Serialize Version
instance Serialize Programs
instance Serialize CabalHelper.Programs
instance Serialize ChModuleName
instance Serialize ChComponentName
instance Serialize ChEntrypoint
mkLabel ''GhcModCaches
mkLabel ''GhcModState
mkLabel ''Options
mkLabel ''OutputOpts
mkLabel ''Programs

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

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

86
src/GHCMod.hs
View File

@ -3,12 +3,13 @@
module Main where
import Config (cProjectVersion)
import MonadUtils (liftIO)
import Control.Category
import Control.Applicative
import Control.Arrow
import Control.Monad
import Data.Typeable (Typeable)
import Data.Version (showVersion)
import Data.Label
import Data.List
import Data.List.Split
import Data.Char (isSpace)
@ -16,6 +17,7 @@ import Data.Maybe
import Exception
import Language.Haskell.GhcMod
import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO)
import Language.Haskell.GhcMod.Types
import Paths_ghc_mod
import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..))
import qualified System.Console.GetOpt as O
@ -23,10 +25,10 @@ import System.FilePath ((</>))
import System.Directory (setCurrentDirectory, getAppUserDataDirectory,
removeDirectoryRecursive)
import System.Environment (getArgs)
import System.IO (stdout, hSetEncoding, utf8, hFlush)
import System.IO
import System.Exit
import Text.PrettyPrint
import Prelude
import Prelude hiding ((.))
import Misc
@ -247,28 +249,29 @@ intToLogLevel = toEnum
globalArgSpec :: [OptDescr (Options -> Either [String] Options)]
globalArgSpec =
[ option "v" ["verbose"] "Increase or set log level. (0-7)" $
optArg "LEVEL" $ \ml o -> Right $ o {
logLevel = case ml of
Nothing -> increaseLogLevel (logLevel o)
Just l -> toEnum $ min 7 $ read l
}
optArg "LEVEL" $ \ml o -> Right $ case ml of
Nothing ->
modify (lOoptLogLevel . lOptOutput) increaseLogLevel o
Just l ->
set (lOoptLogLevel . lOptOutput) (toEnum $ min 7 $ read l) o
, 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" $
NoArg $ \o -> Right $ o { outputStyle = LispStyle }
NoArg $ \o -> Right $ set (lOoptStyle . lOptOutput) LispStyle o
, 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"$
reqArg "OUT,ERR" $ \s o -> let
[out, err] = splitOn "," s
in Right $ o { linePrefix = Just (out, err) }
reqArg "OUT,ERR" $ \s o -> let
[out, err] = splitOn "," s
in Right $ set (lOoptLinePrefix . lOptOutput) (Just (out, err)) o
, option "g" ["ghcOpt", "ghc-option"] "Option to be passed to GHC" $
reqArg "OPT" $ \g o -> Right $
o { ghcUserOptions = g : ghcUserOptions o }
reqArg "OPT" $ \g o -> Right $
o { optGhcUserOptions = g : optGhcUserOptions o }
{-
File map docs:
@ -305,31 +308,34 @@ Exposed functions:
mapped. Works exactly the same as `unmap-file` interactive command
-}
, option "" ["map-file"] "Redirect one file to another, --map-file \"file1.hs=file2.hs\"" $
reqArg "OPT" $ \g o ->
let m = case second (drop 1) $ span (/='=') g of
(s,"") -> (s, Nothing)
(f,t) -> (f, Just t)
in
Right $ o { fileMappings = m : fileMappings o }
reqArg "OPT" $ \g o ->
let m = case second (drop 1) $ span (/='=') g of
(s,"") -> (s, Nothing)
(f,t) -> (f, Just t)
in
Right $ o { optFileMappings = m : optFileMappings o }
, 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)" $
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" $
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" $
NoArg $ \_ -> Left ["version"]
NoArg $ \_ -> Left ["version"]
, option "" ["help"] "print this help message" $
NoArg $ \_ -> Left ["help"]
NoArg $ \_ -> Left ["help"]
]
parseGlobalArgs :: [String] -> Either InvalidCommandLine (Options, [String])
parseGlobalArgs argv
= case O.getOpt' RequireOrder globalArgSpec argv of
@ -390,18 +396,21 @@ main = do
args <- getArgs
case parseGlobalArgs args of
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 (globalOptions,cmdArgs) = hndle $ runGhcModT globalOptions $ handler $ do
case globalCommands cmdArgs of
Just s -> gmPutStr s
Nothing -> do
forM_ (reverse $ fileMappings globalOptions) $ uncurry loadMMappedFiles
forM_ (reverse $ optFileMappings globalOptions) $ uncurry loadMMappedFiles
ghcCommands cmdArgs
where
hndle action = do
(e, _l) <- action
(e, _l) <- liftIO . evaluate =<< action
case e of
Right _ ->
return ()
@ -549,8 +558,9 @@ exitError :: IOish m => String -> GhcModT m a
exitError msg = gmErrStrLn (dropWhileEnd (=='\n') msg) >> liftIO exitFailure
exitError' :: Options -> String -> IO a
exitError' opts msg =
gmUnsafeErrStrLn opts (dropWhileEnd (=='\n') msg) >> liftIO exitFailure
exitError' opts msg = do
gmUnsafeErrStr (optOutput opts) msg
liftIO exitFailure
fatalError :: String -> a
fatalError s = throw $ FatalError $ "ghc-mod: " ++ s
@ -644,24 +654,24 @@ locAction' cmd _ _ = throw $ InvalidCommandLine (Left cmd)
modulesArgSpec :: [OptDescr (Options -> Either [String] Options)]
modulesArgSpec =
[ option "d" ["detailed"] "Print package modules belong to." $
NoArg $ \o -> Right $ o { detailed = True }
NoArg $ \o -> Right $ o { optDetailed = True }
]
hlintArgSpec :: [OptDescr (Options -> Either [String] Options)]
hlintArgSpec =
[ option "h" ["hlintOpt"] "Option to be passed to hlint" $
reqArg "hlintOpt" $ \h o -> Right $ o { hlintOpts = h : hlintOpts o }
reqArg "hlintOpt" $ \h o -> Right $ o { optHlintOpts = h : optHlintOpts o }
]
browseArgSpec :: [OptDescr (Options -> Either [String] Options)]
browseArgSpec =
[ option "o" ["operators"] "Also print operators." $
NoArg $ \o -> Right $ o { operators = True }
NoArg $ \o -> Right $ o { optOperators = True }
, option "d" ["detailed"] "Print symbols with accompanying signature." $
NoArg $ \o -> Right $ o { detailed = True }
NoArg $ \o -> Right $ o { optDetailed = True }
, option "q" ["qualified"] "Qualify symbols" $
NoArg $ \o -> Right $ o { qualified = True }
NoArg $ \o -> Right $ o { optQualified = True }
]
nukeCaches :: IOish m => GhcModT m ()

5
test/BrowseSpec.hs
View File

@ -3,6 +3,7 @@ module BrowseSpec where
import Control.Applicative
import Language.Haskell.GhcMod
import Test.Hspec
import Prelude
import TestUtils
import Dir
@ -16,12 +17,12 @@ spec = do
describe "browse -d Data.Either" $ do
it "contains functions (e.g. `either') including their type signature" $ do
syms <- run defaultOptions { detailed = True }
syms <- run defaultOptions { optDetailed = True }
$ lines <$> browse "Data.Either"
syms `shouldContain` ["either :: (a -> c) -> (b -> c) -> Either a b -> c"]
it "contains type constructors (e.g. `Left') including their type signature" $ do
syms <- run defaultOptions { detailed = True}
syms <- run defaultOptions { optDetailed = True}
$ lines <$> browse "Data.Either"
syms `shouldContain` ["Left :: a -> Either a b"]

3
test/CabalHelperSpec.hs
View File

@ -10,6 +10,7 @@ import Test.Hspec
import System.Directory
import System.FilePath
import System.Process (readProcess, system)
import Prelude
import Dir
import TestUtils
@ -60,7 +61,7 @@ spec = do
let tdir = "test/data/stack-project"
[ghcOpts] <- map gmcGhcOpts . filter ((==ChExeName "new-template-exe") . gmcName) <$> runD' tdir getComponents
let pkgs = pkgOptions ghcOpts
pkgs `shouldBe` ["base", "bytestring"]
sort pkgs `shouldBe` ["base", "bytestring"]
it "extracts build dependencies" $ do
let tdir = "test/data/cabal-project"

8
test/CradleSpec.hs
View File

@ -7,6 +7,8 @@ import Language.Haskell.GhcMod.Types
import System.Directory (canonicalizePath)
import System.FilePath (pathSeparator)
import Test.Hspec
import TestUtils
import Prelude
import Dir
@ -35,14 +37,14 @@ spec = do
it "returns the current directory" $ do
withDirectory_ "/" $ do
curDir <- stripLastDot <$> canonicalizePath "/"
res <- clean_ findCradle
res <- clean_ $ runGmOutDef findCradle
cradleCurrentDir res `shouldBe` curDir
cradleRootDir res `shouldBe` curDir
cradleCabalFile res `shouldBe` Nothing
it "finds a cabal file and a sandbox" $ do
withDirectory "test/data/cabal-project/subdir1/subdir2" $ \dir -> do
res <- relativeCradle dir <$> clean_ findCradle
res <- relativeCradle dir <$> clean_ (runGmOutDef findCradle)
cradleCurrentDir res `shouldBe`
"test/data/cabal-project/subdir1/subdir2"
@ -54,7 +56,7 @@ spec = do
it "works even if a sandbox config file is broken" $ do
withDirectory "test/data/broken-sandbox" $ \dir -> do
res <- relativeCradle dir <$> clean_ findCradle
res <- relativeCradle dir <$> clean_ (runGmOutDef findCradle)
cradleCurrentDir res `shouldBe`
"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
withDirectory_ "test/data/file-mapping" $ do
let fm = [("Nonexistent.hs", "main = putStrLn \"Hello World!\"\n")]
res <- run defaultOptions{logLevel=GmDebug} $ do
res <- run defaultOptions $ do
mapM_ (uncurry loadMappedFileSource) fm
checkSyntax ["Nonexistent.hs"]
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
let fm = [("Foo.hs", tmpdir </> "Foo_Redir.hs")
,("Bar.hs", tmpdir </> "Bar_Redir.hs")]
res <- run defaultOptions{logLevel = GmDebug} $ do
res <- run defaultOptions $ do
mapM_ (uncurry loadMappedFile) fm
types "Bar.hs" 5 1
res `shouldBe` unlines ["5 1 5 20 \"[Char]\""]
@ -234,7 +234,7 @@ spec = do
withDirectory_ "test/data/file-mapping" $ do
let fm = [("Foo.hs", srcFoo)
,("Bar.hs", srcBar)]
res <- run defaultOptions{logLevel = GmDebug} $ do
res <- run defaultOptions $ do
mapM_ (uncurry loadMappedFileSource) fm
types "Bar.hs" 5 1
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 Test.Hspec
import TestUtils
import Prelude
spec :: Spec
spec = do

3
test/InfoSpec.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE CPP #-}
module InfoSpec where
import Control.Applicative ((<$>))
import Control.Applicative
import Data.List (isPrefixOf)
import Language.Haskell.GhcMod
#if __GLASGOW_HASKELL__ < 706
@ -12,6 +12,7 @@ import System.Environment (getExecutablePath)
import System.FilePath
import Test.Hspec
import TestUtils
import Prelude
spec :: Spec
spec = do

1
test/LangSpec.hs
View File

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

1
test/ListSpec.hs
View File

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

24
test/TestUtils.hs
View File

@ -5,6 +5,7 @@ module TestUtils (
, runD'
, runE
, runNullLog
, runGmOutDef
, shouldReturnError
, isPkgDbAt
, isPkgConfDAt
@ -18,14 +19,18 @@ import Language.Haskell.GhcMod.Cradle
import Language.Haskell.GhcMod.Types
import Control.Arrow
import Control.Category
import Control.Concurrent
import Control.Applicative
import Control.Monad.Error (ErrorT, runErrorT)
import Control.Monad.Trans.Journal
import Data.List.Split
import Data.Label
import Data.String
import System.FilePath
import System.Directory
import Test.Hspec
import Prelude hiding ((.))
import Exception
@ -43,7 +48,7 @@ withSpecCradle :: IOish m => FilePath -> (Cradle -> m a) -> m a
withSpecCradle cradledir f =
gbracket (liftIO $ findSpecCradle cradledir) (liftIO . cleanupCradle) f
withGhcModEnvSpec :: IOish m => FilePath -> Options -> (GhcModEnv -> m a) -> m a
withGhcModEnvSpec :: (IOish m, GmOut m) => FilePath -> Options -> (GhcModEnv -> m a) -> m a
withGhcModEnvSpec dir opt f = withSpecCradle dir $ withGhcModEnv' opt f
runGhcModTSpec :: Options -> GhcModT IO a -> IO (Either GhcModError a, GhcModLog)
@ -53,10 +58,12 @@ runGhcModTSpec opt action = do
runGhcModTSpec' :: IOish m
=> FilePath -> Options -> GhcModT m b -> m (Either GhcModError b, GhcModLog)
runGhcModTSpec' dir opt action = liftIO (canonicalizePath dir) >>= \dir' ->
runGhcModTSpec' dir opt action = liftIO (canonicalizePath dir) >>= \dir' -> do
gmo <- GhcModOut (optOutput opt) <$> liftIO newChan
runGmOutT gmo $
withGhcModEnvSpec dir' opt $ \env -> do
first (fst <$>) <$> runGhcModT'' env defaultGhcModState
(gmSetLogLevel (logLevel opt) >> action)
(gmSetLogLevel (ooptLogLevel $ optOutput opt) >> action)
-- | Run GhcMod
run :: Options -> GhcModT IO a -> IO a
@ -65,11 +72,14 @@ run opt a = extract $ runGhcModTSpec opt a
-- | Run GhcMod with default options
runD :: GhcModT IO a -> IO a
runD =
extract . runGhcModTSpec defaultOptions { logLevel = testLogLevel }
extract . runGhcModTSpec (setLogLevel testLogLevel defaultOptions)
runD' :: FilePath -> GhcModT IO a -> IO a
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 = runErrorT
@ -80,6 +90,10 @@ runNullLog action = do
liftIO $ print w
return a
runGmOutDef :: IOish m => GmOutT m a -> m a
runGmOutDef =
runGmOutT (GhcModOut (optOutput defaultOptions) (error "no chan"))
shouldReturnError :: Show a
=> IO (Either GhcModError a, GhcModLog)
-> Expectation