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

Prepare for splitting off ghc-mod-core eventually

Browse Source
This commit is contained in:
Daniel Gröber
2017-01-12 16:36:47 +01:00
parent 8a8ffa18ec
commit ee55da4908
71 changed files with 99 additions and 92 deletions
Download Patch File Download Diff File Expand all files Collapse all files

311
core/Language/Haskell/GhcMod/CabalHelper.hs Normal file
View File

@@ -0,0 +1,311 @@
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE CPP #-}
module Language.Haskell.GhcMod.CabalHelper
#ifndef SPEC
( getComponents
, getGhcMergedPkgOptions
, getCabalPackageDbStack
, prepareCabalHelper
, withAutogen
)
#endif
where
import Control.Applicative
import Control.Monad
import Control.Category ((.))
import Data.Maybe
import Data.Monoid
import Data.Version
import Data.Binary (Binary)
import Data.Traversable
import Distribution.Helper hiding (Programs(..))
import qualified Distribution.Helper as CH
import qualified Language.Haskell.GhcMod.Types as T
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Utils
import Language.Haskell.GhcMod.PathsAndFiles
import Language.Haskell.GhcMod.Logging
import Language.Haskell.GhcMod.Output
import Language.Haskell.GhcMod.CustomPackageDb
import Language.Haskell.GhcMod.Stack
import System.FilePath
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, Gm m)
=> m [GHCOption]
getGhcMergedPkgOptions = chCached $ \distdir -> Cached {
cacheLens = Just (lGmcMergedPkgOptions . lGmCaches),
cacheFile = mergedPkgOptsCacheFile distdir,
cachedAction = \_tcf (_progs, _projdir, _ver) _ma -> do
opts <- runCHQuery ghcMergedPkgOptions
return ([setupConfigPath distdir], opts)
}
getCabalPackageDbStack :: (IOish m, Gm m) => m [GhcPkgDb]
getCabalPackageDbStack = chCached $ \distdir -> Cached {
cacheLens = Just (lGmcPackageDbStack . lGmCaches),
cacheFile = pkgDbStackCacheFile distdir,
cachedAction = \_tcf (_progs, _projdir, _ver) _ma -> do
crdl <- cradle
dbs <- map chPkgToGhcPkg <$>
runCHQuery packageDbStack
return ([setupConfigFile crdl, sandboxConfigFile crdl], dbs)
}
chPkgToGhcPkg :: ChPkgDb -> GhcPkgDb
chPkgToGhcPkg ChPkgGlobal = GlobalDb
chPkgToGhcPkg ChPkgUser = UserDb
chPkgToGhcPkg (ChPkgSpecific f) = PackageDb f
-- | Primary interface to cabal-helper and intended single entrypoint to
-- constructing 'GmComponent's
--
-- The Component\'s 'gmcHomeModuleGraph' will be empty and has to be resolved by
-- 'resolveGmComponents'.
getComponents :: (Applicative m, IOish m, Gm m)
=> m [GmComponent 'GMCRaw ChEntrypoint]
getComponents = chCached $ \distdir -> Cached {
cacheLens = Just (lGmcComponents . lGmCaches),
cacheFile = cabalHelperCacheFile distdir,
cachedAction = \ _tcf (_progs, _projdir, _ver) _ma -> do
runCHQuery $ do
q <- join7
<$> ghcOptions
<*> ghcPkgOptions
<*> ghcSrcOptions
<*> ghcLangOptions
<*> entrypoints
<*> entrypoints
<*> sourceDirs
let cs = flip map q $ curry8 (GmComponent mempty)
return ([setupConfigPath distdir], cs)
}
where
curry8 fn (a, (b, (c, (d, (e, (f, (g, h))))))) = fn a b c d e f g h
join7 a b c d e f = join' a . join' b . join' c . join' d . join' e . join' f
join' :: Eq a => [(a,b)] -> [(a,c)] -> [(a,(b,c))]
join' lb lc = [ (a, (b, c))
| (a, b) <- lb
, (a', c) <- lc
, a == a'
]
getQueryEnv :: (IOish m, GmOut m, GmEnv m) => m QueryEnv
getQueryEnv = do
crdl <- cradle
progs <- patchStackPrograms crdl =<< (optPrograms <$> options)
readProc <- gmReadProcess
let projdir = cradleRootDir crdl
distdir = projdir </> cradleDistDir crdl
return (defaultQueryEnv projdir distdir) {
qeReadProcess = readProc
, qePrograms = helperProgs progs
}
runCHQuery :: (IOish m, GmOut m, GmEnv m) => Query m b -> m b
runCHQuery a = do
qe <- getQueryEnv
runQuery qe a
prepareCabalHelper :: (IOish m, GmEnv m, GmOut m, GmLog m) => m ()
prepareCabalHelper = do
crdl <- cradle
when (isCabalHelperProject $ cradleProject crdl) $
withCabal $ prepare' =<< getQueryEnv
withAutogen :: (IOish m, GmEnv m, GmOut m, GmLog m) => m a -> m a
withAutogen action = do
gmLog GmDebug "" $ strDoc $ "making sure autogen files exist"
crdl <- cradle
let projdir = cradleRootDir crdl
distdir = projdir </> cradleDistDir crdl
(pkgName', _) <- runCHQuery packageId
mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl
mCabalMacroHeader <- liftIO $ timeMaybe (distdir </> macrosHeaderPath)
mCabalPathsModule <- liftIO $ timeMaybe (distdir </> autogenModulePath pkgName')
when (mCabalMacroHeader < mCabalFile || mCabalPathsModule < mCabalFile) $ do
gmLog GmDebug "" $ strDoc $ "autogen files out of sync"
writeAutogen
action
where
writeAutogen = do
gmLog GmDebug "" $ strDoc $ "writing Cabal autogen files"
writeAutogenFiles' =<< getQueryEnv
withCabal :: (IOish m, GmEnv m, GmOut m, GmLog m) => m a -> m a
withCabal action = do
crdl <- cradle
mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl
mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl)
mCabalSandboxConfig <- liftIO $ timeMaybe (sandboxConfigFile crdl)
let haveSetupConfig = isJust mCabalConfig
cusPkgDb <- getCustomPkgDbStack
(flgs, pkgDbStackOutOfSync) <- do
if haveSetupConfig
then runCHQuery $ do
flgs <- nonDefaultConfigFlags
pkgDb <- map chPkgToGhcPkg <$> packageDbStack
return (flgs, fromMaybe False $ (pkgDb /=) <$> cusPkgDb)
else return ([], False)
when (isSetupConfigOutOfDate mCabalFile mCabalConfig) $
gmLog GmDebug "" $ strDoc $ "setup configuration is out of date"
when (isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $
gmLog GmDebug "" $ strDoc $ "sandbox configuration is out of date"
when pkgDbStackOutOfSync $
gmLog GmDebug "" $ strDoc $ "package-db stack out of sync with ghc-mod.package-db-stack"
when ( isSetupConfigOutOfDate mCabalFile mCabalConfig
|| pkgDbStackOutOfSync
|| isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $ do
proj <- cradleProject <$> cradle
opts <- options
case proj of
CabalProject -> do
gmLog GmDebug "" $ strDoc "reconfiguring Cabal project"
cabalReconfigure (optPrograms opts) crdl flgs
StackProject {} -> do
gmLog GmDebug "" $ strDoc "reconfiguring Stack project"
-- TODO: we could support flags for stack too, but it seems
-- you're supposed to put those in stack.yaml so detecting which
-- flags to pass down would be more difficult
-- "--flag PACKAGE:[-]FLAG Override flags set in stack.yaml
-- (applies to local packages and extra-deps)"
stackReconfigure (optStackBuildDeps opts) crdl (optPrograms opts)
_ ->
error $ "withCabal: unsupported project type: " ++ show proj
action
where
cabalReconfigure progs crdl flgs = do
readProc <- gmReadProcess
withDirectory_ (cradleRootDir crdl) $ do
cusPkgStack <- maybe [] ((PackageDb "clear"):) <$> getCustomPkgDbStack
let progOpts =
[ "--with-ghc=" ++ T.ghcProgram progs ]
-- Only pass ghc-pkg if it was actually set otherwise we
-- might break cabal's guessing logic
++ if T.ghcPkgProgram progs /= T.ghcPkgProgram (optPrograms defaultOptions)
then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram progs ]
else []
++ map pkgDbArg cusPkgStack
++ flagOpt
toFlag (f, True) = f
toFlag (f, False) = '-':f
flagOpt = ["--flags", unwords $ map toFlag flgs]
liftIO $ void $ readProc (T.cabalProgram progs) ("configure":progOpts) ""
stackReconfigure deps crdl progs = do
withDirectory_ (cradleRootDir crdl) $ do
supported <- haveStackSupport
if supported
then do
when deps $
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 0.1.4.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"
pkgDbArg UserDb = "--package-db=user"
pkgDbArg (PackageDb p) = "--package-db=" ++ p
-- * Neither file exists -> should return False:
-- @Nothing < Nothing = False@
-- (since we don't need to @cabal configure@ when no cabal file exists.)
--
-- * Cabal file doesn't exist (impossible since cabal-helper is only used with
-- cabal projects) -> should return False
-- @Just cc < Nothing = False@
--
-- * dist/setup-config doesn't exist yet -> should return True:
-- @Nothing < Just cf = True@
--
-- * Both files exist
-- @Just cc < Just cf = cc < cf = cc `olderThan` cf@
isSetupConfigOutOfDate :: Maybe TimedFile -> Maybe TimedFile -> Bool
isSetupConfigOutOfDate worldCabalFile worldCabalConfig = do
worldCabalConfig < worldCabalFile
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, Gm m, Binary a)
=> (FilePath -> Cached m GhcModState ChCacheData a) -> m a
chCached c = do
projdir <- cradleRootDir <$> cradle
distdir <- (projdir </>) . cradleDistDir <$> cradle
d <- cacheInputData projdir
withCabal $ cached projdir (c distdir) d
where
-- we don't need to include the distdir in the cache input because when it
-- changes the cache files will be gone anyways ;)
cacheInputData projdir = do
opts <- options
crdl <- cradle
progs' <- patchStackPrograms crdl (optPrograms opts)
return $ ( helperProgs progs'
, projdir
, (showVersion gmVer, chVer)
)
gmVer = GhcMod.version
chVer = VERSION_cabal_helper

141
core/Language/Haskell/GhcMod/Caching.hs Normal file
View File

@@ -0,0 +1,141 @@
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE CPP, OverloadedStrings #-}
module Language.Haskell.GhcMod.Caching (
module Language.Haskell.GhcMod.Caching
, module Language.Haskell.GhcMod.Caching.Types
) where
import Control.Arrow (first)
import Control.Monad
import Control.Monad.Trans.Maybe
#if !MIN_VERSION_binary(0,7,0)
import Control.Exception
#endif
import Data.Maybe
import Data.Binary hiding (get)
import Data.Version
import Data.Label
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import System.FilePath
import System.Directory.ModTime
import Utils (TimedFile(..), timeMaybe, mightExist)
import Paths_ghc_mod (version)
import Prelude
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Caching.Types
import Language.Haskell.GhcMod.Logging
-- | Cache a MonadIO action with proper invalidation.
cached :: forall m a d. (Gm m, MonadIO m, Binary a, Eq d, Binary d, Show d)
=> FilePath -- ^ Directory to prepend to 'cacheFile'
-> Cached m GhcModState d a -- ^ Cache descriptor
-> d
-> m a
cached dir cd d = do
mcc <- readCache
case mcc of
Nothing -> do
t <- liftIO $ getCurrentModTime
writeCache (TimedCacheFiles t []) Nothing "cache missing or unreadable"
Just (t, ifs, d', a) | d /= d' -> do
tcfs <- timeCacheInput dir ifs
writeCache (TimedCacheFiles t tcfs) (Just a) $ "input data changed" -- ++ " was: " ++ show d ++ " is: " ++ show d'
Just (t, ifs, _, a) -> do
tcfs <- timeCacheInput dir ifs
case invalidatingInputFiles $ TimedCacheFiles t tcfs of
[] -> return a
_ -> writeCache (TimedCacheFiles t tcfs) (Just a) "input files changed"
where
cacheHeader = BS8.pack $ "Written by ghc-mod " ++ showVersion version ++ "\n"
lbsToStrict = BS.concat . LBS.toChunks
lbsFromStrict bs = LBS.fromChunks [bs]
writeCache tcfs ma cause = do
(ifs', a) <- (cachedAction cd) tcfs d ma
t <- liftIO $ getCurrentModTime
gmLog GmDebug "" $ (text "regenerating cache") <+>: text (cacheFile cd)
<+> parens (text cause)
case cacheLens cd of
Nothing -> return ()
Just label -> do
gmLog GmDebug "" $ (text "writing memory cache") <+>: text (cacheFile cd)
setLabel label $ Just (t, ifs', d, a)
let c = BS.append cacheHeader $ lbsToStrict $ encode (t, ifs', d, a)
liftIO $ BS.writeFile (dir </> cacheFile cd) c
return a
setLabel l x = do
s <- gmsGet
gmsPut $ set l x s
readCache :: m (Maybe (ModTime, [FilePath], d, a))
readCache = runMaybeT $ do
case cacheLens cd of
Just label -> do
c <- MaybeT (get label `liftM` gmsGet) `mplus` readCacheFromFile
setLabel label $ Just c
return c
Nothing ->
readCacheFromFile
readCacheFromFile :: MaybeT m (ModTime, [FilePath], d, a)
readCacheFromFile = do
f <- MaybeT $ liftIO $ mightExist $ cacheFile cd
readCacheFromFile' f
readCacheFromFile' :: FilePath -> MaybeT m (ModTime, [FilePath], d, a)
readCacheFromFile' f = MaybeT $ do
gmLog GmDebug "" $ (text "reading cache") <+>: text (cacheFile cd)
cc <- liftIO $ BS.readFile f
case first BS8.words $ BS8.span (/='\n') cc of
(["Written", "by", "ghc-mod", ver], rest)
| BS8.unpack ver == showVersion version ->
either (const Nothing) Just
`liftM` decodeE (lbsFromStrict $ BS.drop 1 rest)
_ -> return Nothing
decodeE b = do
#if MIN_VERSION_binary(0,7,0)
return $ case decodeOrFail b of
Left (_rest, _offset, errmsg) -> Left errmsg
Right (_reset, _offset, a) -> Right a
#else
ea <- liftIO $ try $ evaluate $ decode b
return $ case ea of
Left (ErrorCall errmsg) -> Left errmsg
Right a -> Right a
#endif
timeCacheInput :: MonadIO m => FilePath -> [FilePath] -> m [TimedFile]
timeCacheInput dir ifs = liftIO $ do
ins <- (timeMaybe . (dir </>)) `mapM` ifs
return $ catMaybes ins
invalidatingInputFiles :: TimedCacheFiles -> [FilePath]
invalidatingInputFiles (TimedCacheFiles tcreated tcfs) =
map tfPath $
-- get input files older than tcfile
filter ((TimedFile "" tcreated)<) tcfs

67
core/Language/Haskell/GhcMod/Caching/Types.hs Normal file
View File

@@ -0,0 +1,67 @@
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
module Language.Haskell.GhcMod.Caching.Types where
import Utils
import Data.Label
import System.Directory.ModTime
import Distribution.Helper
type CacheContents d a = Maybe (ModTime, [FilePath], d, a)
type CacheLens s d a = s :-> CacheContents d a
data Cached m s d a = Cached {
cacheFile :: FilePath,
cacheLens :: Maybe (CacheLens s d a),
cachedAction :: TimedCacheFiles
-> d
-> Maybe a
-> m ([FilePath], a)
-- ^ @cachedAction tcf data ma@
--
-- * @tcf@: Input file timestamps. Not technically necessary, just an
-- optimizazion when knowing which input files changed can make updating the
-- cache faster
--
-- * @data@: Arbitrary static input data to cache action. Can be used to
-- invalidate the cache using something other than file timestamps
-- i.e. environment tool version numbers
--
-- * @ma@: Cached data if it existed
--
-- Returns:
--
-- * @fst@: Input files used in generating the cache
--
-- * @snd@: Cache data, will be stored alongside the static input data in the
-- 'cacheFile'
--
-- The cached action, will only run if one of the following is true:
--
-- * 'cacheFile' doesn\'t exist yet
-- * 'cacheFile' exists and 'inputData' changed
-- * any files returned by the cached action changed
}
data TimedCacheFiles = TimedCacheFiles {
tcCreated :: ModTime,
-- ^ 'cacheFile' timestamp
tcFiles :: [TimedFile]
-- ^ Timestamped files returned by the cached action
} deriving (Eq, Ord)
type ChCacheData = (Programs, FilePath, (String, String))

140
core/Language/Haskell/GhcMod/Convert.hs Normal file
View File

@@ -0,0 +1,140 @@
{-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts #-}
module Language.Haskell.GhcMod.Convert (convert, convert', emptyResult, whenFound, whenFound') where
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Types
import Control.Applicative
import Prelude
type Builder = String -> String
-- |
--
-- >>> replace '"' "\\\"" "foo\"bar" ""
-- "foo\\\"bar"
replace :: Char -> String -> String -> Builder
replace _ _ [] = id
replace c cs (x:xs)
| x == c = (cs ++) . replace c cs xs
| otherwise = (x :) . replace c cs xs
inter :: Char -> [Builder] -> Builder
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 . optOutput <$> options
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 :: OutputOpts -> a -> Builder
toPlain :: OutputOpts -> a -> Builder
lineSep :: OutputOpts -> String
lineSep oopts = interpret lsep
where
interpret s = read $ "\"" ++ s ++ "\""
LineSeparator lsep = ooptLineSeparator oopts
-- |
--
-- >>> toLisp (optOutput defaultOptions) "fo\"o" ""
-- "\"fo\\\"o\""
-- >>> toPlain (optOutput defaultOptions) "foo" ""
-- "foo"
instance ToString String where
toLisp oopts = quote oopts
toPlain oopts = replace '\n' (lineSep oopts)
-- |
--
-- >>> toLisp (optOutput defaultOptions) ["foo", "bar", "ba\"z"] ""
-- "(\"foo\" \"bar\" \"ba\\\"z\")"
-- >>> toPlain (optOutput defaultOptions) ["foo", "bar", "baz"] ""
-- "foo\nbar\nbaz"
instance ToString [String] where
toLisp oopts = toSexp1 oopts
toPlain oopts = inter '\n' . map (toPlain oopts)
instance ToString [ModuleString] where
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 (optOutput defaultOptions) inp ""
-- "((1 2 3 4 \"foo\") (5 6 7 8 \"bar\"))"
-- >>> toPlain (optOutput defaultOptions) inp ""
-- "1 2 3 4 \"foo\"\n5 6 7 8 \"bar\""
instance ToString [((Int,Int,Int,Int),String)] where
toLisp oopts = toSexp2 . map toS
where
toS x = ('(' :) . tupToString oopts x . (')' :)
toPlain oopts = inter '\n' . map (tupToString oopts)
instance ToString ((Int,Int,Int,Int),String) where
toLisp oopts x = ('(' :) . tupToString oopts x . (')' :)
toPlain oopts x = tupToString oopts x
instance ToString ((Int,Int,Int,Int),[String]) where
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 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 :: OutputOpts -> [String] -> Builder
toSexp1 oopts ss = ('(' :) . inter ' ' (map (quote oopts) ss) . (')' :)
toSexp2 :: [Builder] -> Builder
toSexp2 ss = ('(' :) . inter ' ' ss . (')' :)
fourIntsToString :: (Int,Int,Int,Int) -> Builder
fourIntsToString (a,b,c,d) = (show a ++) . (' ' :)
. (show b ++) . (' ' :)
. (show c ++) . (' ' :)
. (show d ++)
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 :: OutputOpts -> String -> Builder
quote oopts str = ("\"" ++) . (quote' str ++) . ("\"" ++)
where
lsep = lineSep oopts
quote' [] = []
quote' (x:xs)
| x == '\n' = lsep ++ quote' xs
| x == '\\' = "\\\\" ++ quote' xs
| x == '"' = "\\\"" ++ quote' xs
| otherwise = x : quote' xs
----------------------------------------------------------------
-- Empty result to be returned when no info can be gathered
emptyResult :: Monad m => OutputOpts -> m String
emptyResult oopts = return $ convert oopts ([] :: [String])
-- Return an emptyResult when Nothing
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) => 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

186
core/Language/Haskell/GhcMod/Cradle.hs Normal file
View File

@@ -0,0 +1,186 @@
{-# LANGUAGE CPP #-}
module Language.Haskell.GhcMod.Cradle
#ifndef SPEC
(
findCradle
, findCradle'
, findCradleNoLog
, findSpecCradle
, cleanupCradle
)
#endif
where
import Language.Haskell.GhcMod.PathsAndFiles
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils
import Language.Haskell.GhcMod.Stack
import Language.Haskell.GhcMod.Logging
import Language.Haskell.GhcMod.Error
import Safe
import Control.Applicative
import Control.Monad.Trans.Maybe
import Data.Maybe
import System.Directory
import System.FilePath
import System.Environment
import Prelude
import Control.Monad.Trans.Journal (runJournalT)
----------------------------------------------------------------
-- | Finding 'Cradle'.
-- Find a cabal file by tracing ancestor directories.
-- Find a sandbox according to a cabal sandbox config
-- in a cabal directory.
findCradle :: (GmLog m, IOish m, GmOut m) => Programs -> m Cradle
findCradle progs = findCradle' progs =<< liftIO getCurrentDirectory
findCradleNoLog :: forall m. (IOish m, GmOut m) => Programs -> m Cradle
findCradleNoLog progs =
fst <$> (runJournalT (findCradle progs) :: m (Cradle, GhcModLog))
findCradle' :: (GmLog m, IOish m, GmOut m) => Programs -> FilePath -> m Cradle
findCradle' Programs { stackProgram, cabalProgram } dir = run $
msum [ stackCradle stackProgram dir
, cabalCradle cabalProgram dir
, sandboxCradle dir
, plainCradle dir
]
where run a = fillTempDir =<< (fromJustNote "findCradle'" <$> runMaybeT a)
findSpecCradle ::
(GmLog m, IOish m, GmOut m) => Programs -> FilePath -> m Cradle
findSpecCradle Programs { stackProgram, cabalProgram } dir = do
let cfs = [ stackCradleSpec stackProgram
, cabalCradle cabalProgram
, sandboxCradle
]
cs <- catMaybes <$> mapM (runMaybeT . ($ dir)) cfs
gcs <- filterM isNotGmCradle cs
fillTempDir =<< case gcs of
[] -> fromJust <$> runMaybeT (plainCradle dir)
c:_ -> return c
where
isNotGmCradle crdl =
liftIO $ not <$> doesFileExist (cradleRootDir crdl </> "ghc-mod.cabal")
cleanupCradle :: Cradle -> IO ()
cleanupCradle crdl = removeDirectoryRecursive $ cradleTempDir crdl
fillTempDir :: IOish m => Cradle -> m Cradle
fillTempDir crdl = do
tmpDir <- liftIO $ newTempDir (cradleRootDir crdl)
return crdl { cradleTempDir = tmpDir }
cabalCradle ::
(IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle
cabalCradle cabalProg wdir = do
cabalFile <- MaybeT $ liftIO $ findCabalFile wdir
let cabalDir = takeDirectory cabalFile
gmLog GmInfo "" $ text "Found Cabal project at" <+>: text cabalDir
-- If cabal doesn't exist the user probably wants to use something else
whenM ((==Nothing) <$> liftIO (findExecutable cabalProg)) $ do
gmLog GmInfo "" $ text "'cabal' executable wasn't found, trying next project type"
mzero
gmLog GmInfo "" $ text "Using Cabal project at" <+>: text cabalDir
return Cradle {
cradleProject = CabalProject
, cradleCurrentDir = wdir
, cradleRootDir = cabalDir
, cradleTempDir = error "tmpDir"
, cradleCabalFile = Just cabalFile
, cradleDistDir = "dist"
}
stackCradle ::
(IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle
stackCradle stackProg wdir = do
#if __GLASGOW_HASKELL__ < 708
-- GHC < 7.8 is not supported by stack
mzero
#endif
cabalFile <- MaybeT $ liftIO $ findCabalFile wdir
let cabalDir = takeDirectory cabalFile
_stackConfigFile <- MaybeT $ liftIO $ findStackConfigFile cabalDir
gmLog GmInfo "" $ text "Found Stack project at" <+>: text cabalDir
stackExeSet <- liftIO $ isJust <$> lookupEnv "STACK_EXE"
stackExeExists <- liftIO $ isJust <$> findExecutable stackProg
setupCfgExists <- liftIO $ doesFileExist $ cabalDir </> setupConfigPath "dist"
case (stackExeExists, stackExeSet) of
(False, True) -> do
gmLog GmWarning "" $ text "'stack' executable wasn't found but STACK_EXE is set, trying next project type"
mzero
(False, False) -> do
gmLog GmInfo "" $ text "'stack' executable wasn't found, trying next project type"
mzero
(True, True) -> do
gmLog GmWarning "" $ text "STACK_EXE set, preferring Stack project"
(True, False) | setupCfgExists -> do
gmLog GmWarning "" $ text "'dist/setup-config' exists, ignoring Stack project"
mzero
(True, False) -> return ()
senv <- MaybeT $ getStackEnv cabalDir stackProg
gmLog GmInfo "" $ text "Using Stack project at" <+>: text cabalDir
return Cradle {
cradleProject = StackProject senv
, cradleCurrentDir = wdir
, cradleRootDir = cabalDir
, cradleTempDir = error "tmpDir"
, cradleCabalFile = Just cabalFile
, cradleDistDir = seDistDir senv
}
stackCradleSpec ::
(IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle
stackCradleSpec stackProg wdir = do
crdl <- stackCradle stackProg wdir
case crdl of
Cradle { cradleProject = StackProject StackEnv { seDistDir } } -> do
b <- isGmDistDir seDistDir
when b mzero
return crdl
_ -> error "stackCradleSpec"
where
isGmDistDir dir =
liftIO $ not <$> doesFileExist (dir </> ".." </> "ghc-mod.cabal")
sandboxCradle :: (IOish m, GmLog m, GmOut m) => FilePath -> MaybeT m Cradle
sandboxCradle wdir = do
sbDir <- MaybeT $ liftIO $ findCabalSandboxDir wdir
gmLog GmInfo "" $ text "Using sandbox project at" <+>: text sbDir
return Cradle {
cradleProject = SandboxProject
, cradleCurrentDir = wdir
, cradleRootDir = sbDir
, cradleTempDir = error "tmpDir"
, cradleCabalFile = Nothing
, cradleDistDir = "dist"
}
plainCradle :: (IOish m, GmLog m, GmOut m) => FilePath -> MaybeT m Cradle
plainCradle wdir = do
gmLog GmInfo "" $ text "Found no other project type, falling back to plain GHC project"
return $ Cradle {
cradleProject = PlainProject
, cradleCurrentDir = wdir
, cradleRootDir = wdir
, cradleTempDir = error "tmpDir"
, cradleCabalFile = Nothing
, cradleDistDir = "dist"
}

38
core/Language/Haskell/GhcMod/CustomPackageDb.hs Normal file
View File

@@ -0,0 +1,38 @@
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
module Language.Haskell.GhcMod.CustomPackageDb where
import Control.Applicative
import Control.Monad
import Control.Category ((.))
import Data.Maybe
import Data.Traversable
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.PathsAndFiles
import Prelude hiding ((.))
parseCustomPackageDb :: String -> [GhcPkgDb]
parseCustomPackageDb src = map parsePkgDb $ filter (not . null) $ lines src
where
parsePkgDb "global" = GlobalDb
parsePkgDb "user" = UserDb
parsePkgDb s = PackageDb s
getCustomPkgDbStack :: (MonadIO m, GmEnv m) => m (Maybe [GhcPkgDb])
getCustomPkgDbStack = do
mCusPkgDbFile <- liftIO . (traverse readFile <=< findCustomPackageDbFile) . cradleRootDir =<< cradle
return $ parseCustomPackageDb <$> mCusPkgDbFile

138
core/Language/Haskell/GhcMod/DebugLogger.hs Normal file
View File

@@ -0,0 +1,138 @@
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE CPP, RankNTypes #-}
module Language.Haskell.GhcMod.DebugLogger where
-- (c) The University of Glasgow 2005
--
-- The Glasgow Haskell Compiler License
--
-- Copyright 2002, The University Court of the University of Glasgow.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are met:
--
-- - Redistributions of source code must retain the above copyright notice,
-- this list of conditions and the following disclaimer.
--
-- - Redistributions in binary form must reproduce the above copyright notice,
-- this list of conditions and the following disclaimer in the documentation
-- and/or other materials provided with the distribution.
--
-- - Neither name of the University nor the names of its contributors may be
-- used to endorse or promote products derived from this software without
-- specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
-- GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
-- INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-- FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-- UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-- OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
-- DAMAGE.
import GHC
import FastString
import Pretty
import Outputable (SDoc, PprStyle, runSDoc, initSDocContext, blankLine)
import qualified Outputable
import ErrUtils
import Language.Haskell.GhcMod.Error
import Language.Haskell.GhcMod.Gap
import Prelude
debugLogAction :: (String -> IO ()) -> GmLogAction
debugLogAction putErr _reason dflags severity srcSpan style' msg
= case severity of
SevOutput -> printSDoc putErr msg style'
#if __GLASGOW_HASKELL__ >= 706
SevDump -> printSDoc putErr (msg Outputable.$$ blankLine) style'
#endif
#if __GLASGOW_HASKELL__ >= 708
SevInteractive -> let
putStrSDoc = debugLogActionHPutStrDoc dflags putErr
in
putStrSDoc msg style'
#endif
SevInfo -> printErrs putErr msg style'
SevFatal -> printErrs putErr msg style'
_ -> do putErr "\n"
#if __GLASGOW_HASKELL__ >= 706
printErrs putErr (mkLocMessage severity srcSpan msg) style'
#else
printErrs putErr (mkLocMessage srcSpan msg) style'
#endif
-- careful (#2302): printErrs prints in UTF-8,
-- whereas converting to string first and using
-- hPutStr would just emit the low 8 bits of
-- each unicode char.
where
#if __GLASGOW_HASKELL__ >= 706
printSDoc put = debugLogActionHPrintDoc dflags put
printErrs put = debugLogActionHPrintDoc dflags put
#endif
#if __GLASGOW_HASKELL__ >= 706
debugLogActionHPrintDoc :: DynFlags -> (String -> IO ()) -> SDoc -> PprStyle -> IO ()
debugLogActionHPrintDoc dflags put d sty
= debugLogActionHPutStrDoc dflags put (d Outputable.$$ Outputable.text "") sty
-- Adds a newline
debugLogActionHPutStrDoc :: DynFlags -> (String -> IO ()) -> SDoc -> PprStyle -> IO ()
debugLogActionHPutStrDoc dflags put d sty
= gmPrintDoc_ Pretty.PageMode (pprCols dflags) put doc
where -- Don't add a newline at the end, so that successive
-- calls to this log-action can output all on the same line
doc = runSDoc d (initSDocContext dflags sty)
#else
printSDoc = printErrs
printErrs :: (String -> IO ()) -> SDoc -> PprStyle -> IO ()
printErrs put doc sty = do
gmPrintDoc PageMode 100 put (runSDoc doc (initSDocContext sty))
#endif
gmPrintDoc :: Mode -> Int -> (String -> IO ()) -> Doc -> IO ()
-- printDoc adds a newline to the end
gmPrintDoc mode cols put doc = gmPrintDoc_ mode cols put (doc $$ text "")
gmPrintDoc_ :: Mode -> Int -> (String -> IO ()) -> Doc -> IO ()
gmPrintDoc_ mode pprCols putS doc
= fullRender mode pprCols 1.5 put done doc
where
put (Chr c) next = putS [c] >> next
put (Str s) next = putS s >> next
put (PStr s) next = putS (unpackFS s) >> next
#if __GLASGOW_HASKELL__ >= 708
put (ZStr s) next = putS (zString s) >> next
#endif
put (LStr s _l) next = putS (unpackLitString s) >> next
done = return () -- hPutChar hdl '\n'

20
core/Language/Haskell/GhcMod/Doc.hs Normal file
View File

@@ -0,0 +1,20 @@
module Language.Haskell.GhcMod.Doc where
import GHC
import Language.Haskell.GhcMod.Gap (withStyle, showDocWith)
import Outputable
import Pretty (Mode(..))
showPage :: DynFlags -> PprStyle -> SDoc -> String
showPage dflag style = showDocWith dflag PageMode . withStyle dflag style
showOneLine :: DynFlags -> PprStyle -> SDoc -> String
showOneLine dflag style = showDocWith dflag OneLineMode . withStyle dflag style
getStyle :: GhcMonad m => m PprStyle
getStyle = do
unqual <- getPrintUnqual
return $ mkUserStyle unqual AllTheWay
styleUnqualified :: PprStyle
styleUnqualified = mkUserStyle neverQualify AllTheWay

108
core/Language/Haskell/GhcMod/DynFlags.hs Normal file
View File

@@ -0,0 +1,108 @@
{-# LANGUAGE TemplateHaskell #-}
module Language.Haskell.GhcMod.DynFlags where
import Control.Applicative
import Control.Monad
import GHC
import qualified GHC as G
import GHC.Paths (libdir)
import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.DebugLogger
import Language.Haskell.GhcMod.DynFlagsTH
import System.IO.Unsafe (unsafePerformIO)
import Prelude
setEmptyLogger :: DynFlags -> DynFlags
setEmptyLogger df =
Gap.setLogAction df $ \_ _ _ _ _ _ -> return ()
setDebugLogger :: (String -> IO ()) -> DynFlags -> DynFlags
setDebugLogger put df = do
Gap.setLogAction df (debugLogAction put)
-- * Fast
-- * Friendly to foreign export
-- * Not friendly to -XTemplateHaskell and -XPatternSynonyms
-- * Uses little memory
setHscNothing :: DynFlags -> DynFlags
setHscNothing df = df {
ghcMode = CompManager
, ghcLink = NoLink
, hscTarget = HscNothing
, optLevel = 0
}
-- * Slow
-- * Not friendly to foreign export
-- * Friendly to -XTemplateHaskell and -XPatternSynonyms
-- * Uses lots of memory
setHscInterpreted :: DynFlags -> DynFlags
setHscInterpreted df = df {
ghcMode = CompManager
, ghcLink = LinkInMemory
, hscTarget = HscInterpreted
, optLevel = 0
}
-- | Parse command line ghc options and add them to the 'DynFlags' passed
addCmdOpts :: GhcMonad m => [GHCOption] -> DynFlags -> m DynFlags
addCmdOpts cmdOpts df =
fst3 <$> G.parseDynamicFlags df (map G.noLoc cmdOpts)
where
fst3 (a,_,_) = a
----------------------------------------------------------------
withDynFlags :: GhcMonad m
=> (DynFlags -> DynFlags)
-> m a
-> m a
withDynFlags setFlags body = G.gbracket setup teardown (\_ -> body)
where
setup = do
dflags <- G.getSessionDynFlags
void $ G.setSessionDynFlags (setFlags dflags)
return dflags
teardown = void . G.setSessionDynFlags
withCmdFlags :: GhcMonad m => [GHCOption] -> m a -> m a
withCmdFlags flags body = G.gbracket setup teardown (\_ -> body)
where
setup = do
dflags <- G.getSessionDynFlags
void $ G.setSessionDynFlags =<< addCmdOpts flags dflags
return dflags
teardown = void . G.setSessionDynFlags
----------------------------------------------------------------
-- | Set 'DynFlags' equivalent to "-w:".
setNoWarningFlags :: DynFlags -> DynFlags
setNoWarningFlags df = df { warningFlags = Gap.emptyWarnFlags}
-- | Set 'DynFlags' equivalent to "-Wall".
setAllWarningFlags :: DynFlags -> DynFlags
setAllWarningFlags df = df { warningFlags = allWarningFlags }
allWarningFlags :: Gap.WarnFlags
allWarningFlags = unsafePerformIO $
G.runGhc (Just libdir) $ do
df <- G.getSessionDynFlags
df' <- addCmdOpts ["-Wall"] df
return $ G.warningFlags df'
----------------------------------------------------------------
deferErrors :: Monad m => DynFlags -> m DynFlags
deferErrors df = return $
Gap.setWarnTypedHoles $ Gap.setDeferTypedHoles $
Gap.setDeferTypeErrors $ setNoWarningFlags df
----------------------------------------------------------------
deriveEqDynFlags [d|
eqDynFlags :: DynFlags -> DynFlags -> Bool
eqDynFlags = undefined
|]

144
core/Language/Haskell/GhcMod/DynFlagsTH.hs Normal file
View File

@@ -0,0 +1,144 @@
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE CPP, TemplateHaskell #-}
module Language.Haskell.GhcMod.DynFlagsTH where
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Control.Applicative
import Data.Maybe
import Data.Generics.Aliases
import Data.Generics.Schemes
import DynFlags
import Prelude
deriveEqDynFlags :: Q [Dec] -> Q [Dec]
deriveEqDynFlags qds = do
#if __GLASGOW_HASKELL__ <= 710
~(TyConI (DataD [] _ [] [ctor] _ ))
#else
~(TyConI (DataD [] _ [] _ [ctor] _ ))
#endif
<- reify ''DynFlags
let ~(RecC _ fs) = ctor
a <- newName "a"
b <- newName "b"
e <- AppE (VarE 'and) . ListE <$> sequence (catMaybes $ map (eq a b) fs)
tysig@(SigD n _) :_ <- qds
return $ [tysig, FunD n [Clause [VarP a, VarP b] (NormalB e) []]]
where
eq :: Name -> Name -> (Name, Strict, Type) -> Maybe (Q Exp)
eq a b (fun@(Name (OccName fon) _), _, ft)
| not (isUneqable || isIgnored) = Just expr
| otherwise = Nothing
where
isUneqable = everything (||) (mkQ False hasUnEqable) ft
hasUnEqable (AppT (ConT (Name (OccName on) _)) _)
| any (==on) ignoredConstructorNames = True
hasUnEqable (ConT (Name (OccName on) _))
| any (==on) ignoredTypeNames = True
| any (==on) ignoredTypeOccNames = True
hasUnEqable _ = False
isIgnored = fon `elem` ignoredNames
ignoredConstructorNames = [ "IORef" ]
ignoredNames = [ "pkgDatabase" -- 7.8
#if __GLASGOW_HASKELL__ <= 706
, "ways" -- 'Ways' is not exported :/
#endif
]
ignoredTypeNames =
[ "LogAction"
, "PackageState"
, "Hooks"
, "FlushOut"
, "FlushErr"
, "Settings" -- I think these can't cange at runtime
]
ignoredTypeOccNames = [ "OnOff" ]
fa = AppE (VarE fun) (VarE a)
fb = AppE (VarE fun) (VarE b)
expr =
case fon of
"rtsOptsEnabled" -> do
let eqfn = [| let fn RtsOptsNone RtsOptsNone = True
fn RtsOptsSafeOnly RtsOptsSafeOnly = True
fn RtsOptsAll RtsOptsAll = True
fn _ _ = False
in fn
|]
[e| $(eqfn) $(return fa) $(return fb) |]
"extraPkgConfs" -> do
let eqfn = [| let fn a' b' = and (zipWith eqpr (a' []) (b' []))
&& length (a' []) == length (b' [])
eqpr GlobalPkgConf GlobalPkgConf = True
eqpr UserPkgConf UserPkgConf = True
eqpr (PkgConfFile pa) (PkgConfFile pb) = pa == pb
eqpr _ _ = False
in fn
|]
[e| $(eqfn) $(return fa) $(return fb) |]
#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 800
"sigOf" -> do
let eqfn = [| let fn NotSigOf NotSigOf = True
fn (SigOf a') (SigOf b') = a' == b'
fn (SigOfMap a') (SigOfMap b') = a' == b'
fn _ _ = False
in fn
|]
[e| $(eqfn) $(return fa) $(return fb) |]
#endif
#if __GLASGOW_HASKELL <= 706
"profAuto" -> do
let eqfn = [| let fn NoProfAuto NoProfAuto = True
fn ProfAutoAll ProfAutoAll = True
fn ProfAutoTop ProfAutoTop = True
fn ProfAutoExports ProfAutoExports = True
fn ProfAutoCalls ProfAutoCalls = True
fn _ _ = False
in fn
|]
[e| $(eqfn) $(return fa) $(return fb) |]
#endif
#if __GLASGOW_HASKELL__ >= 706
"language" -> do
let eqfn = [| let fn (Just Haskell98) (Just Haskell98) = True
fn (Just Haskell2010) (Just Haskell2010) = True
fn Nothing Nothing = True
fn _ _ = False
in fn
|]
[e| $(eqfn) $(return fa) $(return fb) |]
#endif
_ ->
[e| $(return fa) == $(return fb) |]
-- expr' = [e| trace (if $(expr) == True then "" else show ($(litE $ StringL fon), $(expr))) $(expr) |]

160
core/Language/Haskell/GhcMod/Error.hs Normal file
View File

@@ -0,0 +1,160 @@
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE ExistentialQuantification #-}
module Language.Haskell.GhcMod.Error (
GhcModError(..)
, GmError
, gmeDoc
, ghcExceptionDoc
, liftMaybe
, overrideError
, modifyError
, modifyError'
, modifyGmError
, tryFix
, GHandler(..)
, gcatches
, module Control.Monad.Error
, module Control.Exception
) where
import Control.Arrow hiding ((<+>))
import Control.Exception
import Control.Monad.Error hiding (MonadIO, liftIO)
import qualified Data.Set as Set
import Data.List
import Data.Version
import System.Process (showCommandForUser)
import Text.Printf
import Exception
import Panic
import Pretty
import Config (cProjectVersion, cHostPlatformString)
import Paths_ghc_mod (version)
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Pretty
type GmError m = MonadError GhcModError m
gmeDoc :: GhcModError -> Doc
gmeDoc e = case e of
GMENoMsg ->
text "Unknown error"
GMEString msg ->
text msg
GMECabalConfigure msg ->
text "Configuring cabal project failed" <+>: gmeDoc msg
GMEStackConfigure msg ->
text "Configuring stack project failed" <+>: gmeDoc msg
GMEStackBootstrap msg ->
text "Bootstrapping stack project environment failed" <+>: gmeDoc msg
GMECabalCompAssignment ctx ->
text "Could not find a consistent component assignment for modules:" $$
(nest 4 $ foldr ($+$) empty $ map ctxDoc ctx) $$
text "" $$
(if all (Set.null . snd) ctx
then noComponentSuggestions
else empty) $$
text "- To find out which components ghc-mod knows about try:" $$
nest 4 (backticks $ text "ghc-mod debug")
where
noComponentSuggestions =
text "- Are some of these modules part of a test and or benchmark?\
\ Try enabling them:" $$
nest 4 (backticks $ text "cabal configure --enable-tests [--enable-benchmarks]")
backticks d = char '`' <> d <> char '`'
ctxDoc = moduleDoc *** compsDoc
>>> first (<> colon) >>> uncurry (flip hang 4)
moduleDoc (Left fn) =
text "File " <> quotes (text fn)
moduleDoc (Right mdl) =
text "Module " <> quotes (text $ moduleNameString mdl)
compsDoc sc | Set.null sc = text "has no known components"
compsDoc sc = fsep $ punctuate comma $
map gmComponentNameDoc $ Set.toList sc
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 rv -> text $
printf "Launching system command `%s` failed (exited with %d)" c rv
GMENoCabalFile ->
text "No cabal file found."
GMETooManyCabalFiles cfs ->
text $ "Multiple cabal files found. Possible cabal files: \""
++ intercalate "\", \"" cfs ++"\"."
ghcExceptionDoc :: GhcException -> Doc
ghcExceptionDoc e@(CmdLineError _) =
text $ "<command line>: " ++ showGhcException e ""
ghcExceptionDoc (UsageError str) = strDoc str
ghcExceptionDoc (Panic msg) = vcat $ map text $ lines $ printf "\
\GHC panic! (the 'impossible' happened)\n\
\ ghc-mod version %s\n\
\ GHC library version %s for %s:\n\
\ %s\n\
\\n\
\Please report this as a bug: %s\n"
gmVer ghcVer platform msg url
where
gmVer = showVersion version
ghcVer = cProjectVersion
platform = cHostPlatformString
url = "https://github.com/kazu-yamamoto/ghc-mod/issues" :: String
ghcExceptionDoc e = text $ showGhcException e ""
liftMaybe :: MonadError e m => e -> m (Maybe a) -> m a
liftMaybe e action = maybe (throwError e) return =<< action
overrideError :: MonadError e m => e -> m a -> m a
overrideError e action = modifyError (const e) action
modifyError :: MonadError e m => (e -> e) -> m a -> m a
modifyError f action = action `catchError` \e -> throwError $ f e
infixr 0 `modifyError'`
modifyError' :: MonadError e m => m a -> (e -> e) -> m a
modifyError' = flip modifyError
modifyGmError :: (MonadIO m, ExceptionMonad m)
=> (GhcModError -> GhcModError) -> m a -> m a
modifyGmError f a = gcatch a $ \(ex :: GhcModError) -> liftIO $ throwIO (f ex)
tryFix :: MonadError e m => m a -> (e -> m ()) -> m a
tryFix action f = do
action `catchError` \e -> f e >> action
data GHandler m a = forall e . Exception e => GHandler (e -> m a)
gcatches :: (MonadIO m, ExceptionMonad m) => m a -> [GHandler m a] -> m a
gcatches io handlers = io `gcatch` gcatchesHandler handlers
gcatchesHandler :: (MonadIO m, ExceptionMonad m)
=> [GHandler m a] -> SomeException -> m a
gcatchesHandler handlers e = foldr tryHandler (liftIO $ throw e) handlers
where tryHandler (GHandler handler) res
= case fromException e of
Just e' -> handler e'
Nothing -> res

104
core/Language/Haskell/GhcMod/FileMapping.hs Normal file
View File

@@ -0,0 +1,104 @@
module Language.Haskell.GhcMod.FileMapping
( loadMappedFile
, loadMappedFileSource
, unloadMappedFile
, mapFile
, fileModSummaryWithMapping
) where
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Gap
import Language.Haskell.GhcMod.HomeModuleGraph
import Language.Haskell.GhcMod.Utils
import System.IO
import System.FilePath
import System.Directory
import Control.Monad.Trans.Maybe
import GHC
import Control.Monad
{- | maps 'FilePath', given as first argument to take source from
'FilePath' given as second argument. Works exactly the same as
first form of `--map-file` CLI option.
\'from\' can be either full path, or path relative to project root.
\'to\' has to be either relative to project root, or full path (preferred)
-}
loadMappedFile :: IOish m
=> FilePath -- ^ \'from\', file that will be mapped
-> FilePath -- ^ \'to\', file to take source from
-> GhcModT m ()
loadMappedFile from to = loadMappedFile' from to False
{- |
maps 'FilePath', given as first argument to have source as given
by second argument.
\'from\' may or may not exist, and should be either full path,
or relative to project root.
-}
loadMappedFileSource :: IOish m
=> FilePath -- ^ \'from\', file that will be mapped
-> String -- ^ \'src\', source
-> GhcModT m ()
loadMappedFileSource from src = do
tmpdir <- cradleTempDir `fmap` cradle
enc <- liftIO . mkTextEncoding . optEncoding =<< options
to <- liftIO $ do
(fn, h) <- openTempFile tmpdir (takeFileName from)
hSetEncoding h enc
hPutStr h src
hClose h
return fn
loadMappedFile' from to True
loadMappedFile' :: IOish m => FilePath -> FilePath -> Bool -> GhcModT m ()
loadMappedFile' from to isTemp = do
cfn <- getCanonicalFileNameSafe from
unloadMappedFile' cfn
crdl <- cradle
let to' = makeRelative (cradleRootDir crdl) to
addMMappedFile cfn (FileMapping to' isTemp)
mapFile :: (IOish m, GmState m) => HscEnv -> Target -> m Target
mapFile _ (Target tid@(TargetFile filePath _) taoc _) = do
mapping <- lookupMMappedFile filePath
return $ mkMappedTarget (Just filePath) tid taoc mapping
mapFile env (Target tid@(TargetModule moduleName) taoc _) = do
(fp, mapping) <- do
filePath <- fmap (fmap mpPath) (liftIO $ findModulePath env moduleName)
mmf <- runMaybeT $ MaybeT (return filePath) >>= MaybeT . lookupMMappedFile
return (filePath, mmf)
return $ mkMappedTarget fp tid taoc mapping
mkMappedTarget :: Maybe FilePath -> TargetId -> Bool -> Maybe FileMapping -> Target
mkMappedTarget _ _ taoc (Just to) =
mkTarget (TargetFile (fmPath to) Nothing) taoc Nothing
mkMappedTarget _ tid taoc _ =
mkTarget tid taoc Nothing
{-|
unloads previously mapped file \'file\', so that it's no longer mapped,
and removes any temporary files created when file was
mapped.
\'file\' should be either full path, or relative to project root.
-}
unloadMappedFile :: IOish m
=> FilePath -- ^ \'file\', file to unmap
-> GhcModT m ()
unloadMappedFile = getCanonicalFileNameSafe >=> unloadMappedFile'
unloadMappedFile' :: IOish m => FilePath -> GhcModT m ()
unloadMappedFile' cfn = void $ runMaybeT $ do
fm <- MaybeT $ lookupMMappedFile cfn
liftIO $ when (fmTemp fm) $ removeFile (fmPath fm)
delMMappedFile cfn
fileModSummaryWithMapping :: (IOish m, GmState m, GhcMonad m, GmEnv m) =>
FilePath -> m ModSummary
fileModSummaryWithMapping fn =
withMappedFile fn $ \fn' -> fileModSummary fn'

721
core/Language/Haskell/GhcMod/Gap.hs Normal file
View File

@@ -0,0 +1,721 @@
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP, ScopedTypeVariables, RankNTypes #-}
module Language.Haskell.GhcMod.Gap (
Language.Haskell.GhcMod.Gap.ClsInst
, mkTarget
, withStyle
, GmLogAction
, setLogAction
, getSrcSpan
, getSrcFile
, withInteractiveContext
, ghcCmdOptions
, toStringBuffer
, showSeverityCaption
, setCabalPkg
, setHideAllPackages
, setDeferTypeErrors
, setDeferTypedHoles
, setWarnTypedHoles
, setDumpSplices
, setNoMaxRelevantBindings
, isDumpSplices
, filterOutChildren
, infoThing
, pprInfo
, HasType(..)
, errorMsgSpan
, setErrorMsgSpan
, typeForUser
, nameForUser
, occNameForUser
, deSugar
, showDocWith
, render
, GapThing(..)
, fromTyThing
, fileModSummary
, WarnFlags
, emptyWarnFlags
, GLMatch
, GLMatchI
, getClass
, occName
, listVisibleModuleNames
, listVisibleModules
, lookupModulePackageInAllPackages
, Language.Haskell.GhcMod.Gap.isSynTyCon
, parseModuleHeader
, mkErrStyle'
, everythingStagedWithContext
, withCleanupSession
) where
import Control.Applicative hiding (empty)
import Control.Monad (filterM)
import CoreSyn (CoreExpr)
import Data.List (intersperse)
import Data.Maybe (catMaybes)
import Data.Time.Clock (UTCTime)
import Data.Traversable hiding (mapM)
import DataCon (dataConUserType)
import Desugar (deSugarExpr)
import DynFlags
import ErrUtils
import Exception
import FastString
import GhcMonad
import HscTypes
import NameSet
import OccName
import Outputable
import PprTyThing
import StringBuffer
import TcType
import Var (varType)
import System.Directory
import SysTools
#if __GLASGOW_HASKELL__ >= 800
import GHCi (stopIServ)
#endif
import qualified Name
import qualified InstEnv
import qualified Pretty
import qualified StringBuffer as SB
#if __GLASGOW_HASKELL__ >= 710
import CoAxiom (coAxiomTyCon)
#endif
#if __GLASGOW_HASKELL__ >= 708
import FamInstEnv
import ConLike (ConLike(..))
import PatSyn
#else
import TcRnTypes
#endif
-- GHC 7.8 doesn't define this macro, nor does GHC 7.10.0
-- It IS defined from 7.10.1 and up though.
-- So we can only test for 7.10.1.0 and up with it.
#if __GLASGOW_HASKELL__ < 710
#ifndef MIN_VERSION_GLASGOW_HASKELL
#define MIN_VERSION_GLASGOW_HASKELL(a,b,c,d) FALSE
#endif
#endif
#if MIN_VERSION_GLASGOW_HASKELL(8,0,1,20161117)
import GHC hiding (ClsInst, withCleanupSession)
import qualified GHC (withCleanupSession)
#elif __GLASGOW_HASKELL__ >= 706
import GHC hiding (ClsInst)
#else
import GHC hiding (Instance)
import Control.Arrow hiding ((<+>))
import Data.Convertible
import RdrName (rdrNameOcc)
#endif
#if __GLASGOW_HASKELL__ < 710
import UniqFM (eltsUFM)
import Module
#endif
#if __GLASGOW_HASKELL__ >= 704
import qualified Data.IntSet as I (IntSet, empty)
#endif
#if __GLASGOW_HASKELL__ < 706
import Control.DeepSeq (NFData(rnf))
import Data.ByteString.Lazy.Internal (ByteString(..))
#endif
import Bag
import Lexer as L
import Parser
import SrcLoc
import Packages
import Data.Generics (GenericQ, extQ, gmapQ)
import GHC.SYB.Utils (Stage(..))
import Language.Haskell.GhcMod.Types (Expression(..))
import Prelude
----------------------------------------------------------------
----------------------------------------------------------------
--
#if __GLASGOW_HASKELL__ >= 706
type ClsInst = InstEnv.ClsInst
#else
type ClsInst = InstEnv.Instance
#endif
mkTarget :: TargetId -> Bool -> Maybe (SB.StringBuffer, UTCTime) -> Target
#if __GLASGOW_HASKELL__ >= 706
mkTarget = Target
#else
mkTarget tid allowObjCode = Target tid allowObjCode . (fmap . second) convert
#endif
----------------------------------------------------------------
----------------------------------------------------------------
withStyle :: DynFlags -> PprStyle -> SDoc -> Pretty.Doc
#if __GLASGOW_HASKELL__ >= 706
withStyle = withPprStyleDoc
#else
withStyle _ = withPprStyleDoc
#endif
#if __GLASGOW_HASKELL__ >= 800
-- flip LogAction
type GmLogAction = WarnReason -> DynFlags -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
#elif __GLASGOW_HASKELL__ >= 706
type GmLogAction = forall a. a -> LogAction
#else
type GmLogAction = forall a. a -> DynFlags -> LogAction
#endif
-- DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
setLogAction :: DynFlags -> GmLogAction -> DynFlags
setLogAction df f =
#if __GLASGOW_HASKELL__ >= 800
df { log_action = flip f }
#elif __GLASGOW_HASKELL__ >= 706
df { log_action = f (error "setLogAction") }
#else
df { log_action = f (error "setLogAction") df }
#endif
showDocWith :: DynFlags -> Pretty.Mode -> Pretty.Doc -> String
#if __GLASGOW_HASKELL__ >= 800
showDocWith dflags mode = Pretty.renderStyle mstyle where
mstyle = Pretty.style { Pretty.mode = mode, Pretty.lineLength = pprCols dflags }
#elif __GLASGOW_HASKELL__ >= 708
-- Pretty.showDocWith disappeard.
-- https://github.com/ghc/ghc/commit/08a3536e4246e323fbcd8040e0b80001950fe9bc
showDocWith dflags mode = Pretty.showDoc mode (pprCols dflags)
#else
showDocWith _ = Pretty.showDocWith
#endif
render :: Pretty.Doc -> String
#if __GLASGOW_HASKELL__ >= 800
render = Pretty.fullRender Pretty.PageMode 80 1.2 string_txt ""
#else
render = Pretty.fullRender Pretty.PageMode 80 1.2 string_txt ""
#endif
where
string_txt :: Pretty.TextDetails -> String -> String
string_txt (Pretty.Chr c) s = c:s
string_txt (Pretty.Str s1) s2 = s1 ++ s2
string_txt (Pretty.PStr s1) s2 = unpackFS s1 ++ s2
string_txt (Pretty.ZStr s1) s2 = zString s1 ++ s2
string_txt (Pretty.LStr s1 _) s2 = unpackLitString s1 ++ s2
----------------------------------------------------------------
----------------------------------------------------------------
getSrcSpan :: SrcSpan -> Maybe (Int,Int,Int,Int)
#if __GLASGOW_HASKELL__ >= 702
getSrcSpan (RealSrcSpan spn)
#else
getSrcSpan spn | isGoodSrcSpan spn
#endif
= Just (srcSpanStartLine spn
, srcSpanStartCol spn
, srcSpanEndLine spn
, srcSpanEndCol spn)
getSrcSpan _ = Nothing
getSrcFile :: SrcSpan -> Maybe String
#if __GLASGOW_HASKELL__ >= 702
getSrcFile (RealSrcSpan spn) = Just . unpackFS . srcSpanFile $ spn
#else
getSrcFile spn | isGoodSrcSpan spn = Just . unpackFS . srcSpanFile $ spn
#endif
getSrcFile _ = Nothing
----------------------------------------------------------------
toStringBuffer :: GhcMonad m => [String] -> m StringBuffer
#if __GLASGOW_HASKELL__ >= 702
toStringBuffer = return . stringToStringBuffer . unlines
#else
toStringBuffer = liftIO . stringToStringBuffer . unlines
#endif
----------------------------------------------------------------
ghcCmdOptions :: [String]
#if __GLASGOW_HASKELL__ >= 710
-- this also includes -X options and all sorts of other things so the
ghcCmdOptions = flagsForCompletion False
#else
ghcCmdOptions = [ "-f" ++ prefix ++ option
| option <- opts
, prefix <- ["","no-"]
]
# if __GLASGOW_HASKELL__ >= 704
where opts =
[option | (option,_,_) <- fFlags]
++ [option | (option,_,_) <- fWarningFlags]
++ [option | (option,_,_) <- fLangFlags]
# else
where opts =
[option | (option,_,_,_) <- fFlags]
++ [option | (option,_,_,_) <- fWarningFlags]
++ [option | (option,_,_,_) <- fLangFlags]
# endif
#endif
----------------------------------------------------------------
----------------------------------------------------------------
fileModSummary :: GhcMonad m => FilePath -> m ModSummary
fileModSummary file' = do
mss <- getModuleGraph
file <- liftIO $ canonicalizePath file'
[ms] <- liftIO $ flip filterM mss $ \m ->
(Just file==) <$> canonicalizePath `traverse` ml_hs_file (ms_location m)
return ms
withInteractiveContext :: GhcMonad m => m a -> m a
withInteractiveContext action = gbracket setup teardown body
where
setup = getContext
teardown = setCtx
body _ = do
topImports >>= setCtx
action
topImports = do
ms <- filterM moduleIsInterpreted =<< map ms_mod <$> getModuleGraph
let iis = map (IIModule . modName) ms
#if __GLASGOW_HASKELL__ >= 704
return iis
#else
return (iis,[])
#endif
#if __GLASGOW_HASKELL__ >= 706
modName = moduleName
setCtx = setContext
#elif __GLASGOW_HASKELL__ >= 704
modName = id
setCtx = setContext
#else
modName = ms_mod
setCtx = uncurry setContext
#endif
showSeverityCaption :: Severity -> String
#if __GLASGOW_HASKELL__ >= 706
showSeverityCaption SevWarning = "Warning: "
showSeverityCaption _ = ""
#else
showSeverityCaption = const ""
#endif
----------------------------------------------------------------
----------------------------------------------------------------
setCabalPkg :: DynFlags -> DynFlags
#if __GLASGOW_HASKELL__ >= 708
setCabalPkg dflag = gopt_set dflag Opt_BuildingCabalPackage
#else
setCabalPkg dflag = dopt_set dflag Opt_BuildingCabalPackage
#endif
----------------------------------------------------------------
setHideAllPackages :: DynFlags -> DynFlags
#if __GLASGOW_HASKELL__ >= 708
setHideAllPackages df = gopt_set df Opt_HideAllPackages
#else
setHideAllPackages df = dopt_set df Opt_HideAllPackages
#endif
----------------------------------------------------------------
setDumpSplices :: DynFlags -> DynFlags
setDumpSplices dflag = dopt_set dflag Opt_D_dump_splices
isDumpSplices :: DynFlags -> Bool
isDumpSplices dflag = dopt Opt_D_dump_splices dflag
----------------------------------------------------------------
setDeferTypeErrors :: DynFlags -> DynFlags
#if __GLASGOW_HASKELL__ >= 708
setDeferTypeErrors dflag = gopt_set dflag Opt_DeferTypeErrors
#elif __GLASGOW_HASKELL__ >= 706
setDeferTypeErrors dflag = dopt_set dflag Opt_DeferTypeErrors
#else
setDeferTypeErrors = id
#endif
setDeferTypedHoles :: DynFlags -> DynFlags
#if __GLASGOW_HASKELL__ >= 710
setDeferTypedHoles dflag = gopt_set dflag Opt_DeferTypedHoles
#else
setDeferTypedHoles = id
#endif
setWarnTypedHoles :: DynFlags -> DynFlags
#if __GLASGOW_HASKELL__ >= 708
setWarnTypedHoles dflag = wopt_set dflag Opt_WarnTypedHoles
#else
setWarnTypedHoles = id
#endif
----------------------------------------------------------------
-- | Set 'DynFlags' equivalent to "-fno-max-relevant-bindings".
setNoMaxRelevantBindings :: DynFlags -> DynFlags
#if __GLASGOW_HASKELL__ >= 708
setNoMaxRelevantBindings df = df { maxRelevantBinds = Nothing }
#else
setNoMaxRelevantBindings = id
#endif
----------------------------------------------------------------
----------------------------------------------------------------
class HasType a where
getType :: GhcMonad m => TypecheckedModule -> a -> m (Maybe (SrcSpan, Type))
instance HasType (LHsBind Id) where
#if __GLASGOW_HASKELL__ >= 708
getType _ (L spn FunBind{fun_matches = m}) = return $ Just (spn, typ)
where in_tys = mg_arg_tys m
out_typ = mg_res_ty m
typ = mkFunTys in_tys out_typ
#else
getType _ (L spn FunBind{fun_matches = MatchGroup _ typ}) = return $ Just (spn, typ)
#endif
getType _ _ = return Nothing
----------------------------------------------------------------
----------------------------------------------------------------
-- from ghc/InteractiveUI.hs
filterOutChildren :: (a -> TyThing) -> [a] -> [a]
filterOutChildren get_thing xs
= [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
where
implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
infoThing :: GhcMonad m => (FilePath -> FilePath) -> Expression -> m SDoc
infoThing m (Expression str) = do
names <- parseName str
#if __GLASGOW_HASKELL__ >= 708
mb_stuffs <- mapM (getInfo False) names
let filtered = filterOutChildren (\(t,_f,_i,_fam) -> t) (catMaybes mb_stuffs)
#else
mb_stuffs <- mapM getInfo names
let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
#endif
return $ vcat (intersperse (text "") $ map (pprInfo m False) filtered)
#if __GLASGOW_HASKELL__ >= 708
pprInfo :: (FilePath -> FilePath) -> Bool -> (TyThing, GHC.Fixity, [ClsInst], [FamInst]) -> SDoc
pprInfo m _ (thing, fixity, insts, famInsts)
= pprTyThingInContextLoc' thing
$$ show_fixity fixity
$$ vcat (map pprInstance' insts)
$$ vcat (map pprFamInst' famInsts)
#else
pprInfo :: (FilePath -> FilePath) -> PrintExplicitForalls -> (TyThing, GHC.Fixity, [ClsInst]) -> SDoc
pprInfo m pefas (thing, fixity, insts)
= pprTyThingInContextLoc' pefas thing
$$ show_fixity fixity
$$ vcat (map pprInstance' insts)
#endif
where
show_fixity fx
| fx == defaultFixity = Outputable.empty
| otherwise = ppr fx <+> ppr (getName thing)
#if __GLASGOW_HASKELL__ >= 708
pprTyThingInContextLoc' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext thing')
#if __GLASGOW_HASKELL__ >= 710
pprFamInst' (FamInst { fi_flavor = DataFamilyInst rep_tc })
= pprTyThingInContextLoc (ATyCon rep_tc)
pprFamInst' (FamInst { fi_flavor = SynFamilyInst, fi_axiom = axiom
, fi_tys = lhs_tys, fi_rhs = rhs })
= showWithLoc (pprDefinedAt' (getName axiom)) $
hang (ptext (sLit "type instance") <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys)
2 (equals <+> ppr rhs)
#else
pprFamInst' ispec = showWithLoc (pprDefinedAt' (getName ispec)) (pprFamInstHdr ispec)
#endif
#else
pprTyThingInContextLoc' pefas' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext pefas' thing')
#endif
showWithLoc loc doc
= hang doc 2 (char '\t' <> comment <+> loc)
-- The tab tries to make them line up a bit
where
comment = ptext (sLit "--")
pprInstance' ispec = hang (pprInstanceHdr ispec)
2 (ptext (sLit "--") <+> pprDefinedAt' (getName ispec))
pprDefinedAt' thing' = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing')
pprNameDefnLoc' name
= case Name.nameSrcLoc name of
RealSrcLoc s -> ptext (sLit "at") <+> ppr (subst s)
UnhelpfulLoc s
| Name.isInternalName name || Name.isSystemName name
-> ptext (sLit "at") <+> ftext s
| otherwise
-> ptext (sLit "in") <+> quotes (ppr (nameModule name))
where subst s = mkRealSrcLoc (realFP s) (srcLocLine s) (srcLocCol s)
realFP = mkFastString . m . unpackFS . srcLocFile
----------------------------------------------------------------
----------------------------------------------------------------
errorMsgSpan :: ErrMsg -> SrcSpan
#if __GLASGOW_HASKELL__ >= 708
errorMsgSpan = errMsgSpan
#else
errorMsgSpan = head . errMsgSpans
#endif
setErrorMsgSpan :: ErrMsg -> SrcSpan -> ErrMsg
#if __GLASGOW_HASKELL__ >= 708
setErrorMsgSpan err s = err { errMsgSpan = s }
#else
setErrorMsgSpan err s = err { errMsgSpans = [s] }
#endif
typeForUser :: Type -> SDoc
#if __GLASGOW_HASKELL__ >= 708
typeForUser = pprTypeForUser
#else
typeForUser = pprTypeForUser False
#endif
nameForUser :: Name -> SDoc
nameForUser = pprOccName . getOccName
occNameForUser :: OccName -> SDoc
occNameForUser = pprOccName
deSugar :: TypecheckedModule -> LHsExpr Id -> HscEnv
-> IO (Maybe CoreExpr)
#if __GLASGOW_HASKELL__ >= 708
deSugar _ e hs_env = snd <$> deSugarExpr hs_env e
#else
deSugar tcm e hs_env = snd <$> deSugarExpr hs_env modu rn_env ty_env e
where
modu = ms_mod $ pm_mod_summary $ tm_parsed_module tcm
tcgEnv = fst $ tm_internals_ tcm
rn_env = tcg_rdr_env tcgEnv
ty_env = tcg_type_env tcgEnv
#endif
----------------------------------------------------------------
----------------------------------------------------------------
data GapThing = GtA Type
| GtT TyCon
| GtN
#if __GLASGOW_HASKELL__ >= 800
| GtPatSyn PatSyn
#endif
fromTyThing :: TyThing -> GapThing
fromTyThing (AnId i) = GtA $ varType i
#if __GLASGOW_HASKELL__ >= 708
fromTyThing (AConLike (RealDataCon d)) = GtA $ dataConUserType d
#if __GLASGOW_HASKELL__ >= 800
fromTyThing (AConLike (PatSynCon p)) = GtPatSyn p
#else
fromTyThing (AConLike (PatSynCon p)) = GtA $ patSynType p
#endif
#else
fromTyThing (ADataCon d) = GtA $ dataConUserType d
#endif
fromTyThing (ATyCon t) = GtT t
fromTyThing _ = GtN
----------------------------------------------------------------
----------------------------------------------------------------
#if __GLASGOW_HASKELL__ >= 704
type WarnFlags = I.IntSet
emptyWarnFlags :: WarnFlags
emptyWarnFlags = I.empty
#else
type WarnFlags = [WarningFlag]
emptyWarnFlags :: WarnFlags
emptyWarnFlags = []
#endif
----------------------------------------------------------------
----------------------------------------------------------------
#if __GLASGOW_HASKELL__ >= 708
type GLMatch = LMatch RdrName (LHsExpr RdrName)
type GLMatchI = LMatch Id (LHsExpr Id)
#else
type GLMatch = LMatch RdrName
type GLMatchI = LMatch Id
#endif
getClass :: [LInstDecl Name] -> Maybe (Name, SrcSpan)
#if __GLASGOW_HASKELL__ >= 800
-- Instance declarations of sort 'instance F (G a)'
getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = HsIB _ (L _ (HsForAllTy _ (L _ (HsAppTy (L _ (HsTyVar (L _ className))) _))))}))] = Just (className, loc)
-- Instance declarations of sort 'instance F G' (no variables)
getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = HsIB _ (L _ (HsAppTy (L _ (HsTyVar (L _ className))) _))}))] = Just (className, loc)
#elif __GLASGOW_HASKELL__ >= 710
-- Instance declarations of sort 'instance F (G a)'
getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsForAllTy _ _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _))))}))] = Just (className, loc)
-- Instance declarations of sort 'instance F G' (no variables)
getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsAppTy (L _ (HsTyVar className)) _))}))] = Just (className, loc)
#elif __GLASGOW_HASKELL__ >= 708
-- Instance declarations of sort 'instance F (G a)'
getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _))))}))] = Just (className, loc)
-- Instance declarations of sort 'instance F G' (no variables)
getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsAppTy (L _ (HsTyVar className)) _))}))] = Just (className, loc)
#elif __GLASGOW_HASKELL__ >= 706
getClass [L loc (ClsInstD (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _)))) _ _ _)] = Just (className, loc)
getClass[L loc (ClsInstD (L _ (HsAppTy (L _ (HsTyVar className)) _)) _ _ _)] = Just (className, loc)
#else
getClass [L loc (InstDecl (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _)))) _ _ _)] = Just (className, loc)
getClass [L loc (InstDecl (L _ (HsAppTy (L _ (HsTyVar className)) _)) _ _ _)] = Just (className, loc)
#endif
getClass _ = Nothing
#if __GLASGOW_HASKELL__ < 706
occName :: RdrName -> OccName
occName = rdrNameOcc
#endif
----------------------------------------------------------------
#if __GLASGOW_HASKELL__ < 710
-- Copied from ghc/InteractiveUI.hs
allExposedPackageConfigs :: DynFlags -> [PackageConfig]
allExposedPackageConfigs df = filter exposed $ eltsUFM $ pkgIdMap $ pkgState df
allExposedModules :: DynFlags -> [ModuleName]
allExposedModules df = concat $ map exposedModules $ allExposedPackageConfigs df
listVisibleModuleNames :: DynFlags -> [ModuleName]
listVisibleModuleNames = allExposedModules
#endif
lookupModulePackageInAllPackages ::
DynFlags -> ModuleName -> [String]
lookupModulePackageInAllPackages df mn =
#if __GLASGOW_HASKELL__ >= 710
unpackSPId . sourcePackageId . snd <$> lookupModuleInAllPackages df mn
where
unpackSPId (SourcePackageId fs) = unpackFS fs
#else
unpackPId . sourcePackageId . fst <$> lookupModuleInAllPackages df mn
where
unpackPId pid = packageIdString $ mkPackageId pid
-- n ++ "-" ++ showVersion v
#endif
listVisibleModules :: DynFlags -> [GHC.Module]
listVisibleModules df = let
#if __GLASGOW_HASKELL__ >= 710
modNames = listVisibleModuleNames df
mods = [ m | mn <- modNames, (m, _) <- lookupModuleInAllPackages df mn ]
#else
pkgCfgs = allExposedPackageConfigs df
mods = [ mkModule pid modname | p <- pkgCfgs
, let pid = packageConfigId p
, modname <- exposedModules p ]
#endif
in mods
isSynTyCon :: TyCon -> Bool
#if __GLASGOW_HASKELL__ >= 710
isSynTyCon = GHC.isTypeSynonymTyCon
#else
isSynTyCon = GHC.isSynTyCon
#endif
parseModuleHeader
:: String -- ^ Haskell module source text (full Unicode is supported)
-> DynFlags
-> FilePath -- ^ the filename (for source locations)
-> Either ErrorMessages (WarningMessages, Located (HsModule RdrName))
parseModuleHeader str dflags filename =
let
loc = mkRealSrcLoc (mkFastString filename) 1 1
buf = stringToStringBuffer str
in
case L.unP Parser.parseHeader (mkPState dflags buf loc) of
PFailed sp err ->
#if __GLASGOW_HASKELL__ >= 706
Left (unitBag (mkPlainErrMsg dflags sp err))
#else
Left (unitBag (mkPlainErrMsg sp err))
#endif
POk pst rdr_module ->
let (warns,_) = getMessages pst in
Right (warns, rdr_module)
mkErrStyle' :: DynFlags -> PrintUnqualified -> PprStyle
#if __GLASGOW_HASKELL__ >= 706
mkErrStyle' = Outputable.mkErrStyle
#else
mkErrStyle' _ = Outputable.mkErrStyle
#endif
#if __GLASGOW_HASKELL__ < 706
instance NFData ByteString where
rnf Empty = ()
rnf (Chunk _ b) = rnf b
#endif
-- | Like 'everything', but avoid known potholes, based on the 'Stage' that
-- generated the Ast.
everythingStagedWithContext :: Stage -> s -> (r -> r -> r) -> r -> GenericQ (s -> (r, s)) -> GenericQ r
everythingStagedWithContext stage s0 f z q x
| (const False
#if __GLASGOW_HASKELL__ <= 708
`extQ` postTcType
#endif
`extQ` fixity `extQ` nameSet) x = z
| otherwise = foldl f r (gmapQ (everythingStagedWithContext stage s' f z q) x)
where nameSet = const (stage `elem` [Parser,TypeChecker]) :: NameSet -> Bool
#if __GLASGOW_HASKELL__ <= 708
postTcType = const (stage<TypeChecker) :: PostTcType -> Bool
#endif
fixity = const (stage<Renamer) :: GHC.Fixity -> Bool
(r, s') = q x s0
withCleanupSession :: GhcMonad m => m a -> m a
#if __GLASGOW_HASKELL__ >= 800
#if MIN_VERSION_GLASGOW_HASKELL(8,0,1,20161117)
withCleanupSession = GHC.withCleanupSession
#else
withCleanupSession ghc = ghc `gfinally` cleanup
where
cleanup = do
hsc_env <- getSession
let dflags = hsc_dflags hsc_env
liftIO $ do
cleanTempFiles dflags
cleanTempDirs dflags
stopIServ hsc_env
#endif
#else
withCleanupSession action = do
df <- getSessionDynFlags
GHC.defaultCleanupHandler df action
#endif

109
core/Language/Haskell/GhcMod/GhcPkg.hs Normal file
View File

@@ -0,0 +1,109 @@
{-# LANGUAGE BangPatterns, ScopedTypeVariables, TupleSections #-}
module Language.Haskell.GhcMod.GhcPkg (
ghcPkgDbOpt
, ghcPkgDbStackOpts
, ghcDbStackOpts
, ghcDbOpt
, getPackageDbStack
, getPackageCachePaths
, getGhcPkgProgram
) where
import Config (cProjectVersion, cTargetPlatformString, cProjectVersionInt)
import Control.Applicative
import Data.List.Split (splitOn)
import Data.Maybe
import Exception (handleIO)
import System.Directory (doesDirectoryExist, getAppUserDataDirectory)
import System.FilePath ((</>))
import Prelude
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.CabalHelper
import Language.Haskell.GhcMod.PathsAndFiles
import Language.Haskell.GhcMod.CustomPackageDb
import Language.Haskell.GhcMod.Stack
ghcVersion :: Int
ghcVersion = read cProjectVersionInt
----------------------------------------------------------------
-- | Get options needed to add a list of package dbs to ghc-pkg's db stack
ghcPkgDbStackOpts :: [GhcPkgDb] -- ^ Package db stack
-> [String]
ghcPkgDbStackOpts dbs = ghcPkgDbOpt `concatMap` dbs
-- | Get options needed to add a list of package dbs to ghc's db stack
ghcDbStackOpts :: [GhcPkgDb] -- ^ Package db stack
-> [String]
ghcDbStackOpts dbs = ghcDbOpt `concatMap` dbs
----------------------------------------------------------------
ghcPkgDbOpt :: GhcPkgDb -> [String]
ghcPkgDbOpt GlobalDb = ["--global"]
ghcPkgDbOpt UserDb = ["--user"]
ghcPkgDbOpt (PackageDb pkgDb)
| ghcVersion < 706 = ["--no-user-package-conf", "--package-conf=" ++ pkgDb]
| otherwise = ["--no-user-package-db", "--package-db=" ++ pkgDb]
ghcDbOpt :: GhcPkgDb -> [String]
ghcDbOpt GlobalDb
| ghcVersion < 706 = ["-global-package-conf"]
| otherwise = ["-global-package-db"]
ghcDbOpt UserDb
| ghcVersion < 706 = ["-user-package-conf"]
| otherwise = ["-user-package-db"]
ghcDbOpt (PackageDb pkgDb)
| ghcVersion < 706 = ["-no-user-package-conf", "-package-conf", pkgDb]
| otherwise = ["-no-user-package-db", "-package-db", pkgDb]
----------------------------------------------------------------
getGhcPkgProgram :: IOish m => GhcModT m FilePath
getGhcPkgProgram = do
crdl <- cradle
progs <- optPrograms <$> options
case cradleProject crdl of
(StackProject senv) -> do
Just ghcPkg <- getStackGhcPkgPath senv
return ghcPkg
_ ->
return $ ghcPkgProgram progs
getPackageDbStack :: IOish m => GhcModT m [GhcPkgDb]
getPackageDbStack = do
crdl <- cradle
mCusPkgStack <- getCustomPkgDbStack
stack <- case cradleProject crdl of
PlainProject ->
return [GlobalDb, UserDb]
SandboxProject -> do
Just db <- liftIO $ getSandboxDb crdl
return $ [GlobalDb, db]
CabalProject ->
getCabalPackageDbStack
(StackProject StackEnv {..}) ->
return $ [GlobalDb, PackageDb seSnapshotPkgDb, PackageDb seLocalPkgDb]
return $ fromMaybe stack mCusPkgStack
getPackageCachePaths :: IOish m => FilePath -> GhcModT m [FilePath]
getPackageCachePaths sysPkgCfg = do
pkgDbStack <- getPackageDbStack
catMaybes <$> (liftIO . resolvePackageConfig sysPkgCfg) `mapM` pkgDbStack
-- TODO: use PkgConfRef
--- Copied from ghc module `Packages' unfortunately it's not exported :/
resolvePackageConfig :: FilePath -> GhcPkgDb -> IO (Maybe FilePath)
resolvePackageConfig sysPkgCfg GlobalDb = return $ Just sysPkgCfg
resolvePackageConfig _ UserDb = handleIO (\_ -> return Nothing) $ do
appdir <- getAppUserDataDirectory "ghc"
let dir = appdir </> (target_arch ++ '-':target_os ++ '-':cProjectVersion)
pkgconf = dir </> "package.conf.d"
exist <- doesDirectoryExist pkgconf
return $ if exist then Just pkgconf else Nothing
where
[target_arch,_,target_os] = splitOn "-" cTargetPlatformString
resolvePackageConfig _ (PackageDb name) = return $ Just name

271
core/Language/Haskell/GhcMod/HomeModuleGraph.hs Normal file
View File

@@ -0,0 +1,271 @@
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE ScopedTypeVariables, RecordWildCards #-}
module Language.Haskell.GhcMod.HomeModuleGraph (
GmModuleGraph(..)
, ModulePath(..)
, mkFileMap
, mkModuleMap
, mkMainModulePath
, findModulePath
, findModulePathSet
, fileModuleName
, canonicalizeModulePath
, homeModuleGraph
, updateHomeModuleGraph
, canonicalizeModuleGraph
, reachable
, moduleGraphToDot
) where
import DriverPipeline
import DynFlags
import ErrUtils
import Exception
import Finder
import GHC
import HscTypes
import Pretty
import Control.Arrow ((&&&))
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
import Control.Monad.State.Strict (execStateT)
import Control.Monad.State.Class
import Data.Maybe
import Data.Monoid as Monoid
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import System.FilePath
import System.Directory
import System.IO
import Prelude
import Language.Haskell.GhcMod.Logging
import Language.Haskell.GhcMod.Logger
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils (withMappedFile)
import Language.Haskell.GhcMod.Gap (parseModuleHeader)
-- | Turn module graph into a graphviz dot file
--
-- @dot -Tpng -o modules.png modules.dot@
moduleGraphToDot :: GmModuleGraph -> String
moduleGraphToDot GmModuleGraph { gmgGraph } =
"digraph {\n" ++ concatMap edges (Map.toList graph) ++ "}\n"
where
graph = Map.map (Set.mapMonotonic mpPath)
$ Map.mapKeysMonotonic mpPath gmgGraph
edges :: (FilePath, (Set FilePath)) -> String
edges (f, sf) =
concatMap (\f' -> " \""++ f ++"\" -> \""++ f' ++"\"\n") (Set.toList sf)
data S = S {
sErrors :: [(ModulePath, ErrorMessages)],
sWarnings :: [(ModulePath, WarningMessages)],
sGraph :: GmModuleGraph
}
defaultS :: S
defaultS = S [] [] mempty
putErr :: MonadState S m
=> (ModulePath, ErrorMessages) -> m ()
putErr e = do
s <- get
put s { sErrors = e:sErrors s}
putWarn :: MonadState S m
=> (ModulePath, ErrorMessages) -> m ()
putWarn w = do
s <- get
put s { sWarnings = w:sWarnings s}
gmgLookupMP :: MonadState S m => ModulePath -> m (Maybe (Set ModulePath))
gmgLookupMP k = (Map.lookup k . gmgGraph . sGraph) `liftM` get
graphUnion :: MonadState S m => GmModuleGraph -> m ()
graphUnion gmg = do
s <- get
put s { sGraph = sGraph s `mappend` gmg }
reachable :: Set ModulePath -> GmModuleGraph -> Set ModulePath
reachable smp0 GmModuleGraph {..} = go smp0
where
go smp = let
δsmp = Set.unions $
collapseMaybeSet . flip Map.lookup gmgGraph <$> Set.toList smp
smp' = smp `Set.union` δsmp
in if smp == smp' then smp' else go smp'
pruneUnreachable :: Set ModulePath -> GmModuleGraph -> GmModuleGraph
pruneUnreachable smp0 gmg@GmModuleGraph {..} = let
r = reachable smp0 gmg
in
GmModuleGraph {
gmgGraph = Map.filterWithKey (\k _ -> k `Set.member` r) gmgGraph
}
collapseMaybeSet :: Maybe (Set a) -> Set a
collapseMaybeSet = maybe Set.empty id
homeModuleGraph :: (IOish m, Gm m)
=> HscEnv -> Set ModulePath -> m GmModuleGraph
homeModuleGraph env smp = updateHomeModuleGraph env mempty smp smp
mkMainModulePath :: FilePath -> ModulePath
mkMainModulePath = ModulePath (mkModuleName "Main")
findModulePath :: HscEnv -> ModuleName -> IO (Maybe ModulePath)
findModulePath env mn = do
fmap (ModulePath mn) <$> find env mn
findModulePathSet :: HscEnv -> [ModuleName] -> IO (Set ModulePath)
findModulePathSet env mns = do
Set.fromList . catMaybes <$> findModulePath env `mapM` mns
find :: MonadIO m => HscEnv -> ModuleName -> m (Maybe FilePath)
find env mn = liftIO $ do
res <- findHomeModule env mn
case res of
-- TODO: handle SOURCE imports (hs-boot stuff): addBootSuffixLocn loc
Found loc@ModLocation { ml_hs_file = Just _ } _mod ->
return $ normalise <$> ml_hs_file loc
_ -> return Nothing
canonicalizeModulePath :: ModulePath -> IO ModulePath
canonicalizeModulePath (ModulePath mn fp) = ModulePath mn <$> canonicalizePath fp
canonicalizeModuleGraph :: MonadIO m => GmModuleGraph -> m GmModuleGraph
canonicalizeModuleGraph GmModuleGraph {..} = liftIO $ do
GmModuleGraph . Map.fromList <$> mapM fmg (Map.toList gmgGraph)
where
fmg (mp, smp) = liftM2 (,) (canonicalizeModulePath mp) (Set.fromList <$> mapM canonicalizeModulePath (Set.toList smp))
updateHomeModuleGraph :: (IOish m, Gm m)
=> HscEnv
-> GmModuleGraph
-> Set ModulePath -- ^ Initial set of modules
-> Set ModulePath -- ^ Updated set of modules
-> m GmModuleGraph
updateHomeModuleGraph env GmModuleGraph {..} smp sump = do
-- TODO: It would be good if we could retain information about modules that
-- stop to compile after we've already successfully parsed them at some
-- point. Figure out a way to delete the modules about to be updated only
-- after we're sure they won't fail to parse .. or something. Should probably
-- push this whole prune logic deep into updateHomeModuleGraph'
(pruneUnreachable smp . sGraph) `liftM` runS (updateHomeModuleGraph' env sump)
where
runS = flip execStateT defaultS { sGraph = graph' }
graph' = GmModuleGraph {
gmgGraph = Set.foldr Map.delete gmgGraph sump
}
mkFileMap :: Set ModulePath -> Map FilePath ModulePath
mkFileMap smp = Map.fromList $ map (mpPath &&& id) $ Set.toList smp
mkModuleMap :: Set ModulePath -> Map ModuleName ModulePath
mkModuleMap smp = Map.fromList $ map (mpModule &&& id) $ Set.toList smp
updateHomeModuleGraph'
:: forall m. (MonadState S m, IOish m, Gm m)
=> HscEnv
-> Set ModulePath -- ^ Initial set of modules
-> m ()
updateHomeModuleGraph' env smp0 = do
go `mapM_` Set.toList smp0
where
go :: ModulePath -> m ()
go mp = do
msmp <- gmgLookupMP mp
case msmp of
Just _ -> return ()
Nothing -> do
smp <- collapseMaybeSet `liftM` step mp
graphUnion GmModuleGraph {
gmgGraph = Map.singleton mp smp
}
mapM_ go (Set.toList smp)
step :: ModulePath -> m (Maybe (Set ModulePath))
step mp = runMaybeT $ do
(dflags, ppsrc_fn) <- MaybeT preprocess'
src <- liftIO $ readFile ppsrc_fn
imports mp src dflags
where
preprocess' :: m (Maybe (DynFlags, FilePath))
preprocess' = do
let fn = mpPath mp
ep <- preprocessFile env fn
case ep of
Right (_, x) -> return $ Just x
Left errs -> do
-- TODO: Remember these and present them as proper errors if this is
-- the file the user is looking at.
gmLog GmWarning ("preprocess " ++ show fn) $ Pretty.empty $+$ (vcat $ map text errs)
return Nothing
imports :: ModulePath -> String -> DynFlags -> MaybeT m (Set ModulePath)
imports mp@ModulePath {..} src dflags =
case parseModuleHeader src dflags mpPath of
Left err -> do
putErr (mp, err)
mzero
Right (ws, lmdl) -> do
putWarn (mp, ws)
let HsModule {..} = unLoc lmdl
mns = map (unLoc . ideclName)
$ filter (isNothing . ideclPkgQual)
$ map unLoc hsmodImports
-- TODO: handle package qualifier "this"
liftIO $ Set.fromList . catMaybes <$> mapM (findModulePath env) mns
preprocessFile :: (IOish m, GmEnv m, GmState m) =>
HscEnv -> FilePath -> m (Either [String] ([String], (DynFlags, FilePath)))
preprocessFile env file =
withLogger' env $ \setDf -> do
withMappedFile file $ \fn -> do
let env' = env { hsc_dflags = setDf (hsc_dflags env) }
liftIO $ preprocess env' (fn, Nothing)
fileModuleName :: (IOish m, GmEnv m, GmState m) =>
HscEnv -> FilePath -> m (Either [String] (Maybe ModuleName))
fileModuleName env fn = do
let handler = liftIO . handle (\(_ :: SomeException) -> return $ Right Nothing)
ep <- preprocessFile env fn
case ep of
Left errs -> do
return $ Left errs
Right (_warns, (dflags, procdFile)) -> leftM (errBagToStrList env) =<< handler (do
src <- readFile procdFile
case parseModuleHeader src dflags procdFile of
Left errs -> return $ Left errs
Right (_, lmdl) -> do
let HsModule {..} = unLoc lmdl
return $ Right $ unLoc <$> hsmodName)
where
leftM f = either (return . Left <=< f) (return . Right)

60
core/Language/Haskell/GhcMod/LightGhc.hs Normal file
View File

@@ -0,0 +1,60 @@
module Language.Haskell.GhcMod.LightGhc where
import Control.Monad
import Control.Monad.Reader (runReaderT)
import Data.IORef
import GHC
import GHC.Paths (libdir)
import StaticFlags
import SysTools
import DynFlags
import HscMain
import HscTypes
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.DynFlags
import qualified Language.Haskell.GhcMod.Gap as Gap
-- We have to be more careful about tearing down 'HscEnv's since GHC 8 added an
-- out of process GHCI server which has to be shutdown.
newLightEnv :: IOish m => (DynFlags -> LightGhc DynFlags) -> m HscEnv
newLightEnv mdf = do
df <- liftIO $ do
initStaticOpts
settings <- initSysTools (Just libdir)
initDynFlags $ defaultDynFlags settings
hsc_env <- liftIO $ newHscEnv df
df' <- runLightGhc hsc_env $ mdf df
return $ hsc_env {
hsc_dflags = df',
hsc_IC = (hsc_IC hsc_env) { ic_dflags = df' }
}
teardownLightEnv :: MonadIO m => HscEnv -> m ()
teardownLightEnv env = runLightGhc env $ do
Gap.withCleanupSession $ return ()
withLightHscEnv'
:: IOish m => (DynFlags -> LightGhc DynFlags) -> (HscEnv -> m a) -> m a
withLightHscEnv' mdf action = gbracket (newLightEnv mdf) teardownLightEnv action
withLightHscEnv :: IOish m => [GHCOption] -> (HscEnv -> m a) -> m a
withLightHscEnv opts = withLightHscEnv' (f <=< liftIO . newHscEnv)
where
f env = runLightGhc env $ do
-- HomeModuleGraph and probably all other clients get into all sorts of
-- trouble if the package state isn't initialized here
_ <- setSessionDynFlags =<< addCmdOpts opts =<< getSessionDynFlags
getSessionDynFlags
runLightGhc :: MonadIO m => HscEnv -> LightGhc a -> m a
runLightGhc env action = liftIO $ do
renv <- newIORef env
flip runReaderT renv $ unLightGhc action
runLightGhc' :: MonadIO m => IORef HscEnv -> LightGhc a -> m a
runLightGhc' renv action = liftIO $ do
flip runReaderT renv $ unLightGhc action

189
core/Language/Haskell/GhcMod/Logger.hs Normal file
View File

@@ -0,0 +1,189 @@
{-# LANGUAGE CPP, RankNTypes #-}
module Language.Haskell.GhcMod.Logger (
withLogger
, withLogger'
, checkErrorPrefix
, errsToStr
, errBagToStrList
) where
import Control.Arrow
import Control.Applicative
import Data.Ord
import Data.List
import Data.Maybe
import Data.Function
import Control.Monad.Reader (Reader, ask, runReader)
import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
import System.FilePath (normalise)
import ErrUtils
import GHC
import HscTypes
import Outputable
import qualified GHC as G
import Bag
import SrcLoc
import FastString
import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Doc (showPage)
import Language.Haskell.GhcMod.DynFlags (withDynFlags)
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Error
import Language.Haskell.GhcMod.Pretty
import Language.Haskell.GhcMod.Utils (mkRevRedirMapFunc)
import qualified Language.Haskell.GhcMod.Gap as Gap
import Prelude
type Builder = [String] -> [String]
data Log = Log [String] Builder
newtype LogRef = LogRef (IORef Log)
data GmPprEnv = GmPprEnv { gpeDynFlags :: DynFlags
, gpeMapFile :: FilePath -> FilePath
}
type GmPprEnvM a = Reader GmPprEnv a
emptyLog :: Log
emptyLog = Log [] id
newLogRef :: IO LogRef
newLogRef = LogRef <$> newIORef emptyLog
readAndClearLogRef :: LogRef -> IO [String]
readAndClearLogRef (LogRef ref) = do
Log _ b <- readIORef ref
writeIORef ref emptyLog
return $ b []
appendLogRef :: (FilePath -> FilePath) -> DynFlags -> LogRef -> Gap.GmLogAction
appendLogRef map_file df (LogRef ref) _reason _df sev src st msg = do
modifyIORef ref update
where
-- TODO: get rid of ppMsg and just do more or less what ghc's
-- defaultLogAction does
l = ppMsg map_file df st src sev msg
update lg@(Log ls b)
| l `elem` ls = lg
| otherwise = Log (l:ls) (b . (l:))
----------------------------------------------------------------
-- | Logged messages are returned as 'String'.
-- Right is success and Left is failure.
withLogger :: (GmGhc m, GmEnv m, GmOut m, GmState m)
=> (DynFlags -> DynFlags)
-> m a
-> m (Either String (String, a))
withLogger f action = do
env <- G.getSession
oopts <- outputOpts
let conv = convert oopts
eres <- withLogger' env $ \setDf ->
withDynFlags (f . setDf) action
return $ either (Left . conv) (Right . first conv) eres
withLogger' :: (IOish m, GmState m, GmEnv m)
=> HscEnv -> ((DynFlags -> DynFlags) -> m a) -> m (Either [String] ([String], a))
withLogger' env action = do
logref <- liftIO $ newLogRef
rfm <- mkRevRedirMapFunc
let setLogger df = Gap.setLogAction df $ appendLogRef rfm df logref
handlers = [
GHandler $ \ex -> return $ Left $ runReader (sourceError ex) gpe,
GHandler $ \ex -> return $ Left [render $ ghcExceptionDoc ex]
]
gpe = GmPprEnv {
gpeDynFlags = hsc_dflags env
, gpeMapFile = rfm
}
a <- gcatches (Right <$> action setLogger) handlers
ls <- liftIO $ readAndClearLogRef logref
return ((,) ls <$> a)
errBagToStrList :: (IOish m, GmState m, GmEnv m) => HscEnv -> Bag ErrMsg -> m [String]
errBagToStrList env errs = do
rfm <- mkRevRedirMapFunc
return $ runReader
(errsToStr (sortMsgBag errs))
GmPprEnv{ gpeDynFlags = hsc_dflags env, gpeMapFile = rfm }
----------------------------------------------------------------
-- | Converting 'SourceError' to 'String'.
sourceError :: SourceError -> GmPprEnvM [String]
sourceError = errsToStr . sortMsgBag . srcErrorMessages
errsToStr :: [ErrMsg] -> GmPprEnvM [String]
errsToStr = mapM ppErrMsg
sortMsgBag :: Bag ErrMsg -> [ErrMsg]
sortMsgBag bag = sortBy (compare `on` Gap.errorMsgSpan) $ bagToList bag
----------------------------------------------------------------
ppErrMsg :: ErrMsg -> GmPprEnvM String
ppErrMsg err = do
GmPprEnv {..} <- ask
let unqual = errMsgContext err
st = Gap.mkErrStyle' gpeDynFlags unqual
err' = Gap.setErrorMsgSpan err $ mapSrcSpanFile gpeMapFile (Gap.errorMsgSpan err)
return $ showPage gpeDynFlags st $ pprLocErrMsg err'
mapSrcSpanFile :: (FilePath -> FilePath) -> SrcSpan -> SrcSpan
mapSrcSpanFile map_file (RealSrcSpan s) =
RealSrcSpan $ mapRealSrcSpanFile map_file s
mapSrcSpanFile _ (UnhelpfulSpan s) =
UnhelpfulSpan s
mapRealSrcSpanFile :: (FilePath -> FilePath) -> RealSrcSpan -> RealSrcSpan
mapRealSrcSpanFile map_file s = let
start = mapRealSrcLocFile map_file $ realSrcSpanStart s
end = mapRealSrcLocFile map_file $ realSrcSpanEnd s
in
mkRealSrcSpan start end
mapRealSrcLocFile :: (FilePath -> FilePath) -> RealSrcLoc -> RealSrcLoc
mapRealSrcLocFile map_file l = let
file = mkFastString $ map_file $ unpackFS $ srcLocFile l
line = srcLocLine l
col = srcLocCol l
in
mkRealSrcLoc file line col
ppMsg :: (FilePath -> FilePath) -> DynFlags -> PprStyle -> SrcSpan -> Severity -> SDoc -> String
ppMsg map_file df st spn sev msg = let
cts = showPage df st msg
in
ppMsgPrefix map_file df spn sev cts ++ cts
ppMsgPrefix :: (FilePath -> FilePath) -> DynFlags -> SrcSpan -> Severity -> String -> String
ppMsgPrefix map_file df spn sev cts =
let
defaultPrefix = if Gap.isDumpSplices df then "" else checkErrorPrefix
in
fromMaybe defaultPrefix $ do
(line,col,_,_) <- Gap.getSrcSpan spn
file <- map_file <$> normalise <$> Gap.getSrcFile spn
return $ file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++
if or (map (\x -> x `isPrefixOf` cts) warningAsErrorPrefixes)
then ""
else Gap.showSeverityCaption sev
checkErrorPrefix :: String
checkErrorPrefix = "Dummy:0:0:Error:"
warningAsErrorPrefixes :: [String]
warningAsErrorPrefixes = [ "Couldn't match expected type"
, "Couldn't match type"
, "No instance for"]

115
core/Language/Haskell/GhcMod/Logging.hs Normal file
View File

@@ -0,0 +1,115 @@
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Language.Haskell.GhcMod.Logging (
module Language.Haskell.GhcMod.Logging
, module Language.Haskell.GhcMod.Pretty
, GmLogLevel(..)
, module Data.Monoid
, module Pretty
) where
import Control.Applicative hiding (empty)
import Control.Monad
import Control.Monad.Trans.Class
import Data.List
import Data.Char
import Data.Monoid
import Data.Maybe
import System.IO
import System.FilePath
import Prelude
import Pretty hiding (style, (<>))
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Pretty
import Language.Haskell.GhcMod.Output
gmSetLogLevel :: GmLog m => GmLogLevel -> m ()
gmSetLogLevel level =
gmlJournal $ GhcModLog (Just level) (Last Nothing) []
gmGetLogLevel :: forall m. GmLog m => m GmLogLevel
gmGetLogLevel = do
GhcModLog { gmLogLevel = Just level } <- gmlHistory
return level
gmSetDumpLevel :: GmLog m => Bool -> m ()
gmSetDumpLevel level =
gmlJournal $ GhcModLog Nothing (Last (Just level)) []
increaseLogLevel :: GmLogLevel -> GmLogLevel
increaseLogLevel l | l == maxBound = l
increaseLogLevel l = succ l
decreaseLogLevel :: GmLogLevel -> GmLogLevel
decreaseLogLevel l | l == minBound = l
decreaseLogLevel l = pred l
-- |
-- >>> Just GmDebug <= Nothing
-- False
-- >>> Just GmException <= Just GmDebug
-- True
-- >>> Just GmDebug <= Just GmException
-- False
gmLog :: (MonadIO m, GmLog m, GmOut m) => GmLogLevel -> String -> Doc -> m ()
gmLog level loc' doc = do
GhcModLog { gmLogLevel = Just level' } <- gmlHistory
let loc | loc' == "" = empty
| otherwise = text loc' <+>: empty
msgDoc = sep [loc, doc]
msg = dropWhileEnd isSpace $ render $ gmLogLevelDoc level <+>: msgDoc
when (level <= level') $ gmErrStrLn msg
gmLogQuiet level loc' doc
gmLogQuiet :: GmLog m => GmLogLevel -> String -> Doc -> m ()
gmLogQuiet level loc doc =
gmlJournal (GhcModLog Nothing (Last Nothing) [(level, loc, doc)])
gmAppendLogQuiet :: GmLog m => GhcModLog -> m ()
gmAppendLogQuiet GhcModLog { gmLogMessages } =
forM_ gmLogMessages $ \(level, loc, doc) -> gmLogQuiet level loc doc
gmVomit :: (MonadIO m, GmLog m, GmOut m, GmEnv m) => String -> Doc -> String -> m ()
gmVomit filename doc content = do
gmLog GmVomit "" $ doc <+>: text content
GhcModLog { gmLogVomitDump = Last mdump }
<- gmlHistory
dir <- cradleTempDir `liftM` cradle
when (fromMaybe False mdump) $
liftIO $ writeFile (dir </> filename) content
newtype LogDiscardT m a = LogDiscardT { runLogDiscard :: m a }
deriving (Functor, Applicative, Monad)
instance MonadTrans LogDiscardT where
lift = LogDiscardT
instance Monad m => GmLog (LogDiscardT m) where
gmlJournal = const $ return ()
gmlHistory = return mempty
gmlClear = return ()

148
core/Language/Haskell/GhcMod/Monad.hs Normal file
View File

@@ -0,0 +1,148 @@
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE CPP #-}
module Language.Haskell.GhcMod.Monad (
runGmOutT
, runGmOutT'
, runGhcModT
, runGhcModT'
, hoistGhcModT
, runGmlT
, runGmlT'
, runGmlTWith
, runGmPkgGhc
, withGhcModEnv
, withGhcModEnv'
, module Language.Haskell.GhcMod.Monad.Types
) where
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Error
import Language.Haskell.GhcMod.Logging
import Language.Haskell.GhcMod.Cradle
import Language.Haskell.GhcMod.Target
import Language.Haskell.GhcMod.Output
import Control.Arrow (first)
import Control.Applicative
import Control.Concurrent
import Control.Monad.Reader (runReaderT)
import Control.Monad.State.Strict (runStateT)
import Control.Monad.Trans.Journal (runJournalT)
import Exception
import System.Directory
import System.IO.Unsafe
import Prelude
withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a
withGhcModEnv dir opts f = withGhcModEnv' withCradle dir opts f
where
withCradle dir' =
gbracket
(runJournalT $ do
gmSetLogLevel $ ooptLogLevel $ optOutput opts
findCradle' (optPrograms opts) dir')
(liftIO . cleanupCradle . fst)
cwdLock :: MVar ThreadId
cwdLock = unsafePerformIO $ newEmptyMVar
{-# NOINLINE cwdLock #-}
withGhcModEnv' :: (IOish m, GmOut m) => (FilePath -> ((Cradle, GhcModLog) -> m a) -> m a) -> FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a
withGhcModEnv' withCradle dir opts f =
withCradle dir $ \(crdl,lg) ->
withCradleRootDir crdl $
f (GhcModEnv opts crdl, lg)
where
swapCurrentDirectory ndir = do
odir <- canonicalizePath =<< getCurrentDirectory
setCurrentDirectory ndir
return odir
withCradleRootDir (cradleRootDir -> projdir) a = do
success <- liftIO $ tryPutMVar cwdLock =<< myThreadId
if not success
then error "withGhcModEnv': using ghc-mod from multiple threads is not supported!"
else gbracket setup teardown (const a)
where
setup = liftIO $ swapCurrentDirectory projdir
teardown odir = liftIO $ do
setCurrentDirectory odir
void $ takeMVar cwdLock
runGmOutT :: IOish m => Options -> GmOutT m a -> m a
runGmOutT opts ma = do
gmo@GhcModOut{..} <- GhcModOut (optOutput opts) <$> liftIO newChan
let action = runGmOutT' gmo ma
case ooptLinePrefix $ optOutput opts of
Nothing -> action
Just pfxs ->
gbracket_ (liftIO $ forkIO $ stdoutGateway pfxs gmoChan)
(const $ liftIO $ flushStdoutGateway gmoChan)
action
runGmOutT' :: GhcModOut -> GmOutT m a -> m a
runGmOutT' gmo ma = flip runReaderT gmo $ unGmOutT ma
-- | Run a @GhcModT m@ computation.
runGhcModT :: IOish m
=> Options
-> GhcModT m a
-> m (Either GhcModError a, GhcModLog)
runGhcModT opt action = liftIO (getCurrentDirectory >>= canonicalizePath) >>= \dir' -> do
runGmOutT opt $
withGhcModEnv dir' opt $ \(env,lg) ->
first (fst <$>) <$> runGhcModT' env defaultGhcModState (do
gmSetLogLevel (ooptLogLevel $ optOutput opt)
gmAppendLogQuiet lg
action)
-- | @hoistGhcModT result@. Embed a GhcModT computation's result into a GhcModT
-- computation. Note that if the computation that returned @result@ modified the
-- state part of GhcModT this cannot be restored.
hoistGhcModT :: IOish m
=> (Either GhcModError a, GhcModLog)
-> GhcModT m a
hoistGhcModT (r,l) = do
gmlJournal l >> case r of
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'.
--
-- You should probably look at 'runGhcModT' instead.
runGhcModT' :: IOish m
=> GhcModEnv
-> GhcModState
-> GhcModT m a
-> GmOutT m (Either GhcModError (a, GhcModState), GhcModLog)
runGhcModT' r s a = do
flip runReaderT r $ runJournalT $ runErrorT $ runStateT (unGmT a) s
gbracket_ :: ExceptionMonad m => m a -> (a -> m b) -> m c -> m c
gbracket_ ma mb mc = gbracket ma mb (const mc)

28
core/Language/Haskell/GhcMod/Monad/Compat.hs_h Normal file
View File

@@ -0,0 +1,28 @@
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015,2016 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
-- MonadUtils of GHC 7.6 or earlier defines its own MonadIO.
-- RWST does not automatically become an instance of MonadIO.
-- MonadUtils of GHC 7.8 or later imports MonadIO in Monad.Control.IO.Class.
-- So, RWST automatically becomes an instance of
#if __GLASGOW_HASKELL__ < 708
-- 'CoreMonad.MonadIO' and 'Control.Monad.IO.Class.MonadIO' are different
-- classes before ghc 7.8
#define DIFFERENT_MONADIO 1
-- RWST doen't have a MonadIO instance before ghc 7.8
#define MONADIO_INSTANCES 1
#endif

68
core/Language/Haskell/GhcMod/Monad/Env.hs Normal file
View File

@@ -0,0 +1,68 @@
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015,2016 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
module Language.Haskell.GhcMod.Monad.Env where
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad.Newtypes
import Control.Monad
import Control.Monad.Trans.Journal (JournalT)
import Control.Monad.State.Strict (StateT(..))
import Control.Monad.Error (ErrorT(..))
import Control.Monad.Reader.Class
import Control.Monad.Trans.Class (MonadTrans(..))
import Prelude
class Monad m => GmEnv m where
gmeAsk :: m GhcModEnv
gmeAsk = gmeReader id
gmeReader :: (GhcModEnv -> a) -> m a
gmeReader f = f `liftM` gmeAsk
gmeLocal :: (GhcModEnv -> GhcModEnv) -> m a -> m a
{-# MINIMAL (gmeAsk | gmeReader), gmeLocal #-}
instance Monad m => GmEnv (GmT m) where
gmeAsk = GmT ask
gmeReader = GmT . reader
gmeLocal f a = GmT $ local f (unGmT 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 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))
deriving instance (Monad m, GmEnv (GhcModT m)) => GmEnv (GmlT m)

71
core/Language/Haskell/GhcMod/Monad/Log.hs Normal file
View File

@@ -0,0 +1,71 @@
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015,2016 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
module Language.Haskell.GhcMod.Monad.Log where
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad.Newtypes
import Control.Monad
import Control.Monad.Trans.Journal (JournalT)
import Control.Monad.Reader (ReaderT(..))
import Control.Monad.State.Strict (StateT(..))
import Control.Monad.Error (Error, ErrorT(..))
import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Journal.Class (MonadJournal(..))
import Control.Monad.Trans.Class (MonadTrans(..))
import Prelude
class Monad m => GmLog m where
gmlJournal :: GhcModLog -> m ()
gmlHistory :: m GhcModLog
gmlClear :: m ()
instance Monad m => GmLog (JournalT GhcModLog m) where
gmlJournal = journal
gmlHistory = history
gmlClear = 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
gmlHistory = lift gmlHistory
gmlClear = lift gmlClear
instance (Monad m, GmLog m) => GmLog (StateT s m) where
gmlJournal = lift . gmlJournal
gmlHistory = lift gmlHistory
gmlClear = lift gmlClear
instance (Monad m, GmLog m, Error e) => GmLog (ErrorT e m) where
gmlJournal = lift . gmlJournal
gmlHistory = lift gmlHistory
gmlClear = lift gmlClear
instance (Monad m, GmLog m) => GmLog (MaybeT m) where
gmlJournal = lift . gmlJournal
gmlHistory = lift gmlHistory
gmlClear = lift gmlClear
deriving instance GmLog m => GmLog (GmOutT m)
deriving instance (Monad m, GmLog (GhcModT m)) => GmLog (GmlT m)

176
core/Language/Haskell/GhcMod/Monad/Newtypes.hs Normal file
View File

@@ -0,0 +1,176 @@
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015,2016 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, DeriveFunctor #-}
{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-}
{-# LANGUAGE RankNTypes, FlexibleInstances #-}
module Language.Haskell.GhcMod.Monad.Newtypes where
#include "Compat.hs_h"
import Language.Haskell.GhcMod.Types
import GHC
import Control.Applicative
import Control.Monad
import Control.Monad.Reader (ReaderT(..))
import Control.Monad.Error (ErrorT(..), MonadError(..))
import Control.Monad.State.Strict (StateT(..))
import Control.Monad.Trans.Journal (JournalT)
import Control.Monad.Reader.Class
import Control.Monad.State.Class (MonadState(..))
import Control.Monad.Journal.Class (MonadJournal(..))
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Control
import Control.Monad.Base (MonadBase(..), liftBase)
import Data.IORef
import Prelude
type GhcModT m = GmT (GmOutT m)
newtype GmOutT m a = GmOutT {
unGmOutT :: ReaderT GhcModOut m a
} deriving ( Functor
, Applicative
, Alternative
, Monad
, MonadPlus
, MonadTrans
)
newtype GmT m a = GmT {
unGmT :: StateT GhcModState
(ErrorT GhcModError
(JournalT GhcModLog
(ReaderT GhcModEnv m) ) ) a
} deriving ( Functor
, Applicative
, Alternative
, Monad
, MonadPlus
, MonadError GhcModError
)
newtype GmlT m a = GmlT { unGmlT :: GhcModT m a }
deriving ( Functor
, Applicative
, Alternative
, Monad
, MonadPlus
, MonadError GhcModError
)
newtype LightGhc a = LightGhc { unLightGhc :: ReaderT (IORef HscEnv) IO a }
deriving ( Functor
, Applicative
, Monad
)
-- 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 (GmT m) a
liftBaseWith = defaultLiftBaseWith
restoreM = defaultRestoreM
{-# INLINE liftBaseWith #-}
{-# INLINE restoreM #-}
instance MonadTransControl GmlT where
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 MonadTrans GmlT where
lift = GmlT . lift . lift
-- GmT ------------------------------------------
instance MonadReader r m => MonadReader r (GmT m) where
local f ma = gmLiftWithInner (\run -> local f (run ma))
ask = gmLiftInner ask
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
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 (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 = GmT (liftBaseWith $ \runInBase ->
f $ runInBase . unGmT)
restoreM = GmT . restoreM
{-# INLINE liftBaseWith #-}
{-# INLINE restoreM #-}
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 $ unGmT ma
restoreT = GmT . restoreT . restoreT . restoreT . restoreT
{-# INLINE liftWith #-}
{-# INLINE restoreT #-}
instance MonadTrans GmT where
lift = GmT . 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

83
core/Language/Haskell/GhcMod/Monad/Orphans.hs Normal file
View File

@@ -0,0 +1,83 @@
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015,2016 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE CPP, UndecidableInstances, StandaloneDeriving #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Haskell.GhcMod.Monad.Orphans where
#include "Compat.hs_h"
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad.Newtypes
#if DIFFERENT_MONADIO
import qualified MonadUtils as GHC (MonadIO(..))
#endif
import qualified Control.Monad.IO.Class as MTL
import Control.Monad.Reader (ReaderT(..))
import Control.Monad.State.Strict (StateT(..))
import Control.Monad.Trans.Journal (JournalT)
import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Error (Error(..), ErrorT(..))
--------------------------------------------------
-- Miscellaneous instances
#if DIFFERENT_MONADIO
instance MTL.MonadIO m => GHC.MonadIO (ReaderT x m) where
liftIO = MTL.liftIO
instance MTL.MonadIO m => GHC.MonadIO (StateT x m) where
liftIO = MTL.liftIO
instance (Error e, MTL.MonadIO m) => GHC.MonadIO (ErrorT e m) where
liftIO = MTL.liftIO
instance MTL.MonadIO m => GHC.MonadIO (JournalT x m) where
liftIO = MTL.liftIO
instance MTL.MonadIO m => GHC.MonadIO (MaybeT m) where
liftIO = MTL.liftIO
deriving instance MTL.MonadIO m => GHC.MonadIO (GmOutT m)
deriving instance MTL.MonadIO m => GHC.MonadIO (GmT m)
deriving instance MTL.MonadIO m => GHC.MonadIO (GmlT m)
deriving instance GHC.MonadIO LightGhc
#endif
deriving instance MTL.MonadIO m => MTL.MonadIO (GmOutT m)
deriving instance MTL.MonadIO m => MTL.MonadIO (GmT m)
deriving instance MTL.MonadIO m => MTL.MonadIO (GmlT m)
deriving instance MTL.MonadIO LightGhc
instance MonadIO IO where
liftIO = id
instance MonadIO m => MonadIO (ReaderT x m) where
liftIO = MTL.liftIO
instance MonadIO m => MonadIO (StateT x m) where
liftIO = MTL.liftIO
instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where
liftIO = MTL.liftIO
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 (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

52
core/Language/Haskell/GhcMod/Monad/Out.hs Normal file
View File

@@ -0,0 +1,52 @@
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015,2016 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}
module Language.Haskell.GhcMod.Monad.Out where
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad.Newtypes
import Control.Monad
import Control.Monad.State.Strict (StateT(..))
import Control.Monad.Trans.Journal (JournalT)
import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Reader.Class
import Control.Monad.Trans.Class (MonadTrans(..))
import Prelude
class Monad m => GmOut m where
gmoAsk :: m GhcModOut
instance Monad m => GmOut (GmOutT m) where
gmoAsk = GmOutT ask
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 GmOut m => GmOut (JournalT w m) where
gmoAsk = lift gmoAsk
instance GmOut m => GmOut (MaybeT m) where
gmoAsk = lift gmoAsk

67
core/Language/Haskell/GhcMod/Monad/State.hs Normal file
View File

@@ -0,0 +1,67 @@
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015,2016 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
module Language.Haskell.GhcMod.Monad.State where
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad.Newtypes
import Control.Monad
import Control.Monad.State.Strict (StateT(..))
import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.State.Class (MonadState(..))
import Control.Monad.Trans.Class (MonadTrans(..))
import Prelude
class Monad m => GmState m where
gmsGet :: m GhcModState
gmsGet = gmsState (\s -> (s, s))
gmsPut :: GhcModState -> m ()
gmsPut s = gmsState (\_ -> ((), s))
gmsState :: (GhcModState -> (a, GhcModState)) -> m a
gmsState f = do
s <- gmsGet
let ~(a, s') = f s
gmsPut s'
return a
{-# MINIMAL gmsState | gmsGet, gmsPut #-}
instance GmState m => GmState (StateT s m) where
gmsGet = lift gmsGet
gmsPut = lift . gmsPut
gmsState = lift . gmsState
instance Monad m => GmState (StateT GhcModState m) where
gmsGet = get
gmsPut = put
gmsState = 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
deriving instance (Monad m, GmState (GhcModT m)) => GmState (GmlT m)

239
core/Language/Haskell/GhcMod/Monad/Types.hs Normal file
View File

@@ -0,0 +1,239 @@
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-}
{-# LANGUAGE TypeFamilies, UndecidableInstances, BangPatterns #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Haskell.GhcMod.Monad.Types (
-- * Monad Types
GhcModT
, GmOutT(..)
, GmT(..)
, GmlT(..)
, LightGhc(..)
, GmGhc
, IOish
-- * Environment, state and logging
, GhcModEnv(..)
, GhcModState(..)
, GhcModCaches(..)
, defaultGhcModState
, GmGhcSession(..)
, GmComponent(..)
-- * Accessing 'GhcModEnv', 'GhcModState' and 'GhcModLog'
, GmLogLevel(..)
, GhcModLog(..)
, GhcModError(..)
, Gm
, GmEnv(..)
, GmState(..)
, GmLog(..)
, GmOut(..)
, cradle
, options
, outputOpts
, withOptions
, getMMappedFiles
, setMMappedFiles
, addMMappedFile
, delMMappedFile
, lookupMMappedFile
, getMMappedFilePaths
-- * Re-exporting convenient stuff
, MonadIO
, liftIO
, gmlGetSession
, gmlSetSession
) where
#include "Compat.hs_h"
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad.Env
import Language.Haskell.GhcMod.Monad.State
import Language.Haskell.GhcMod.Monad.Log
import Language.Haskell.GhcMod.Monad.Out
import Language.Haskell.GhcMod.Monad.Newtypes
import Language.Haskell.GhcMod.Monad.Orphans ()
import Safe
import GHC
import DynFlags
import Exception
import HscTypes
import Control.Applicative
import Control.Monad
import Control.Monad.Reader (ReaderT(..))
import Control.Monad.State.Strict (StateT(..))
import Control.Monad.Trans.Journal (JournalT)
import Control.Monad.Trans.Maybe (MaybeT)
import Control.Monad.Trans.Control
import Control.Monad.Reader.Class
import qualified Data.Map as M
import Data.Maybe
import Data.Monoid
import Data.IORef
import Prelude
type Gm m = (GmEnv m, GmState m, GmLog m, GmOut m)
--------------------------------------------------
-- 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
-- together and counting repetitions) than the head. Specifically the
-- @MonadBaseControl IO m@ constraint in 'IOish' is causing this violation.
type GmGhc m = (IOish m, GhcMonad m)
instance (MonadIO m, MonadBaseControl IO m) => GhcMonad (GmlT m) where
getSession = gmlGetSession
setSession = gmlSetSession
-- | Get the underlying GHC session
gmlGetSession :: (MonadIO m, MonadBaseControl IO m) => GmlT m HscEnv
gmlGetSession = do
ref <- gmgsSession . fromJustNote "gmlGetSession" . gmGhcSession <$> gmsGet
liftIO $ readIORef ref
-- | Set the underlying GHC session
gmlSetSession :: (MonadIO m, MonadBaseControl IO m) => HscEnv -> GmlT m ()
gmlSetSession a = do
ref <- gmgsSession . fromJustNote "gmlSetSession" . gmGhcSession <$> gmsGet
liftIO $ flip writeIORef a ref
instance GhcMonad LightGhc where
getSession = (liftIO . readIORef) =<< LightGhc ask
setSession a = (liftIO . flip writeIORef a) =<< LightGhc ask
#if __GLASGOW_HASKELL__ >= 706
instance (MonadIO m, MonadBaseControl IO m) => HasDynFlags (GmlT m) where
getDynFlags = hsc_dflags <$> getSession
instance HasDynFlags LightGhc where
getDynFlags = hsc_dflags <$> getSession
#endif
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)
gmask = liftBaseOp gmask . liftRestore
where liftRestore f r = f $ liftBaseOp_ r
instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (GmlT m) where
gcatch act handler = control $ \run ->
run act `gcatch` (run . handler)
gmask = liftBaseOp gmask . liftRestore
where liftRestore f r = f $ liftBaseOp_ r
instance ExceptionMonad LightGhc where
gcatch act handl =
LightGhc $ unLightGhc act `gcatch` \e -> unLightGhc (handl e)
gmask f =
LightGhc $ gmask $ \io_restore ->let
g_restore (LightGhc m) = LightGhc $ io_restore m
in
unLightGhc (f g_restore)
instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (StateT s 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 (ReaderT s m) where
gcatch act handler = control $ \run ->
run act `gcatch` (run . handler)
gmask = liftBaseOp gmask . liftRestore
where liftRestore f r = f $ liftBaseOp_ r
instance (Monoid w, MonadIO m, MonadBaseControl IO m) => ExceptionMonad (JournalT w 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 (MaybeT m) where
gcatch act handler = control $ \run ->
run act `gcatch` (run . handler)
gmask = liftBaseOp gmask . liftRestore
where liftRestore f r = f $ liftBaseOp_ r
----------------------------------------------------------------
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
getMMappedFiles :: GmState m => m FileMappingMap
getMMappedFiles = gmMMappedFiles `liftM` gmsGet
setMMappedFiles :: GmState m => FileMappingMap -> m ()
setMMappedFiles mf = (\s -> gmsPut s { gmMMappedFiles = mf } ) =<< gmsGet
addMMappedFile :: GmState m => FilePath -> FileMapping -> m ()
addMMappedFile t fm =
getMMappedFiles >>= setMMappedFiles . M.insert t fm
delMMappedFile :: GmState m => FilePath -> m ()
delMMappedFile t =
getMMappedFiles >>= setMMappedFiles . M.delete t
lookupMMappedFile :: GmState m => FilePath -> m (Maybe FileMapping)
lookupMMappedFile t =
M.lookup t `liftM` getMMappedFiles
getMMappedFilePaths :: GmState m => m [FilePath]
getMMappedFilePaths = M.keys `liftM` getMMappedFiles
withOptions :: GmEnv m => (Options -> Options) -> m a -> m a
withOptions changeOpt action = gmeLocal changeEnv action
where
changeEnv e = e { gmOptions = changeOpt opt }
where
opt = gmOptions e

48
core/Language/Haskell/GhcMod/Options/DocUtils.hs Normal file
View File

@@ -0,0 +1,48 @@
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015 Nikolay Yakimov <root@livid.pp.ru>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
module Language.Haskell.GhcMod.Options.DocUtils (
($$),
($$$),
(<=>),
(<$$>),
(<||>)
) where
import Options.Applicative
import Data.Monoid
import Prelude
infixl 6 <||>
infixr 7 <$$>
infixr 7 $$
infixr 8 <=>
infixr 9 $$$
($$) :: (a -> b) -> a -> b
($$) = ($)
($$$) :: (a -> b) -> a -> b
($$$) = ($)
(<||>) :: Alternative a => a b -> a b -> a b
(<||>) = (<|>)
(<=>) :: Monoid m => m -> m -> m
(<=>) = (<>)
(<$$>) :: Functor f => (a -> b) -> f a -> f b
(<$$>) = (<$>)

79
core/Language/Haskell/GhcMod/Options/Help.hs Normal file
View File

@@ -0,0 +1,79 @@
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015 Nikolay Yakimov <root@livid.pp.ru>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE OverloadedStrings, FlexibleInstances, GeneralizedNewtypeDeriving #-}
module Language.Haskell.GhcMod.Options.Help where
import Options.Applicative
import Options.Applicative.Help.Pretty (Doc)
import qualified Options.Applicative.Help.Pretty as PP
import Control.Monad.State
import GHC.Exts( IsString(..) )
import Data.Maybe
import Data.Monoid
import Prelude
newtype MyDocM s a = MyDoc {unwrapState :: State s a}
deriving (Monad, Functor, Applicative, MonadState s)
type MyDoc = MyDocM (Maybe Doc) ()
instance IsString (MyDocM (Maybe Doc) a) where
fromString = append . para
instance Monoid (MyDocM (Maybe Doc) ()) where
mappend a b = append $ doc a <> doc b
mempty = append PP.empty
para :: String -> Doc
para = PP.fillSep . map PP.text . words
append :: Doc -> MyDocM (Maybe Doc) a
append s = modify m >> return undefined
where
m :: Maybe Doc -> Maybe Doc
m Nothing = Just s
m (Just old) = Just $ old PP..$. s
infixr 7 \\
(\\) :: MyDoc -> MyDoc -> MyDoc
(\\) a b = append $ doc a PP.<+> doc b
doc :: MyDoc -> Doc
doc = fromMaybe PP.empty . flip execState Nothing . unwrapState
help' :: MyDoc -> Mod f a
help' = helpDoc . Just . doc
desc :: MyDoc -> InfoMod a
desc = footerDoc . Just . doc . indent 2
code :: MyDoc -> MyDoc
code x = do
_ <- " "
indent 4 x
" "
progDesc' :: MyDoc -> InfoMod a
progDesc' = progDescDoc . Just . doc
indent :: Int -> MyDoc -> MyDoc
indent n = append . PP.indent n . doc
int' :: Int -> MyDoc
int' = append . PP.int
para' :: String -> MyDoc
para' = append . para

177
core/Language/Haskell/GhcMod/Options/Options.hs Normal file
View File

@@ -0,0 +1,177 @@
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015 Nikolay Yakimov <root@livid.pp.ru>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
module Language.Haskell.GhcMod.Options.Options (
globalArgSpec
, parseCmdLineOptions
) where
import Options.Applicative
import Options.Applicative.Types
import Language.Haskell.GhcMod.Types
import Control.Arrow
import Data.Char (toUpper, toLower)
import Data.List (intercalate)
import Language.Haskell.GhcMod.Read
import Language.Haskell.GhcMod.Options.DocUtils
import Language.Haskell.GhcMod.Options.Help
import Data.Monoid
import Prelude
-- | Parse a set of arguments according to the ghc-mod CLI flag spec, producing
-- @Options@ set accordingly.
parseCmdLineOptions :: [String] -> Maybe Options
parseCmdLineOptions = getParseResult . execParserPure (prefs mempty) (info globalArgSpec mempty)
splitOn :: Eq a => a -> [a] -> ([a], [a])
splitOn c = second (drop 1) . break (==c)
logLevelParser :: Parser GmLogLevel
logLevelParser =
logLevelSwitch <*>
logLevelOption
<||> silentSwitch
where
logLevelOption =
option parseLL
$$ long "verbose"
<=> metavar "LEVEL"
<=> value GmWarning
<=> showDefaultWith showLL
<=> help' $$$ do
"Set log level ("
<> int' (fromEnum (minBound :: GmLogLevel))
<> "-"
<> int' (fromEnum (maxBound :: GmLogLevel))
<> ")"
"You can also use strings (case-insensitive):"
para'
$ intercalate ", "
$ map showLL ([minBound..maxBound] :: [GmLogLevel])
logLevelSwitch =
repeatAp succ' . length <$> many $$ flag' ()
$$ short 'v'
<=> help "Increase log level"
silentSwitch = flag' GmSilent
$$ long "silent"
<=> short 's'
<=> help "Be silent, set log level to 'silent'"
showLL = drop 2 . map toLower . show
repeatAp f n = foldr (.) id (replicate n f)
succ' x | x == maxBound = x
| otherwise = succ x
parseLL = do
v <- readerAsk
let
il'= toEnum . min maxBound <$> readMaybe v
ll' = readMaybe ("Gm" ++ capFirst v)
maybe (readerError $ "Not a log level \"" ++ v ++ "\"") return $ ll' <|> il'
capFirst (h:t) = toUpper h : map toLower t
capFirst [] = []
outputOptsSpec :: Parser OutputOpts
outputOptsSpec = OutputOpts
<$> logLevelParser
<*> flag PlainStyle LispStyle
$$ long "tolisp"
<=> short 'l'
<=> help "Format output as an S-Expression"
<*> LineSeparator <$$> strOption
$$ long "boundary"
<=> long "line-separator"
<=> short 'b'
<=> metavar "SEP"
<=> value "\0"
<=> showDefault
<=> help "Output line separator"
<*> optional $$ splitOn ',' <$$> strOption
$$ long "line-prefix"
<=> metavar "OUT,ERR"
<=> help "Output prefixes"
programsArgSpec :: Parser Programs
programsArgSpec = Programs
<$> strOption
$$ long "with-ghc"
<=> value "ghc"
<=> showDefault
<=> help "GHC executable to use"
<*> strOption
$$ long "with-ghc-pkg"
<=> value "ghc-pkg"
<=> showDefault
<=> help "ghc-pkg executable to use (only needed when guessing from GHC path fails)"
<*> strOption
$$ long "with-cabal"
<=> value "cabal"
<=> showDefault
<=> help "cabal-install executable to use"
<*> strOption
$$ long "with-stack"
<=> value "stack"
<=> showDefault
<=> help "stack executable to use"
-- | An optparse-applicative @Parser@ sepcification for @Options@ so that
-- applications making use of the ghc-mod API can have a consistent way of
-- parsing global options.
globalArgSpec :: Parser Options
globalArgSpec = Options
<$> outputOptsSpec
<*> programsArgSpec
<*> many $$ strOption
$$ long "ghcOpt"
<=> long "ghc-option"
<=> short 'g'
<=> metavar "OPT"
<=> help "Option to be passed to GHC"
<*> many fileMappingSpec
<*> strOption
$$ long "encoding"
<=> value "UTF-8"
<=> showDefault
<=> help "I/O encoding"
<*> switch
$$ long "stack-build-deps"
<=> showDefault
<=> help "Build dependencies if needed when using stack"
where
fileMappingSpec =
getFileMapping . splitOn '=' <$> strOption
$$ long "map-file"
<=> metavar "MAPPING"
<=> fileMappingHelp
fileMappingHelp = help' $ do
"Redirect one file to another"
"--map-file \"file1.hs=file2.hs\""
indent 4 $ do
"can be used to tell ghc-mod"
\\ "that it should take source code"
\\ "for `file1.hs` from `file2.hs`."
"`file1.hs` can be either full path,"
\\ "or path relative to project root."
"`file2.hs` has to be either relative to project root,"
\\ "or full path (preferred)"
"--map-file \"file.hs\""
indent 4 $ do
"can be used to tell ghc-mod that it should take"
\\ "source code for `file.hs` from stdin. File end"
\\ "marker is `\\n\\EOT\\n`, i.e. `\\x0A\\x04\\x0A`."
\\ "`file.hs` may or may not exist, and should be"
\\ "either full path, or relative to project root."
getFileMapping = second (\i -> if null i then Nothing else Just i)

243
core/Language/Haskell/GhcMod/Output.hs Normal file
View File

@@ -0,0 +1,243 @@
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
-- Derived from process:System.Process
-- Copyright (c) The University of Glasgow 2004-2008
{-# LANGUAGE FlexibleInstances #-}
module Language.Haskell.GhcMod.Output (
gmPutStr
, gmErrStr
, gmPutStrLn
, gmErrStrLn
, gmPutStrIO
, gmErrStrIO
, gmReadProcess
, gmReadProcess'
, stdoutGateway
, flushStdoutGateway
) where
import Data.List
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as BS
import qualified Data.Label as L
import qualified Data.Label.Base as LB
import System.IO
import System.Exit
import System.Process
import Control.Monad
import Control.Monad.State.Strict
import Control.DeepSeq
import Control.Exception
import Control.Concurrent (forkIO, killThread)
import Control.Concurrent.MVar
import Control.Concurrent.Chan
import Pipes
import Pipes.Lift
import Prelude
import Language.Haskell.GhcMod.Types hiding (LineSeparator, MonadIO(..))
import Language.Haskell.GhcMod.Monad.Types hiding (MonadIO(..))
import Language.Haskell.GhcMod.Gap ()
class ProcessOutput a where
hGetContents' :: Handle -> IO a
instance ProcessOutput String where
hGetContents' = hGetContents
instance ProcessOutput ByteString where
hGetContents' = BS.hGetContents
outputFns :: (GmOut m, MonadIO m')
=> m (String -> m' (), String -> m' ())
outputFns =
outputFns' `liftM` gmoAsk
outputFns' ::
MonadIO m => GhcModOut -> (String -> m (), String -> m ())
outputFns' (GhcModOut oopts c) = let
OutputOpts {..} = oopts
in
case ooptLinePrefix of
Nothing -> stdioOutputFns
Just _ -> chanOutputFns c
stdioOutputFns :: MonadIO m => (String -> m (), String -> m ())
stdioOutputFns =
( liftIO . putStr
, liftIO . hPutStr stderr
)
chanOutputFns :: MonadIO m
=> Chan (Either (MVar ()) (GmStream, String))
-> (String -> m (), String -> m ())
chanOutputFns c = (write GmOutStream, write GmErrStream)
where
write stream s = liftIO $ writeChan c $ Right $ (stream,s)
gmPutStr, gmPutStrLn, gmErrStr, gmErrStrLn
:: (MonadIO m, GmOut m) => String -> m ()
gmPutStr str = do
putOut <- gmPutStrIO
putOut str
gmErrStr str = do
putErr <- gmErrStrIO
putErr str
gmPutStrLn = gmPutStr . (++"\n")
gmErrStrLn = gmErrStr . (++"\n")
gmPutStrIO, gmErrStrIO :: (GmOut m, MonadIO mi) => m (String -> mi ())
gmPutStrIO = fst `liftM` outputFns
gmErrStrIO = snd `liftM` outputFns
gmReadProcess :: GmOut m => m (FilePath -> [String] -> String -> IO String)
gmReadProcess = do
GhcModOut {..} <- gmoAsk
case ooptLinePrefix gmoOptions of
Just _ ->
readProcessStderrChan
Nothing ->
return $ readProcess
gmReadProcess' :: GmOut m => m (FilePath -> [String] -> String -> IO ByteString)
gmReadProcess' = readProcessStderrChan
flushStdoutGateway :: Chan (Either (MVar ()) (GmStream, String)) -> IO ()
flushStdoutGateway c = do
mv <- newEmptyMVar
writeChan c $ Left mv
takeMVar mv
type Line = String
stdoutGateway :: (String, String) -> Chan (Either (MVar ()) (GmStream, String)) -> IO ()
stdoutGateway (outPf, errPf) chan = do
runEffect $ commandProc >-> evalStateP ("","") seperateStreams
where
commandProc :: Producer (Either (MVar ()) (GmStream, String)) IO ()
commandProc = do
cmd <- liftIO $ readChan chan
case cmd of
Left mv -> do
yield $ Left mv
Right input -> do
yield $ Right input
commandProc
seperateStreams :: Consumer (Either (MVar ()) (GmStream, String)) (StateT (String, String) IO) ()
seperateStreams = do
ecmd <- await
case ecmd of
Left mv -> do
-- flush buffers
(\s -> lift $ zoom (streamLens s) $ sGetLine Nothing)
`mapM_` [GmOutStream, GmErrStream]
liftIO $ putMVar mv ()
Right (stream, str) -> do
ls <- lift $ zoom (streamLens stream) $ sGetLine (Just str)
case ls of
[] -> return ()
_ -> liftIO $ putStr $ unlines $ map (streamPf stream++) ls
liftIO $ hFlush stdout
seperateStreams
sGetLine :: (Maybe String) -> StateT String IO [Line]
sGetLine mstr' = do
buf <- get
let mstr = (buf++) `liftM` mstr'
case mstr of
Nothing -> put "" >> return [buf]
Just "" -> return []
Just s | last s == '\n' -> put "" >> return (lines s)
| otherwise -> do
let (p:ls') = reverse $ lines s
put p
return $ reverse $ ls'
streamLens GmOutStream = LB.fst
streamLens GmErrStream = LB.snd
streamPf GmOutStream = outPf
streamPf GmErrStream = errPf
zoom :: Monad m => (f L.:-> o) -> StateT o m a -> StateT f m a
zoom l (StateT a) =
StateT $ \f -> do
(a', s') <- a $ L.get l f
return (a', L.set l s' f)
readProcessStderrChan ::
(GmOut m, ProcessOutput a, NFData a) => m (FilePath -> [String] -> String -> IO a)
readProcessStderrChan = do
(_, e :: String -> IO ()) <- outputFns
return $ readProcessStderrChan' e
readProcessStderrChan' :: (ProcessOutput a, NFData a) =>
(String -> IO ()) -> FilePath -> [String] -> String -> IO a
readProcessStderrChan' putErr exe args input = do
let cp = (proc exe args) {
std_out = CreatePipe
, std_err = CreatePipe
, std_in = CreatePipe
}
(Just i, Just o, Just e, h) <- createProcess cp
_ <- forkIO $ reader e
output <- hGetContents' o
withForkWait (evaluate $ rnf output) $ \waitOut -> do
-- now write any input
unless (null input) $
ignoreSEx $ hPutStr i input
-- hClose performs implicit hFlush, and thus may trigger a SIGPIPE
ignoreSEx $ hClose i
-- wait on the output
waitOut
hClose o
res <- waitForProcess h
case res of
ExitFailure rv ->
throw $ GMEProcess "readProcessStderrChan" exe args $ Left rv
ExitSuccess ->
return output
where
ignoreSEx = handle (\(SomeException _) -> return ())
reader h = ignoreSEx $ do
putErr . (++"\n") =<< hGetLine h
reader h
withForkWait :: IO () -> (IO () -> IO a) -> IO a
withForkWait async body = do
waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))
mask $ \restore -> do
tid <- forkIO $ try (restore async) >>= putMVar waitVar
let wait = takeMVar waitVar >>= either throwIO return
restore (body wait) `onException` killThread tid

242
core/Language/Haskell/GhcMod/PathsAndFiles.hs Normal file
View File

@@ -0,0 +1,242 @@
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
module Language.Haskell.GhcMod.PathsAndFiles (
module Language.Haskell.GhcMod.PathsAndFiles
, module Language.Haskell.GhcMod.Caching
) where
import Config (cProjectVersion)
import Control.Arrow (second)
import Control.Applicative
import Control.Exception as E
import Control.Monad
import Control.Monad.Trans.Maybe
import Data.List
import Data.Char
import Data.Maybe
import Data.Traversable hiding (mapM)
import Distribution.Helper (buildPlatform)
import System.Directory
import System.FilePath
import System.Process
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Caching
import qualified Language.Haskell.GhcMod.Utils as U
import Utils (mightExist)
import Prelude
-- | Guaranteed to be a path to a directory with no trailing slash.
type DirPath = FilePath
-- | Guaranteed to be the name of a file only (no slashes).
type FileName = String
-- | @findCabalFiles dir@. Searches for a @.cabal@ files in @dir@'s parent
-- directories. The first parent directory containing more than one cabal file
-- is assumed to be the project directory. If only one cabal file exists in this
-- directory it is returned otherwise @findCabalFiles@ throws 'GMENoCabalFile'
-- or 'GMETooManyCabalFiles'
findCabalFile :: FilePath -> IO (Maybe FilePath)
findCabalFile dir = findFileInParentsP isCabalFile pick dir
where
pick [] = Nothing
pick [cf] = Just cf
pick cfs = throw $ GMETooManyCabalFiles cfs
findStackConfigFile :: FilePath -> IO (Maybe FilePath)
findStackConfigFile dir =
findFileInParentsP (=="stack.yaml") pick dir
where
pick [] = Nothing
pick (sf:_) = Just sf
findCabalSandboxDir :: FilePath -> IO (Maybe FilePath)
findCabalSandboxDir dir =
fmap takeDirectory <$> findFileInParentsP isSandboxConfig pick dir
where
isSandboxConfig = (==sandboxConfigFileName)
pick [] = Nothing
pick (sc:_) = Just sc
findCustomPackageDbFile :: FilePath -> IO (Maybe FilePath)
findCustomPackageDbFile dir =
mightExist $ dir </> "ghc-mod.package-db-stack"
-- | Get path to sandbox config file
getSandboxDb :: Cradle -> IO (Maybe GhcPkgDb)
getSandboxDb crdl = do
mConf <- traverse readFile =<< mightExist (sandboxConfigFile crdl)
bp <- buildPlatform readProcess
return $ PackageDb . fixPkgDbVer bp <$> (extractSandboxDbDir =<< mConf)
where
fixPkgDbVer bp dir =
case takeFileName dir == ghcSandboxPkgDbDir bp of
True -> dir
False -> takeDirectory dir </> ghcSandboxPkgDbDir bp
-- | Extract the sandbox package db directory from the cabal.sandbox.config
-- file. Exception is thrown if the sandbox config file is broken.
extractSandboxDbDir :: String -> Maybe FilePath
extractSandboxDbDir conf = extractValue <$> parse conf
where
key = "package-db:"
keyLen = length key
parse = listToMaybe . filter (key `isPrefixOf`) . lines
extractValue = U.dropWhileEnd isSpace . dropWhile isSpace . drop keyLen
-- |
-- >>> isCabalFile "/home/user/.cabal"
-- False
isCabalFile :: FilePath -> Bool
isCabalFile f = takeExtension' f == ".cabal"
-- |
-- >>> takeExtension' "/some/dir/bla.cabal"
-- ".cabal"
--
-- >>> takeExtension' "some/reldir/bla.cabal"
-- ".cabal"
--
-- >>> takeExtension' "bla.cabal"
-- ".cabal"
--
-- >>> takeExtension' ".cabal"
-- ""
takeExtension' :: FilePath -> String
takeExtension' p =
if takeFileName p == takeExtension p
then "" -- just ".cabal" is not a valid cabal file
else takeExtension p
-- | @findFileInParentsP p r dir@ Look for files satisfying @p@ in @dir@ and all
-- it's parent directories. Files found to satisfy @p@ in a given directory are
-- passed to @r@ and if this yields a 'Just' value the search finishes early
-- without examinig any more directories and this value is returned.
findFileInParentsP :: (FilePath -> Bool)
-> ([FilePath] -> Maybe a)
-> FilePath
-> IO (Maybe a)
findFileInParentsP p r dir = runMaybeT $
join $ msum <$> map (MaybeT . fmap r) <$> liftIO (findFilesInParentsP p dir)
-- | @findFilesInParentsP p dir@ Look for files satisfying @p@ in @dir@ and all
-- it's parent directories.
findFilesInParentsP :: (FilePath -> Bool) -> FilePath
-> IO [IO [FilePath]]
findFilesInParentsP p dir' = U.makeAbsolute' dir' >>= \dir -> return $
map (\d -> (map (d </>)) <$> getFilesP p d) $ parents dir
-- | @getFilesP p dir@. Find all __files__ satisfying @p@ in @.cabal@ in @dir@.
getFilesP :: (FilePath -> Bool) -> DirPath -> IO [FileName]
getFilesP p dir = filterM p' =<< getDirectoryContentsSafe
where
p' fn = do
(p fn && ) <$> doesFileExist (dir </> fn)
getDirectoryContentsSafe = do
rdable <- readable <$> getPermissions dir
if rdable
then getDirectoryContents dir
else return []
-- | @parents dir@. Returns all parent directories of @dir@ including @dir@.
--
-- Examples
--
-- >>> parents "foo"
-- ["foo"]
--
-- >>> parents "/foo"
-- ["/foo","/"]
--
-- >>> parents "/foo/bar"
-- ["/foo/bar","/foo","/"]
--
-- >>> parents "foo/bar"
-- ["foo/bar","foo"]
parents :: FilePath -> [FilePath]
parents "" = []
parents dir' =
let (drive, dir) = splitDrive $ normalise $ dropTrailingPathSeparator dir'
in map (joinDrive drive) $ parents' $ filter (/=".") $ splitDirectories dir
where
parents' :: [String] -> [FilePath]
parents' [] | isAbsolute dir' = "":[]
parents' [] = []
parents' dir = [joinPath dir] ++ parents' (init dir)
----------------------------------------------------------------
setupConfigFile :: Cradle -> FilePath
setupConfigFile crdl =
cradleRootDir crdl </> setupConfigPath (cradleDistDir crdl)
sandboxConfigFile :: Cradle -> FilePath
sandboxConfigFile crdl = cradleRootDir crdl </> sandboxConfigFileName
sandboxConfigFileName :: String
sandboxConfigFileName = "cabal.sandbox.config"
-- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@
setupConfigPath :: FilePath -> FilePath
setupConfigPath dist = dist </> "setup-config"
-- localBuildInfoFile defaultDistPref
macrosHeaderPath :: FilePath
macrosHeaderPath = autogenModulesDir </> "cabal_macros.h"
autogenModulePath :: String -> String
autogenModulePath pkg_name =
autogenModulesDir </> ("Paths_" ++ map fixchar pkg_name) <.> ".hs"
where fixchar '-' = '_'
fixchar c = c
autogenModulesDir :: FilePath
autogenModulesDir = "build" </> "autogen"
ghcSandboxPkgDbDir :: String -> String
ghcSandboxPkgDbDir buildPlatf = do
buildPlatf ++ "-ghc-" ++ cProjectVersion ++ "-packages.conf.d"
packageCache :: String
packageCache = "package.cache"
-- | Filename of the symbol table cache file.
symbolCache :: Cradle -> FilePath
symbolCache crdl = cradleRootDir crdl </> cradleDistDir crdl </> symbolCacheFile
symbolCacheFile :: String
symbolCacheFile = "ghc-mod.symbol-cache"
resolvedComponentsCacheFile :: FilePath -> FilePath
resolvedComponentsCacheFile dist =
setupConfigPath dist <.> "ghc-mod.resolved-components"
cabalHelperCacheFile :: FilePath -> FilePath
cabalHelperCacheFile dist =
setupConfigPath dist <.> "ghc-mod.cabal-components"
mergedPkgOptsCacheFile :: FilePath -> FilePath
mergedPkgOptsCacheFile dist =
setupConfigPath dist <.> "ghc-mod.package-options"
pkgDbStackCacheFile :: FilePath -> FilePath
pkgDbStackCacheFile dist =
setupConfigPath dist <.> "ghc-mod.package-db-stack"

90
core/Language/Haskell/GhcMod/Pretty.hs Normal file
View File

@@ -0,0 +1,90 @@
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
module Language.Haskell.GhcMod.Pretty
( render
, renderSDoc
, gmComponentNameDoc
, gmLogLevelDoc
, (<+>:)
, fnDoc
, showToDoc
, warnDoc
, strLnDoc
, strDoc
) where
import Control.Arrow hiding ((<+>))
import Data.Char
import Data.List
import Distribution.Helper
import Pretty
import GHC
import Outputable (SDoc, withPprStyleDoc)
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Doc
import Language.Haskell.GhcMod.Gap (render)
renderSDoc :: GhcMonad m => SDoc -> m Doc
renderSDoc sdoc = do
df <- getSessionDynFlags
ppsty <- getStyle
return $ withPprStyleDoc df ppsty sdoc
gmComponentNameDoc :: ChComponentName -> Doc
gmComponentNameDoc ChSetupHsName = text $ "Setup.hs"
gmComponentNameDoc (ChLibName "") = text $ "library"
gmComponentNameDoc (ChLibName n) = text $ "library:" ++ n
gmComponentNameDoc (ChExeName n) = text $ "exe:" ++ n
gmComponentNameDoc (ChTestName n) = text $ "test:" ++ n
gmComponentNameDoc (ChBenchName n) = text $ "bench:" ++ n
gmLogLevelDoc :: GmLogLevel -> Doc
gmLogLevelDoc GmSilent = error "GmSilent MUST not be used for log messages"
gmLogLevelDoc GmPanic = text "PANIC"
gmLogLevelDoc GmException = text "EXCEPTION"
gmLogLevelDoc GmError = text "ERROR"
gmLogLevelDoc GmWarning = text "Warning"
gmLogLevelDoc GmInfo = text "info"
gmLogLevelDoc GmDebug = text "DEBUG"
gmLogLevelDoc GmVomit = text "VOMIT"
infixl 6 <+>:
(<+>:) :: Doc -> Doc -> Doc
a <+>: b = (a <> colon) <+> b
fnDoc :: FilePath -> Doc
fnDoc = doubleQuotes . text
showToDoc :: Show a => a -> Doc
showToDoc = strLnDoc . show
warnDoc :: Doc -> Doc
warnDoc d = text "Warning" <+>: d
strLnDoc :: String -> Doc
strLnDoc str = doc (dropWhileEnd isSpace str)
where
doc = lines >>> map text >>> foldr ($+$) empty
strDoc :: String -> Doc
strDoc str = doc (dropWhileEnd isSpace str)
where
doc :: String -> Doc
doc = lines
>>> map (words >>> map text >>> fsep)
>>> \l -> case l of (x:xs) -> hang x 4 (vcat xs); [] -> empty

106
core/Language/Haskell/GhcMod/Read.hs Normal file
View File

@@ -0,0 +1,106 @@
module Language.Haskell.GhcMod.Read where
import Text.Read (readPrec_to_S, readPrec, minPrec)
import qualified Text.ParserCombinators.ReadP as P
import Text.ParserCombinators.ReadPrec (lift)
-- This library (libraries/base) is derived from code from several
-- sources:
-- * Code from the GHC project which is largely (c) The University of
-- Glasgow, and distributable under a BSD-style license (see below),
-- * Code from the Haskell 98 Report which is (c) Simon Peyton Jones
-- and freely redistributable (but see the full license for
-- restrictions).
-- * Code from the Haskell Foreign Function Interface specification,
-- which is (c) Manuel M. T. Chakravarty and freely redistributable
-- (but see the full license for restrictions).
-- The full text of these licenses is reproduced below. All of the
-- licenses are BSD-style or compatible.
-- -----------------------------------------------------------------------------
-- The Glasgow Haskell Compiler License
-- Copyright 2004, The University Court of the University of Glasgow.
-- All rights reserved.
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are met:
-- - Redistributions of source code must retain the above copyright notice,
-- this list of conditions and the following disclaimer.
-- - Redistributions in binary form must reproduce the above copyright notice,
-- this list of conditions and the following disclaimer in the documentation
-- and/or other materials provided with the distribution.
-- - Neither name of the University nor the names of its contributors may be
-- used to endorse or promote products derived from this software without
-- specific prior written permission.
-- THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
-- GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
-- INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-- FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-- UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-- OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
-- DAMAGE.
-- -----------------------------------------------------------------------------
-- Code derived from the document "Report on the Programming Language
-- Haskell 98", is distributed under the following license:
-- Copyright (c) 2002 Simon Peyton Jones
-- The authors intend this Report to belong to the entire Haskell
-- community, and so we grant permission to copy and distribute it for
-- any purpose, provided that it is reproduced in its entirety,
-- including this Notice. Modified versions of this Report may also be
-- copied and distributed for any purpose, provided that the modified
-- version is clearly presented as such, and that it does not claim to
-- be a definition of the Haskell 98 Language.
-- -----------------------------------------------------------------------------
-- Code derived from the document "The Haskell 98 Foreign Function
-- Interface, An Addendum to the Haskell 98 Report" is distributed under
-- the following license:
-- Copyright (c) 2002 Manuel M. T. Chakravarty
-- The authors intend this Report to belong to the entire Haskell
-- community, and so we grant permission to copy and distribute it for
-- any purpose, provided that it is reproduced in its entirety,
-- including this Notice. Modified versions of this Report may also be
-- copied and distributed for any purpose, provided that the modified
-- version is clearly presented as such, and that it does not claim to
-- be a definition of the Haskell 98 Foreign Function Interface.
-- -----------------------------------------------------------------------------
readEither :: Read a => String -> Either String a
readEither s =
case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of
[x] -> Right x
[] -> Left "Prelude.read: no parse"
_ -> Left "Prelude.read: ambiguous parse"
where
read' =
do x <- readPrec
lift P.skipSpaces
return x
readMaybe :: Read a => String -> Maybe a
readMaybe s = case readEither s of
Left _ -> Nothing
Right a -> Just a

191
core/Language/Haskell/GhcMod/SrcUtils.hs Normal file
View File

@@ -0,0 +1,191 @@
-- TODO: remove CPP once Gap(ed)
{-# LANGUAGE CPP, TupleSections, FlexibleInstances, Rank2Types #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Haskell.GhcMod.SrcUtils where
import Control.Applicative
import CoreUtils (exprType)
import Data.Generics
import Data.Maybe
import Data.Ord as O
import GHC (LHsExpr, LPat, Id, DynFlags, SrcSpan, Type, Located, ParsedSource, RenamedSource, TypecheckedSource, GenLocated(L))
import Var (Var)
import qualified GHC as G
import qualified Var as G
import qualified Type as G
import GHC.SYB.Utils
import GhcMonad
import qualified Language.Haskell.Exts as HE
import Language.Haskell.GhcMod.Doc
import Language.Haskell.GhcMod.Gap
import qualified Language.Haskell.GhcMod.Gap as Gap
import OccName (OccName)
import Outputable (PprStyle)
import TcHsSyn (hsPatType)
import Prelude
import Control.Monad
import Data.List (nub)
import Control.Arrow
import qualified Data.Map as M
----------------------------------------------------------------
instance HasType (LHsExpr Id) where
getType tcm e = do
hs_env <- G.getSession
mbe <- liftIO $ Gap.deSugar tcm e hs_env
return $ (G.getLoc e, ) <$> CoreUtils.exprType <$> mbe
instance HasType (LPat Id) where
getType _ (G.L spn pat) = return $ Just (spn, hsPatType pat)
----------------------------------------------------------------
-- | Stores mapping from monomorphic to polymorphic types
type CstGenQS = M.Map Var Type
-- | Generic type to simplify SYB definition
type CstGenQT a = forall m. GhcMonad m => a Id -> CstGenQS -> (m [(SrcSpan, Type)], CstGenQS)
collectSpansTypes :: (GhcMonad m) => Bool -> G.TypecheckedModule -> (Int, Int) -> m [(SrcSpan, Type)]
collectSpansTypes withConstraints tcs lc =
-- This walks AST top-down, left-to-right, while carrying CstGenQS down the tree
-- (but not left-to-right)
everythingStagedWithContext TypeChecker M.empty (liftM2 (++))
(return [])
((return [],)
`mkQ` (hsBind :: CstGenQT G.LHsBind) -- matches on binds
`extQ` (genericCT :: CstGenQT G.LHsExpr) -- matches on expressions
`extQ` (genericCT :: CstGenQT G.LPat) -- matches on patterns
)
(G.tm_typechecked_source tcs)
where
-- Helper function to insert mapping into CstGenQS
insExp x = M.insert (G.abe_mono x) (G.varType $ G.abe_poly x)
-- If there is AbsBinds here, insert mapping into CstGenQS if needed
hsBind (L _ G.AbsBinds{abs_exports = es'}) s
| withConstraints = (return [], foldr insExp s es')
| otherwise = (return [], s)
#if __GLASGOW_HASKELL__ >= 800
-- TODO: move to Gap
-- Note: this deals with bindings with explicit type signature, e.g.
-- double :: Num a => a -> a
-- double x = 2*x
hsBind (L _ G.AbsBindsSig{abs_sig_export = poly, abs_sig_bind = bind}) s
| withConstraints =
let new_s =
case bind of
G.L _ G.FunBind{fun_id = i} -> M.insert (G.unLoc i) (G.varType poly) s
_ -> s
in (return [], new_s)
| otherwise = (return [], s)
#endif
-- Otherwise, it's the same as other cases
hsBind x s = genericCT x s
-- Generic SYB function to get type
genericCT x s
| withConstraints
= (maybe [] (uncurry $ constrainedType (collectBinders x) s) <$> getType' x, s)
| otherwise = (maybeToList <$> getType' x, s)
-- Collects everything with Id from LHsBind, LHsExpr, or LPat
collectBinders :: Data a => a -> [Id]
collectBinders = listifyStaged TypeChecker (const True)
-- Gets monomorphic type with location
getType' x@(L spn _)
| G.isGoodSrcSpan spn && spn `G.spans` lc
= getType tcs x
| otherwise = return Nothing
-- Gets constrained type
constrainedType :: [Var] -- ^ Binders in expression, i.e. anything with Id
-> CstGenQS -- ^ Map from Id to polymorphic type
-> SrcSpan -- ^ extent of expression, copied to result
-> Type -- ^ monomorphic type
-> [(SrcSpan, Type)] -- ^ result
constrainedType pids s spn genTyp =
let
-- runs build on every binder.
ctys = mapMaybe build (nub pids)
-- Computes constrained type for x. Returns (constraints, substitutions)
-- Substitutions are needed because type variables don't match
-- between polymorphic and monomorphic types.
-- E.g. poly type might be `Monad m => m ()`, while monomorphic might be `f ()`
build x | Just cti <- x `M.lookup` s
= let
(preds', ctt) = getPreds cti
-- list of type variables in monomorphic type
vts = listifyStaged TypeChecker G.isTyVar $ G.varType x
-- list of type variables in polymorphic type
tvm = listifyStaged TypeChecker G.isTyVarTy ctt
in Just (preds', zip vts tvm)
| otherwise = Nothing
-- list of constraints
preds = concatMap fst ctys
-- Type variable substitutions
#if __GLASGOW_HASKELL__ >= 800
-- TODO: move to Gap
subs = G.mkTvSubstPrs $ concatMap snd ctys
#else
subs = G.mkTopTvSubst $ concatMap snd ctys
#endif
-- Constrained type
ty = G.substTy subs $ G.mkFunTys preds genTyp
in [(spn, ty)]
-- Splits a given type into list of constraints and simple type. Drops foralls.
getPreds :: Type -> ([Type], Type)
getPreds x | G.isForAllTy x = getPreds $ G.dropForAlls x
| Just (c, t) <- G.splitFunTy_maybe x
, G.isPredTy c = first (c:) $ getPreds t
| otherwise = ([], x)
listifySpans :: Typeable a => TypecheckedSource -> (Int, Int) -> [Located a]
listifySpans tcs lc = listifyStaged TypeChecker p tcs
where
p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc
listifyParsedSpans :: Typeable a => ParsedSource -> (Int, Int) -> [Located a]
listifyParsedSpans pcs lc = listifyStaged Parser p pcs
where
p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc
listifyRenamedSpans :: Typeable a => RenamedSource -> (Int, Int) -> [Located a]
listifyRenamedSpans pcs lc = listifyStaged Renamer p pcs
where
p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc
listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r]
listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x]))
cmp :: SrcSpan -> SrcSpan -> Ordering
cmp a b
| a `G.isSubspanOf` b = O.LT
| b `G.isSubspanOf` a = O.GT
| otherwise = O.EQ
toTup :: DynFlags -> PprStyle -> (SrcSpan, Type) -> ((Int,Int,Int,Int),String)
toTup dflag style (spn, typ) = (fourInts spn, pretty dflag style typ)
fourInts :: SrcSpan -> (Int,Int,Int,Int)
fourInts = fromMaybe (0,0,0,0) . Gap.getSrcSpan
fourIntsHE :: HE.SrcSpan -> (Int,Int,Int,Int)
fourIntsHE loc = ( HE.srcSpanStartLine loc, HE.srcSpanStartColumn loc
, HE.srcSpanEndLine loc, HE.srcSpanEndColumn loc)
-- Check whether (line,col) is inside a given SrcSpanInfo
typeSigInRangeHE :: Int -> Int -> HE.Decl HE.SrcSpanInfo -> Bool
typeSigInRangeHE lineNo colNo (HE.TypeSig (HE.SrcSpanInfo s _) _ _) =
HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo)
typeSigInRangeHE lineNo colNo (HE.TypeFamDecl (HE.SrcSpanInfo s _) _ _ _) =
HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo)
typeSigInRangeHE lineNo colNo (HE.DataFamDecl (HE.SrcSpanInfo s _) _ _ _) =
HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo)
typeSigInRangeHE _ _ _= False
pretty :: DynFlags -> PprStyle -> Type -> String
pretty dflag style = showOneLine dflag style . Gap.typeForUser
showName :: DynFlags -> PprStyle -> G.Name -> String
showName dflag style name = showOneLine dflag style $ Gap.nameForUser name
showOccName :: DynFlags -> PprStyle -> OccName -> String
showOccName dflag style name = showOneLine dflag style $ Gap.occNameForUser name

97
core/Language/Haskell/GhcMod/Stack.hs Normal file
View File

@@ -0,0 +1,97 @@
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
module Language.Haskell.GhcMod.Stack where
import Safe
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.List.Split
import Data.Maybe
import System.Directory
import System.FilePath
import System.Info.Extra
import Exception
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Output
import Language.Haskell.GhcMod.Logging
import Language.Haskell.GhcMod.Error
import qualified Language.Haskell.GhcMod.Utils as U
import Prelude
patchStackPrograms :: (IOish m, GmOut m) => Cradle -> Programs -> m Programs
patchStackPrograms Cradle { cradleProject = (StackProject senv) } progs = do
Just ghc <- getStackGhcPath senv
Just ghcPkg <- getStackGhcPkgPath senv
return $ progs {
ghcProgram = ghc
, ghcPkgProgram = ghcPkg
}
patchStackPrograms _crdl progs = return progs
getStackEnv :: (IOish m, GmOut m, GmLog m)
=> FilePath -> FilePath -> m (Maybe StackEnv)
getStackEnv projdir stackProg = U.withDirectory_ projdir $ runMaybeT $ do
env <- map (liToTup . splitOn ": ") . lines <$> readStack stackProg ["path"]
let look k = fromJustNote "getStackEnv" $ lookup k env
return StackEnv {
seDistDir = look "dist-dir"
, seBinPath = splitSearchPath $ look "bin-path"
, seSnapshotPkgDb = look "snapshot-pkg-db"
, seLocalPkgDb = look "local-pkg-db"
}
where
liToTup [k,v] = (k,v)
liToTup [k] = (k, error "getStackEnv: missing key '"++k++"'")
liToTup _ = error "getStackEnv"
getStackGhcPath :: IOish m => StackEnv -> m (Maybe FilePath)
getStackGhcPath = findExecutablesInStackBinPath "ghc"
getStackGhcPkgPath :: IOish m => StackEnv -> m (Maybe FilePath)
getStackGhcPkgPath = findExecutablesInStackBinPath "ghc-pkg"
findExecutablesInStackBinPath :: IOish m => String -> StackEnv -> m (Maybe FilePath)
findExecutablesInStackBinPath exe StackEnv {..} =
liftIO $ listToMaybe <$> findExecutablesInDirectories' seBinPath 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, GmLog m)
=> FilePath -> [String] -> MaybeT m String
readStack exe args = do
stack <- MaybeT $ liftIO $ findExecutable exe
readProc <- lift gmReadProcess
flip gcatch handler $ do
liftIO $ evaluate =<< readProc stack args ""
where
handler (e :: IOError) = do
gmLog GmWarning "readStack" $ gmeDoc $ exToErr e
mzero
exToErr = GMEStackBootstrap . GMEString . show

515
core/Language/Haskell/GhcMod/Target.hs Normal file
View File

@@ -0,0 +1,515 @@
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE CPP, ViewPatterns, NamedFieldPuns, RankNTypes #-}
module Language.Haskell.GhcMod.Target where
import Control.Arrow
import Control.Applicative
import Control.Category ((.))
import GHC
#if __GLASGOW_HASKELL__ >= 800
import GHC.LanguageExtensions
#endif
import GHC.Paths (libdir)
import SysTools
import DynFlags
import HscTypes
import Pretty
import Language.Haskell.GhcMod.DynFlags
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.CabalHelper
import Language.Haskell.GhcMod.HomeModuleGraph
import Language.Haskell.GhcMod.PathsAndFiles
import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.Error
import Language.Haskell.GhcMod.Logging
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils as U
import Language.Haskell.GhcMod.FileMapping
import Language.Haskell.GhcMod.LightGhc
import Language.Haskell.GhcMod.CustomPackageDb
import Language.Haskell.GhcMod.Output
import Safe
import Data.Maybe
import Data.Monoid as Monoid
import Data.Either
import Data.Foldable as Foldable (foldrM)
import qualified Data.Foldable as Foldable
import Data.Traversable hiding (mapM, forM)
import Data.IORef
import Data.List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Function (on)
import Distribution.Helper
import Prelude hiding ((.))
import System.Directory
import System.FilePath
runGmPkgGhc :: (IOish m, Gm m) => LightGhc a -> m a
runGmPkgGhc action = do
pkgOpts <- packageGhcOptions
withLightHscEnv pkgOpts $ \env -> liftIO $ runLightGhc env action
initSession :: IOish m
=> [GHCOption]
-> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags)
-> GhcModT m ()
initSession opts mdf = do
s <- gmsGet
case gmGhcSession s of
Nothing -> do
gmLog GmDebug "initSession" $ text "Session not initialized, creating new one"
putNewSession s
Just (GmGhcSession hsc_env_ref) -> do
crdl <- cradle
df <- liftIO $ hsc_dflags <$> readIORef hsc_env_ref
changed <-
withLightHscEnv' (initDF crdl) $ \hsc_env ->
return $ not $ hsc_dflags hsc_env `eqDynFlags` df
if changed
then do
gmLog GmDebug "initSession" $ text "Flags changed, creating new session"
teardownSession hsc_env_ref
putNewSession s
else
gmLog GmDebug "initSession" $ text "Session already initialized"
where
initDF Cradle { cradleTempDir } df =
setTmpDir cradleTempDir <$> (mdf =<< addCmdOpts opts df)
teardownSession hsc_env_ref = do
hsc_env <- liftIO $ readIORef hsc_env_ref
teardownLightEnv hsc_env
putNewSession :: IOish m => GhcModState -> GhcModT m ()
putNewSession s = do
crdl <- cradle
nhsc_env_ref <- liftIO . newIORef =<< newLightEnv (initDF crdl)
runLightGhc' nhsc_env_ref $ setSessionDynFlags =<< getSessionDynFlags
gmsPut s { gmGhcSession = Just $ GmGhcSession nhsc_env_ref }
-- | Drop the currently active GHC session, the next that requires a GHC session
-- will initialize a new one.
dropSession :: IOish m => GhcModT m ()
dropSession = do
s <- gmsGet
case gmGhcSession s of
Just (GmGhcSession ref) -> do
-- TODO: This is still not enough, there seem to still be references to
-- GHC's state around afterwards.
liftIO $ writeIORef ref (error "HscEnv: session was dropped")
-- Not available on ghc<7.8; didn't really help anyways
-- liftIO $ setUnsafeGlobalDynFlags (error "DynFlags: session was dropped")
gmsPut s { gmGhcSession = Nothing }
Nothing -> return ()
-- | Run a GmlT action (i.e. a function in the GhcMonad) in the context
-- of certain files or modules
runGmlT :: IOish m => [Either FilePath ModuleName] -> GmlT m a -> GhcModT m a
runGmlT fns action = runGmlT' fns return action
-- | Run a GmlT action (i.e. a function in the GhcMonad) in the context
-- of certain files or modules, with updated GHC flags
runGmlT' :: IOish m
=> [Either FilePath ModuleName]
-> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags)
-> GmlT m a
-> GhcModT m a
runGmlT' fns mdf action = runGmlTWith fns mdf id action
-- | Run a GmlT action (i.e. a function in the GhcMonad) in the context
-- of certain files or modules, with updated GHC flags and a final
-- transformation
runGmlTWith :: IOish m
=> [Either FilePath ModuleName]
-> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags)
-> (GmlT m a -> GmlT m b)
-> GmlT m a
-> GhcModT m b
runGmlTWith efnmns' mdf wrapper action = do
crdl <- cradle
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"] ++ optGhcUserOptions
gmVomit
"session-ghc-options"
(text "Initializing GHC session with following options")
(intercalate " " $ map (("\""++) . (++"\"")) opts')
GhcModLog { gmLogLevel = Just level } <- gmlHistory
putErr <- gmErrStrIO
let setLogger | level >= GmDebug = setDebugLogger putErr
| otherwise = setEmptyLogger
initSession opts' $
setHscNothing >>> setLogger >>> mdf
mappedStrs <- getMMappedFilePaths
let targetStrs = mappedStrs ++ map moduleNameString mns ++ cfns
unGmlT $ wrapper $ do
loadTargets opts targetStrs
action
targetGhcOptions :: forall m. IOish m
=> Cradle
-> Set (Either FilePath ModuleName)
-> GhcModT m [GHCOption]
targetGhcOptions crdl sefnmn = do
when (Set.null sefnmn) $ error "targetGhcOptions: no targets given"
case cradleProject crdl of
proj
| isCabalHelperProject proj -> cabalOpts crdl
| otherwise -> sandboxOpts crdl
where
zipMap f l = l `zip` (f `map` l)
cabalOpts :: Cradle -> GhcModT m [String]
cabalOpts Cradle{..} = do
mcs <- cabalResolvedComponents
let mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn
candidates = findCandidates $ map snd mdlcs
let noCandidates = Set.null candidates
noModuleHasAnyAssignment = all (Set.null . snd) mdlcs
if noCandidates && noModuleHasAnyAssignment
then do
-- First component should be ChLibName, if no lib will take lexically first exe.
let cns = filter (/= ChSetupHsName) $ Map.keys mcs
gmLog GmDebug "" $ strDoc $ "Could not find a component assignment, falling back to picking library component in cabal file."
return $ gmcGhcOpts $ fromJustNote "targetGhcOptions, no-assignment" $ Map.lookup (head cns) mcs
else do
when noCandidates $
throwError $ GMECabalCompAssignment mdlcs
let cn = pickComponent candidates
return $ gmcGhcOpts $ fromJustNote "targetGhcOptions" $ Map.lookup cn mcs
resolvedComponentsCache :: IOish m => FilePath ->
Cached (GhcModT m) GhcModState
[GmComponent 'GMCRaw (Set.Set ModulePath)]
(Map.Map ChComponentName (GmComponent 'GMCResolved (Set.Set ModulePath)))
resolvedComponentsCache distdir = Cached {
cacheLens = Just (lGmcResolvedComponents . lGmCaches),
cacheFile = resolvedComponentsCacheFile distdir,
cachedAction = \tcfs comps ma -> do
Cradle {..} <- cradle
let iifs = invalidatingInputFiles tcfs
setupChanged =
(cradleRootDir </> setupConfigPath distdir) `elem` iifs
mums :: Maybe [Either FilePath ModuleName]
mums =
let
filterOutSetupCfg =
filter (/= cradleRootDir </> setupConfigPath distdir)
changedFiles = filterOutSetupCfg iifs
in if null changedFiles || setupChanged
then Nothing
else Just $ map Left changedFiles
let mdesc (Left f) = "file:" ++ f
mdesc (Right mn) = "module:" ++ moduleNameString mn
changed = map (text . mdesc) $ Foldable.concat mums
changedDoc | [] <- changed = text "none"
| otherwise = sep changed
gmLog GmDebug "resolvedComponentsCache" $
text "files changed" <+>: changedDoc
mcs <- resolveGmComponents ((,) <$> mums <*> ma) comps
return (setupConfigPath distdir : flatten mcs , mcs)
}
where
flatten :: Map.Map ChComponentName (GmComponent t (Set.Set ModulePath))
-> [FilePath]
flatten = Map.elems
>>> map (gmcHomeModuleGraph >>> gmgGraph
>>> (Map.keysSet &&& Map.elems)
>>> uncurry insert
>>> map (Set.map mpPath)
>>> Set.unions
)
>>> Set.unions
>>> Set.toList
moduleComponents :: Map ChComponentName (GmComponent t (Set ModulePath))
-> Either FilePath ModuleName
-> Set ChComponentName
moduleComponents m efnmn =
foldr' Set.empty m $ \c s ->
let
memb =
case efnmn of
Left fn -> fn `Set.member` Set.map mpPath (smp c)
Right mn -> mn `Set.member` Set.map mpModule (smp c)
in if memb
then Set.insert (gmcName c) s
else s
where
smp c = Map.keysSet $ gmgGraph $ gmcHomeModuleGraph c
foldr' b as f = Map.foldr f b as
findCandidates :: [Set ChComponentName] -> Set ChComponentName
findCandidates [] = Set.empty
findCandidates scns = foldl1 Set.intersection scns
pickComponent :: Set ChComponentName -> ChComponentName
pickComponent scn = Set.findMin scn
packageGhcOptions :: (IOish m, Applicative m, Gm m) => m [GHCOption]
packageGhcOptions = do
crdl <- cradle
case cradleProject crdl of
proj
| isCabalHelperProject proj -> getGhcMergedPkgOptions
| otherwise -> sandboxOpts crdl
-- also works for plain projects!
sandboxOpts :: (IOish m, GmEnv m) => Cradle -> m [String]
sandboxOpts crdl = do
mCusPkgDb <- getCustomPkgDbStack
pkgDbStack <- liftIO $ getSandboxPackageDbStack
let pkgOpts = ghcDbStackOpts $ fromMaybe pkgDbStack mCusPkgDb
return $ ["-i" ++ d | d <- [wdir,rdir]] ++ pkgOpts ++ ["-Wall"]
where
(wdir, rdir) = (cradleCurrentDir crdl, cradleRootDir crdl)
getSandboxPackageDbStack :: IO [GhcPkgDb]
getSandboxPackageDbStack =
([GlobalDb] ++) . maybe [UserDb] return <$> getSandboxDb crdl
resolveGmComponent :: (IOish m, Gm m)
=> Maybe [CompilationUnit] -- ^ Updated modules
-> GmComponent 'GMCRaw (Set ModulePath)
-> m (GmComponent 'GMCResolved (Set ModulePath))
resolveGmComponent mums c@GmComponent {..} = do
distDir <- cradleDistDir <$> cradle
gmLog GmDebug "resolveGmComponent" $ text $ show $ ghcOpts distDir
withLightHscEnv (ghcOpts distDir) $ \env -> do
let srcDirs = if null gmcSourceDirs then [""] else gmcSourceDirs
let mg = gmcHomeModuleGraph
let simp = gmcEntrypoints
sump <- case mums of
Nothing -> return simp
Just ums ->
Set.fromList . catMaybes <$>
mapM (resolveModule env srcDirs) ums
mg' <- canonicalizeModuleGraph =<< updateHomeModuleGraph env mg simp sump
return $ c { gmcEntrypoints = simp, gmcHomeModuleGraph = mg' }
where ghcOpts distDir = concat [
gmcGhcSrcOpts,
gmcGhcLangOpts,
[ "-optP-include", "-optP" ++ distDir </> macrosHeaderPath ]
]
resolveEntrypoint :: (IOish m, Gm m)
=> Cradle
-> GmComponent 'GMCRaw ChEntrypoint
-> m (GmComponent 'GMCRaw (Set ModulePath))
resolveEntrypoint Cradle {..} c@GmComponent {..} = do
gmLog GmDebug "resolveEntrypoint" $ text $ show $ gmcGhcSrcOpts
withLightHscEnv gmcGhcSrcOpts $ \env -> do
let srcDirs = if null gmcSourceDirs then [""] else gmcSourceDirs
eps <- liftIO $ resolveChEntrypoints cradleRootDir gmcEntrypoints
rms <- resolveModule env srcDirs `mapM` eps
return c { gmcEntrypoints = Set.fromList $ catMaybes rms }
-- TODO: remember that the file from `main-is:` is always module `Main` and let
-- ghc do the warning about it. Right now we run that module through
-- resolveModule like any other
resolveChEntrypoints :: FilePath -> ChEntrypoint -> IO [CompilationUnit]
resolveChEntrypoints _ (ChLibEntrypoint em om) =
return $ map (Right . chModToMod) (em ++ om)
resolveChEntrypoints _ (ChExeEntrypoint main om) =
return $ [Left main] ++ map (Right . chModToMod) om
resolveChEntrypoints srcDir ChSetupEntrypoint = do
shs <- doesFileExist (srcDir </> "Setup.hs")
slhs <- doesFileExist (srcDir </> "Setup.lhs")
return $ case (shs, slhs) of
(True, _) -> [Left "Setup.hs"]
(_, True) -> [Left "Setup.lhs"]
(False, False) -> []
chModToMod :: ChModuleName -> ModuleName
chModToMod (ChModuleName mn) = mkModuleName mn
resolveModule :: (IOish m, Gm m) =>
HscEnv -> [FilePath] -> CompilationUnit -> m (Maybe ModulePath)
resolveModule env _srcDirs (Right mn) =
liftIO $ traverse canonicalizeModulePath =<< findModulePath env mn
resolveModule env srcDirs (Left fn') = do
mfn <- liftIO $ findFile' srcDirs fn'
case mfn of
Nothing -> return Nothing
Just fn'' -> do
fn <- liftIO $ canonicalizePath fn''
emn <- fileModuleName env fn
case emn of
Left errs -> do
gmLog GmWarning ("resolveModule " ++ show fn) $
Pretty.empty $+$ (vcat $ map text errs)
return Nothing -- TODO: should expose these errors otherwise
-- modules with preprocessor/parse errors are
-- going to be missing
Right mmn -> return $ Just $
case mmn of
Nothing -> mkMainModulePath fn
Just mn -> ModulePath mn fn
where
-- needed for ghc 7.4
findFile' dirs file =
getFirst . mconcat <$> mapM (fmap First . mightExist . (</>file)) dirs
-- fileModuleName fn (dir:dirs)
-- | makeRelative dir fn /= fn
type CompilationUnit = Either FilePath ModuleName
type Components =
[GmComponent 'GMCRaw (Set ModulePath)]
type ResolvedComponentsMap =
Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath))
resolveGmComponents :: (IOish m, Gm m)
=> Maybe ([CompilationUnit], ResolvedComponentsMap)
-- ^ Updated modules
-> Components -> m ResolvedComponentsMap
resolveGmComponents mcache cs = do
let rcm = fromMaybe Map.empty $ snd <$> mcache
m' <- foldrM' rcm cs $ \c m -> do
case Map.lookup (gmcName c) m of
Nothing -> insertUpdated m c
Just c' -> if same gmcRawEntrypoints c c' && same gmcGhcSrcOpts c c'
then return m
else insertUpdated m c
return m'
where
foldrM' b fa f = foldrM f b fa
insertUpdated m c = do
rc <- resolveGmComponent (fst <$> mcache) c
return $ Map.insert (gmcName rc) rc m
same :: Eq b
=> (forall t a. GmComponent t a -> b)
-> GmComponent u c -> GmComponent v d -> Bool
same f a b = (f a) == (f b)
-- | Set the files as targets and load them.
loadTargets :: IOish m => [GHCOption] -> [FilePath] -> GmlT m ()
loadTargets opts targetStrs = do
targets' <-
withLightHscEnv opts $ \env ->
liftM (nubBy ((==) `on` targetId))
(mapM ((`guessTarget` Nothing) >=> mapFile env) targetStrs)
>>= mapM relativize
let targets = map (\t -> t { targetAllowObjCode = False }) targets'
gmLog GmDebug "loadTargets" $
text "Loading" <+>: fsep (map (text . showTargetId) targets)
setTargets targets
mg <- depanal [] False
let interp = needsHscInterpreted mg
target <- hscTarget <$> getSessionDynFlags
when (interp && target /= HscInterpreted) $ do
_ <- setSessionDynFlags . setHscInterpreted =<< getSessionDynFlags
gmLog GmInfo "loadTargets" $ text "Target needs interpeter, switching to LinkInMemory/HscInterpreted. Perfectly normal if anything is using TemplateHaskell, QuasiQuotes or PatternSynonyms."
target' <- hscTarget <$> getSessionDynFlags
case target' of
HscNothing -> do
void $ load LoadAllTargets
forM_ mg $
handleSourceError (gmLog GmDebug "loadTargets" . text . show)
. void . (parseModule >=> typecheckModule >=> desugarModule)
HscInterpreted -> do
void $ load LoadAllTargets
_ -> error ("loadTargets: unsupported hscTarget")
gmLog GmDebug "loadTargets" $ text "Loading done"
where
relativize (Target (TargetFile filePath phase) taoc src) = do
crdl <- cradle
let tid = TargetFile relativeFilePath phase
relativeFilePath = makeRelative (cradleRootDir crdl) filePath
return $ Target tid taoc src
relativize tgt = return tgt
showTargetId (Target (TargetModule s) _ _) = moduleNameString s
showTargetId (Target (TargetFile s _) _ _) = s
needsHscInterpreted :: ModuleGraph -> Bool
needsHscInterpreted = any $ \ms ->
let df = ms_hspp_opts ms in
#if __GLASGOW_HASKELL__ >= 800
TemplateHaskell `xopt` df
|| QuasiQuotes `xopt` df
|| PatternSynonyms `xopt` df
#else
Opt_TemplateHaskell `xopt` df
|| Opt_QuasiQuotes `xopt` df
#if __GLASGOW_HASKELL__ >= 708
|| (Opt_PatternSynonyms `xopt` df)
#endif
#endif
cabalResolvedComponents :: (IOish m) =>
GhcModT m (Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath)))
cabalResolvedComponents = do
crdl@(Cradle{..}) <- cradle
comps <- mapM (resolveEntrypoint crdl) =<< getComponents
withAutogen $
cached cradleRootDir (resolvedComponentsCache cradleDistDir) comps

406
core/Language/Haskell/GhcMod/Types.hs Normal file
View File

@@ -0,0 +1,406 @@
{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, RankNTypes,
StandaloneDeriving, DefaultSignatures, FlexibleInstances, TemplateHaskell,
GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-}
module Language.Haskell.GhcMod.Types (
module Language.Haskell.GhcMod.Types
, ModuleName
, mkModuleName
, moduleNameString
) where
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.Error (Error(..))
import qualified Control.Monad.IO.Class as MTL
import Control.Exception (Exception)
import Control.Applicative
import Control.Concurrent
import Control.Monad
import Control.DeepSeq
import Data.Binary
import Data.Binary.Generic
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Monoid
import Data.Maybe
import Data.Typeable (Typeable)
import Data.IORef
import Data.Label.Derive
import Distribution.Helper hiding (Programs(..))
import qualified Distribution.Helper as CabalHelper
import Exception (ExceptionMonad)
#if __GLASGOW_HASKELL__ < 708
import qualified MonadUtils as GHC (MonadIO(..))
#endif
import GHC (ModuleName, moduleNameString, mkModuleName)
import HscTypes (HscEnv)
import GHC.Generics
import Pretty (Doc)
import Prelude
import Language.Haskell.GhcMod.Caching.Types
-- | A constraint alias (-XConstraintKinds) to make functions dealing with
-- 'GhcModT' somewhat cleaner.
--
-- Basicially an @IOish m => m@ is a 'Monad' supporting arbitrary 'IO' and
-- exception handling. Usually this will simply be 'IO' but we parametrise it in
-- the exported API so users have the option to use a custom inner monad.
type IOish m = (Functor m, MonadIO m, MonadBaseControl IO m, ExceptionMonad m)
-- MonadUtils of GHC 7.6 or earlier defines its own MonadIO.
-- MonadUtils of GHC 7.8 or later imports MonadIO in Monad.Control.IO.Class.
#if __GLASGOW_HASKELL__ < 708
type MonadIOC m = (GHC.MonadIO m, MTL.MonadIO m)
#else
type MonadIOC m = (MTL.MonadIO m)
#endif
class MonadIOC m => MonadIO m where
liftIO :: IO a -> m a
-- | Output style.
data OutputStyle = LispStyle -- ^ S expression style.
| PlainStyle -- ^ Plain textstyle.
deriving (Show)
-- | The type for line separator. Historically, a Null string is used.
newtype LineSeparator = LineSeparator String deriving (Show)
data FileMapping = FileMapping {fmPath :: FilePath, fmTemp :: Bool}
deriving (Eq, Show)
type FileMappingMap = Map FilePath FileMapping
data ProgramSource = ProgramSourceUser | ProgramSourceStack
data Programs = Programs {
-- | @ghc@ program name.
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
, optGhcUserOptions :: [GHCOption]
, optFileMappings :: [(FilePath, Maybe FilePath)]
, optEncoding :: String
, optStackBuildDeps :: Bool
} deriving (Show)
-- | A default 'Options'.
defaultOptions :: Options
defaultOptions = Options {
optOutput = OutputOpts {
ooptLogLevel = GmWarning
, ooptStyle = PlainStyle
, ooptLineSeparator = LineSeparator "\0"
, ooptLinePrefix = Nothing
}
, optPrograms = Programs {
ghcProgram = "ghc"
, ghcPkgProgram = "ghc-pkg"
, cabalProgram = "cabal"
, stackProgram = "stack"
}
, optGhcUserOptions = []
, optFileMappings = []
, optEncoding = "UTF-8"
, optStackBuildDeps = False
}
----------------------------------------------------------------
data Project = CabalProject
| SandboxProject
| PlainProject
| StackProject StackEnv
deriving (Eq, Show, Ord)
isCabalHelperProject :: Project -> Bool
isCabalHelperProject StackProject {} = True
isCabalHelperProject CabalProject {} = True
isCabalHelperProject _ = False
data StackEnv = StackEnv {
seDistDir :: FilePath
, seBinPath :: [FilePath]
, seSnapshotPkgDb :: FilePath
, seLocalPkgDb :: FilePath
} deriving (Eq, Show, Ord)
-- | The environment where this library is used.
data Cradle = Cradle {
cradleProject :: Project
-- | The directory where this library is executed.
, cradleCurrentDir :: FilePath
-- | The project root directory.
, cradleRootDir :: FilePath
-- | Per-Project temporary directory
, cradleTempDir :: FilePath
-- | The file name of the found cabal file.
, cradleCabalFile :: Maybe FilePath
-- | The build info directory.
, cradleDistDir :: FilePath
} deriving (Eq, Show, Ord)
data GmStream = GmOutStream | GmErrStream
deriving (Show)
data GhcModEnv = GhcModEnv {
gmOptions :: Options
, gmCradle :: Cradle
}
data GhcModOut = GhcModOut {
gmoOptions :: OutputOpts
, gmoChan :: Chan (Either (MVar ()) (GmStream, String))
}
data GhcModLog = GhcModLog {
gmLogLevel :: Maybe GmLogLevel,
gmLogVomitDump :: Last Bool,
gmLogMessages :: [(GmLogLevel, String, Doc)]
} deriving (Show)
instance Monoid GhcModLog where
mempty = GhcModLog (Just GmPanic) (Last Nothing) mempty
GhcModLog ml vd ls `mappend` GhcModLog ml' vd' ls' =
GhcModLog (ml' `mplus` ml) (vd `mappend` vd') (ls `mappend` ls')
data GmGhcSession = GmGhcSession {
gmgsSession :: !(IORef HscEnv)
}
data GhcModCaches = GhcModCaches {
gmcPackageDbStack :: CacheContents ChCacheData [GhcPkgDb]
, gmcMergedPkgOptions :: CacheContents ChCacheData [GHCOption]
, gmcComponents :: CacheContents ChCacheData [GmComponent 'GMCRaw ChEntrypoint]
, gmcResolvedComponents :: CacheContents
[GmComponent 'GMCRaw (Set.Set ModulePath)]
(Map.Map ChComponentName (GmComponent 'GMCResolved (Set.Set ModulePath)))
}
data GhcModState = GhcModState {
gmGhcSession :: !(Maybe GmGhcSession)
, gmCaches :: !GhcModCaches
, gmMMappedFiles :: !FileMappingMap
}
defaultGhcModState :: GhcModState
defaultGhcModState =
GhcModState n (GhcModCaches n n n n) Map.empty
where n = Nothing
----------------------------------------------------------------
-- | GHC package database flags.
data GhcPkgDb = GlobalDb
| UserDb
| PackageDb String
deriving (Eq, Show, Generic)
instance Binary GhcPkgDb where
put = ggput . from
get = to `fmap` ggget
-- | A single GHC command line option.
type GHCOption = String
-- | An include directory for modules.
type IncludeDir = FilePath
-- | Haskell expression.
newtype Expression = Expression { getExpression :: String }
deriving (Show, Eq, Ord)
-- | Module name.
newtype ModuleString = ModuleString { getModuleString :: String }
deriving (Show, Eq, Ord, Binary, NFData)
data GmLogLevel =
GmSilent
| GmPanic
| GmException
| GmError
| GmWarning
| GmInfo
| GmDebug
| GmVomit
deriving (Eq, Ord, Enum, Bounded, Show, Read)
data GmModuleGraph = GmModuleGraph {
gmgGraph :: Map ModulePath (Set ModulePath)
} deriving (Eq, Ord, Show, Read, Generic, Typeable)
instance Binary GmModuleGraph where
put GmModuleGraph {..} = put (mpim, graph)
where
mpim :: Map ModulePath Integer
mpim = Map.fromList $ Map.keys gmgGraph `zip` [0..]
graph :: Map Integer (Set Integer)
graph = Map.map (Set.map mpToInt) $ Map.mapKeys mpToInt gmgGraph
mpToInt :: ModulePath -> Integer
mpToInt mp = fromJust $ Map.lookup mp mpim
get = do
(mpim :: Map ModulePath Integer, graph :: Map Integer (Set Integer)) <- get
let impm = swapMap mpim
intToMp i = fromJust $ Map.lookup i impm
mpGraph :: Map ModulePath (Set ModulePath)
mpGraph = Map.map (Set.map intToMp) $ Map.mapKeys intToMp graph
return $ GmModuleGraph mpGraph
where
swapMap :: Ord v => Map k v -> Map v k
swapMap = Map.fromList . map (\(x, y) -> (y, x)) . Map.toList
instance Monoid GmModuleGraph where
mempty = GmModuleGraph mempty
mappend (GmModuleGraph a) (GmModuleGraph a') =
GmModuleGraph (Map.unionWith Set.union a a')
data GmComponentType = GMCRaw
| GMCResolved
data GmComponent (t :: GmComponentType) eps = GmComponent {
gmcHomeModuleGraph :: GmModuleGraph
, gmcName :: ChComponentName
, gmcGhcOpts :: [GHCOption]
, gmcGhcPkgOpts :: [GHCOption]
, gmcGhcSrcOpts :: [GHCOption]
, gmcGhcLangOpts :: [GHCOption]
, gmcRawEntrypoints :: ChEntrypoint
, gmcEntrypoints :: eps
, gmcSourceDirs :: [FilePath]
} deriving (Eq, Ord, Show, Read, Generic, Functor)
instance Binary eps => Binary (GmComponent t eps) where
put = ggput . from
get = to `fmap` ggget
data ModulePath = ModulePath { mpModule :: ModuleName, mpPath :: FilePath }
deriving (Eq, Ord, Show, Read, Generic, Typeable)
instance Binary ModulePath where
put = ggput . from
get = to `fmap` ggget
instance Binary ModuleName where
get = mkModuleName <$> get
put mn = put (moduleNameString mn)
instance Show ModuleName where
show mn = "ModuleName " ++ show (moduleNameString mn)
instance Read ModuleName where
readsPrec d =
readParen
(d > app_prec)
(\r' -> [ (mkModuleName m, t)
| ("ModuleName", s) <- lex r'
, (m, t) <- readsPrec (app_prec + 1) s
])
where
app_prec = 10
data GhcModError
= GMENoMsg
-- ^ Unknown error
| GMEString String
-- ^ Some Error with a message. These are produced mostly by
-- 'fail' calls on GhcModT.
| GMECabalConfigure GhcModError
-- ^ Configuring a cabal project failed.
| GMEStackConfigure GhcModError
-- ^ Configuring a stack project failed.
| GMEStackBootstrap GhcModError
-- ^ Bootstrapping @stack@ environment failed (process exited with failure)
| GMECabalCompAssignment [(Either FilePath ModuleName, Set ChComponentName)]
-- ^ Could not find a consistent component assignment for modules
| GMEProcess String String [String] (Either Int GhcModError)
-- ^ Launching an operating system process failed. Fields in
-- order: function, command, arguments, (stdout, stderr, exitcode)
| GMENoCabalFile
-- ^ No cabal file found.
| GMETooManyCabalFiles [FilePath]
-- ^ Too many cabal files found.
deriving (Eq,Show,Typeable)
instance Error GhcModError where
noMsg = GMENoMsg
strMsg = GMEString
instance Exception GhcModError
instance Binary CabalHelper.Programs where
put = ggput . from
get = to `fmap` ggget
instance Binary ChModuleName where
put = ggput . from
get = to `fmap` ggget
instance Binary ChComponentName where
put = ggput . from
get = to `fmap` ggget
instance Binary ChEntrypoint where
put = ggput . from
get = to `fmap` ggget
-- | Options for "lintWith" function
data LintOpts = LintOpts {
optLintHlintOpts :: [String]
-- ^ options that will be passed to hlint executable
} deriving (Show)
-- | Default "LintOpts" instance
defaultLintOpts :: LintOpts
defaultLintOpts = LintOpts []
-- | Options for "browseWith" function
data BrowseOpts = BrowseOpts {
optBrowseOperators :: Bool
-- ^ If 'True', "browseWith" also returns operators.
, optBrowseDetailed :: Bool
-- ^ If 'True', "browseWith" also returns types.
, optBrowseParents :: Bool
-- ^ If 'True', "browseWith" also returns parents.
, optBrowseQualified :: Bool
-- ^ If 'True', "browseWith" will return fully qualified name
} deriving (Show)
-- | Default "BrowseOpts" instance
defaultBrowseOpts :: BrowseOpts
defaultBrowseOpts = BrowseOpts False False False False
mkLabel ''GhcModCaches
mkLabel ''GhcModState
mkLabel ''Options
mkLabel ''OutputOpts
mkLabel ''Programs

164
core/Language/Haskell/GhcMod/Utils.hs Normal file
View File

@@ -0,0 +1,164 @@
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE CPP #-}
{-# LANGUAGE DoAndIfThenElse #-}
module Language.Haskell.GhcMod.Utils (
module Language.Haskell.GhcMod.Utils
, module Utils
, readProcess
) where
import Control.Applicative
import Data.Char
import qualified Data.Map as M
import Data.Maybe (fromMaybe)
import Data.Either (rights)
import Data.List (inits)
import Exception
import Language.Haskell.GhcMod.Error
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad.Types
import System.Directory
import System.Environment
import System.FilePath
import System.IO.Temp (createTempDirectory)
import System.Process (readProcess)
import Text.Printf
import Paths_ghc_mod (getLibexecDir, getBinDir)
import Utils
import Prelude
-- dropWhileEnd is not provided prior to base 4.5.0.0.
dropWhileEnd :: (a -> Bool) -> [a] -> [a]
dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) []
withDirectory_ :: (MonadIO m, ExceptionMonad m) => FilePath -> m a -> m a
withDirectory_ dir action =
gbracket
(liftIO getCurrentDirectory)
(liftIO . setCurrentDirectory)
(\_ -> liftIO (setCurrentDirectory dir) >> action)
uniqTempDirName :: FilePath -> FilePath
uniqTempDirName dir =
"ghc-mod" ++ map escapeDriveChar drive ++ map escapePathChar path
where
(drive, path) = splitDrive dir
escapeDriveChar :: Char -> Char
escapeDriveChar c
| isAlphaNum c = c
| otherwise = '-'
escapePathChar :: Char -> Char
escapePathChar c
| c `elem` pathSeparators = '-'
| otherwise = c
newTempDir :: FilePath -> IO FilePath
newTempDir _dir =
flip createTempDirectory "ghc-mod" =<< getTemporaryDirectory
whenM :: Monad m => m Bool -> m () -> m ()
whenM mb ma = mb >>= flip when ma
-- | Returns the path to the currently running ghc-mod executable. With ghc<7.6
-- this is a guess but >=7.6 uses 'getExecutablePath'.
ghcModExecutable :: IO FilePath
#ifndef SPEC
ghcModExecutable = do
dir <- takeDirectory <$> getExecutablePath'
return $ (if dir == "." then "" else dir) </> "ghc-mod"
#else
ghcModExecutable = do
gpp <- lookupEnv "STACK_EXE"
case gpp of
Just _ -> fmap (</> "ghc-mod") getBinDir
_ -> fmap (</> "dist/build/ghc-mod/ghc-mod") getCurrentDirectory
#endif
getExecutablePath' :: IO FilePath
#if __GLASGOW_HASKELL__ >= 706
getExecutablePath' = getExecutablePath
#else
getExecutablePath' = getProgName
#endif
canonFilePath :: FilePath -> IO FilePath
canonFilePath f = do
p <- canonicalizePath f
e <- doesFileExist p
when (not e) $ error $ "canonFilePath: not a file: " ++ p
return p
withMappedFile :: (IOish m, GmState m, GmEnv m) =>
forall a. FilePath -> (FilePath -> m a) -> m a
withMappedFile file action = getCanonicalFileNameSafe file >>= lookupMMappedFile >>= runWithFile
where
runWithFile (Just to) = action $ fmPath to
runWithFile _ = action file
getCanonicalFileNameSafe :: (IOish m, GmEnv m) => FilePath -> m FilePath
getCanonicalFileNameSafe fn = do
let fn' = normalise fn
pl <- liftIO $ rights <$> (mapM ((try :: IO FilePath -> IO (Either SomeException FilePath)) . canonicalizePath . joinPath) $ reverse $ inits $ splitPath' fn')
return $
if (length pl > 0)
then joinPath $ (head pl):(drop (length pl - 1) (splitPath fn'))
else error "Current dir doesn't seem to exist?"
where
#if __GLASGOW_HASKELL__ < 710
splitPath' = (".":) . splitPath
#else
splitPath' = splitPath
#endif
mkRevRedirMapFunc :: (Functor m, GmState m, GmEnv m) => m (FilePath -> FilePath)
mkRevRedirMapFunc = do
rm <- M.fromList <$> map (uncurry mf) <$> M.toList <$> getMMappedFiles
crdl <- cradle
return $ \key ->
fromMaybe key
$ makeRelative (cradleRootDir crdl)
<$> M.lookup key rm
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
-- Copyright : (c) The University of Glasgow 2001
-- | Make a path absolute by prepending the current directory (if it isn't
-- already absolute) and applying 'normalise' to the result.
--
-- If the path is already absolute, the operation never fails. Otherwise, the
-- operation may fail with the same exceptions as 'getCurrentDirectory'.
makeAbsolute' :: FilePath -> IO FilePath
makeAbsolute' = (normalise <$>) . absolutize
where absolutize path -- avoid the call to `getCurrentDirectory` if we can
| isRelative path = (</> path) <$> getCurrentDirectory
| otherwise = return path

55
core/Language/Haskell/GhcMod/World.hs Normal file
View File

@@ -0,0 +1,55 @@
module Language.Haskell.GhcMod.World where
import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.PathsAndFiles
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Utils
import Control.Applicative
import Data.Maybe
import Data.Traversable hiding (mapM)
import System.FilePath ((</>))
import GHC.Paths (libdir)
import Prelude
data World = World {
worldPackageCaches :: [TimedFile]
, worldCabalFile :: Maybe TimedFile
, worldCabalConfig :: Maybe TimedFile
, worldCabalSandboxConfig :: Maybe TimedFile
, worldMappedFiles :: FileMappingMap
} deriving (Eq)
timedPackageCaches :: IOish m => GhcModT m [TimedFile]
timedPackageCaches = do
fs <- mapM (liftIO . mightExist) . map (</> packageCache)
=<< getPackageCachePaths libdir
(liftIO . timeFile) `mapM` catMaybes fs
getCurrentWorld :: IOish m => GhcModT m World
getCurrentWorld = do
crdl <- cradle
pkgCaches <- timedPackageCaches
mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl
mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl)
mCabalSandboxConfig <- liftIO $ timeMaybe (sandboxConfigFile crdl)
mFileMap <- getMMappedFiles
return World {
worldPackageCaches = pkgCaches
, worldCabalFile = mCabalFile
, worldCabalConfig = mCabalConfig
, worldCabalSandboxConfig = mCabalSandboxConfig
, worldMappedFiles = mFileMap
}
didWorldChange :: IOish m => World -> GhcModT m Bool
didWorldChange world = do
(world /=) <$> getCurrentWorld
isYoungerThanSetupConfig :: FilePath -> World -> IO Bool
isYoungerThanSetupConfig file World {..} = do
tfile <- timeFile file
return $ worldCabalConfig < Just tfile