module HsDev.Tools.GhcMod (
list,
browse, browseInspection,
langs, flags,
info,
TypedRegion(..),
typeOf,
OutputMessage(..),
parseOutputMessages, parseOutputMessage,
check,
lint,
runGhcMod,
locateGhcModEnv, ghcModEnvPath,
ghcModWorker,
WorkerMap,
ghcModMultiWorker, dispatch,
waitMultiGhcMod,
GhcModT,
module Control.Concurrent.Worker,
module Control.Monad.Except,
module HsDev.Tools.Types
) where
import Control.Applicative
import Control.Arrow
import Control.Concurrent
import Control.DeepSeq
import Control.Exception (SomeException(..))
import Control.Lens (view, preview, _Just, over)
import Control.Monad.Except
import Control.Monad.Catch (MonadThrow(..), MonadCatch(..))
import Control.Monad.Reader
import Data.Aeson hiding (Error)
import Data.Char
import Data.List (sort)
import Data.Maybe
import qualified Data.Map as M
import Data.String (fromString)
import Exception (gcatch)
import System.Directory
import System.FilePath (normalise)
import Text.Read (readMaybe)
import Language.Haskell.GhcMod (GhcModT, withOptions)
import qualified Language.Haskell.GhcMod as GhcMod
import qualified Language.Haskell.GhcMod.Monad as GhcMod
import qualified Language.Haskell.GhcMod.Types as GhcMod
import Control.Concurrent.Worker
import HsDev.PackageDb
import HsDev.Project
import HsDev.Sandbox (searchPackageDbStack)
import HsDev.Symbols
import HsDev.Tools.Base
import HsDev.Tools.Types
import HsDev.Util ((.::), liftIOErrors, liftThrow, readFileUtf8, ordNub)
list :: [String] -> PackageDbStack -> ExceptT String IO [ModuleLocation]
list opts pdbs = runGhcMod (GhcMod.defaultOptions { GhcMod.optGhcUserOptions = opts }) $ do
ms <- (map splitPackage . lines) <$> GhcMod.modules True
return [InstalledModule (topPackageDb pdbs) (readMaybe p) m | (m, p) <- ms]
where
splitPackage :: String -> (String, String)
splitPackage = second (drop 1) . break isSpace
browse :: [String] -> PackageDbStack -> String -> Maybe ModulePackage -> ExceptT String IO InspectedModule
browse opts pdbs mname mpackage = inspect thisLoc (return $ browseInspection opts) $ runGhcMod
(GhcMod.defaultOptions { GhcMod.optGhcUserOptions = packageOpt mpackage ++ opts }) $ do
ds <- (mapMaybe parseDecl . lines) <$> GhcMod.browse
(GhcMod.defaultBrowseOpts {
GhcMod.optBrowseDetailed = True,
GhcMod.optBrowseQualified = True })
mpkgname
return Module {
_moduleName = fromString mname,
_moduleDocs = Nothing,
_moduleLocation = thisLoc,
_moduleExports = Just [ExportName Nothing (view declarationName d) ThingNothing | d <- ds],
_moduleImports = [import_ iname |
iname <- ordNub (mapMaybe (preview definedModule) ds),
iname /= fromString mname],
_moduleDeclarations = sortDeclarations ds }
where
mpkgname = maybe mname (\p -> view packageName p ++ ":" ++ mname) mpackage
thisLoc = view moduleIdLocation $ mloc mname
mloc mname' = ModuleId (fromString mname') $ InstalledModule (topPackageDb pdbs) Nothing mname'
parseDecl s = do
groups <- matchRx rx s
let
rdecl = decl (fromString $ groups `at` 3) $ case groups 5 of
Nothing -> Function (Just $ fromString $ groups `at` 4) [] Nothing
Just k -> declarationTypeCtor k $
TypeInfo Nothing (maybe [] (map fromString . words) $ groups 7) Nothing []
return $ rdecl `definedIn` mloc (init $ groups `at` 1)
definedModule = declarationDefined . _Just . moduleIdName
rx = "^((\\w+\\.)*)(\\w+)\\s+::\\s+((class|type|data|newtype)\\s+(\\w+)((\\s+\\w+)*)?|.*)$"
browseInspection :: [String] -> Inspection
browseInspection = InspectionAt 0 . sort . ordNub
langs :: ExceptT String IO [String]
langs = runGhcMod GhcMod.defaultOptions $ (lines . nullToNL) <$> GhcMod.languages
flags :: ExceptT String IO [String]
flags = runGhcMod GhcMod.defaultOptions $ (lines . nullToNL) <$> GhcMod.flags
info :: [String] -> PackageDbStack -> FilePath -> String -> GhcModT IO Declaration
info opts pdbs file sname = do
fileCts <- liftIO $ readFileUtf8 file
rs <- withOptions (\o -> o { GhcMod.optGhcUserOptions = packageDbStackOpts pdbs ++ opts }) $
liftM nullToNL $ GhcMod.info file (GhcMod.Expression sname)
toDecl fileCts rs
where
toDecl fstr s =
liftM (recalcDeclTabs fstr) .
maybe (throwError $ GhcMod.GMEString $ "Can't parse info: '" ++ sname ++ "'") return $
parseData s `mplus` parseFunction s
recalcDeclTabs :: String -> Declaration -> Declaration
recalcDeclTabs fstr = over (declarationPosition . _Just) (recalcTabs fstr 8)
parseFunction s = do
groups <- matchRx (sname ++ "\\s+::\\s+(.*?)(\\s+-- Defined (at (.*)|in `(.*)'))?$") s
return (decl (fromString sname) (Function (Just $ fromString $ groups `at` 1) [] Nothing)) {
_declarationDefined = unnamedModuleId <$>
((groups 4 >>= parseSrc) <|> (mkMod <$> groups 5)),
_declarationPosition = groups 4 >>= parsePos }
parseData s = do
groups <- matchRx "(newtype|type|data)\\s+((.*)=>\\s+)?(\\S+)\\s+((\\w+\\s+)*)=(\\s*(.*)\\s+-- Defined (at (.*)|in `(.*)'))?" s
let
args = maybe [] (map fromString . words) $ groups 5
ctx = fmap (fromString . trim) $ groups 3
def = fmap fromString $ groups 8
return (decl (fromString sname) (declarationTypeCtor (groups `at` 1) $ TypeInfo ctx args def [])) {
_declarationDefined = unnamedModuleId <$>
((groups 10 >>= parseSrc) <|> (mkMod <$> groups 11)),
_declarationPosition = groups 10 >>= parsePos }
parseSrc src = case splitRx ":(?=\\d)" src of
[srcFile, _, _] -> Just $ FileModule srcFile Nothing
_ -> Nothing
parsePos src = case splitRx ":(?=\\d)" src of
[_, line, column] -> Position <$> readMaybe line <*> readMaybe column
_ -> Nothing
mkMod = InstalledModule (topPackageDb pdbs) Nothing
trim = p . p where
p = reverse . dropWhile isSpace
data TypedRegion = TypedRegion {
typedRegion :: Region,
typedExpr :: String,
typedType :: String }
deriving (Eq, Ord, Read, Show)
instance NFData TypedRegion where
rnf (TypedRegion r e t) = rnf r `seq` rnf e `seq` rnf t
instance ToJSON TypedRegion where
toJSON (TypedRegion r e t) = object [
"region" .= r,
"expr" .= e,
"type" .= t]
instance FromJSON TypedRegion where
parseJSON = withObject "typed region" $ \v -> TypedRegion <$>
v .:: "region" <*>
v .:: "expr" <*>
v .:: "type"
typeOf :: [String] -> PackageDbStack -> FilePath -> Int -> Int -> GhcModT IO [TypedRegion]
typeOf opts pdbs file line col = withOptions (\o -> o { GhcMod.optGhcUserOptions = packageDbStackOpts pdbs ++ opts }) $ do
fileCts <- liftIO $ readFileUtf8 file
let
Position line' col' = calcTabs fileCts 8 (Position line col)
ts <- lines <$> GhcMod.types file line' col'
return $ mapMaybe (toRegionType fileCts) ts
where
toRegionType :: String -> String -> Maybe TypedRegion
toRegionType fstr s = do
(r, tp) <- parseRead s $ (,) <$> parseRegion fstr <*> readParse
return $ TypedRegion r (regionStr r fstr) tp
parseRegion :: String -> ReadM Region
parseRegion fstr = Region <$> parsePosition fstr <*> parsePosition fstr
parsePosition :: String -> ReadM Position
parsePosition fstr = recalcTabs fstr 8 <$> (Position <$> readParse <*> readParse)
parseOutputMessages :: String -> [Note OutputMessage]
parseOutputMessages = mapMaybe parseOutputMessage . lines
parseOutputMessage :: String -> Maybe (Note OutputMessage)
parseOutputMessage s = do
groups <- matchRx "^(.+):(\\d+):(\\d+):(\\s*(Warning|Error):)?\\s*(.*)$" s
l <- readMaybe (groups `at` 2)
c <- readMaybe (groups `at` 3)
return Note {
_noteSource = FileModule (normalise (groups `at` 1)) Nothing,
_noteRegion = regionAt (Position l c),
_noteLevel = Just $ if groups 5 == Just "Warning" then Warning else Error,
_note = outputMessage $ nullToNL (groups `at` 6) }
recalcOutputMessageTabs :: [(FilePath, String)] -> Note OutputMessage -> Note OutputMessage
recalcOutputMessageTabs fileCts n = fromMaybe n $ do
src <- preview (noteSource . moduleFile) n
cts <- lookup src fileCts
return $ recalcTabs cts 8 n
nullToNL :: String -> String
nullToNL = map $ \case
'\0' -> '\n'
ch -> ch
check :: [String] -> PackageDbStack -> [FilePath] -> Maybe Project -> GhcModT IO [Note OutputMessage]
check opts pdbs files _ = do
cts <- liftIO $ mapM readFileUtf8 files
withOptions (\o -> o { GhcMod.optGhcUserOptions = packageDbStackOpts pdbs ++ opts }) $ do
res <- GhcMod.checkSyntax files
return $ map (recalcOutputMessageTabs (zip files cts)) $ parseOutputMessages res
lint :: [String] -> FilePath -> GhcModT IO [Note OutputMessage]
lint opts file = do
cts <- liftIO $ readFileUtf8 file
res <- GhcMod.lint (GhcMod.defaultLintOpts { GhcMod.optLintHlintOpts = opts }) file
return $ map (recalcOutputMessageTabs [(file, cts)]) $ parseOutputMessages res
gmOut :: IO GhcMod.GhcModOut
gmOut = do
ch <- newChan
return GhcMod.GhcModOut {
GhcMod.gmoOptions = GhcMod.OutputOpts {
GhcMod.ooptLogLevel = GhcMod.GmSilent,
GhcMod.ooptStyle = GhcMod.PlainStyle,
GhcMod.ooptLineSeparator = GhcMod.LineSeparator "\0",
GhcMod.ooptLinePrefix = Nothing },
GhcMod.gmoChan = ch }
runGhcMod :: (GhcMod.IOish m, MonadCatch m) => GhcMod.Options -> GhcModT m a -> ExceptT String m a
runGhcMod opts act = do
out <- liftIO gmOut
cur <- liftIO getCurrentDirectory
liftIOErrors $ ExceptT $ liftM (left show . right fst . fst) $ flip runReaderT out $ GhcMod.unGmOutT $
GhcMod.withGhcModEnv cur opts $ \(env, _) ->
GhcMod.runGhcModT' env GhcMod.defaultGhcModState act
locateGhcModEnv :: FilePath -> IO (Either Project PackageDbStack)
locateGhcModEnv f = do
mproj <- locateProject f
maybe (liftM Right $ searchPackageDbStack f) (return . Left) mproj
ghcModEnvPath :: FilePath -> Either Project PackageDbStack -> FilePath
ghcModEnvPath defaultPath = either (view projectPath) (fromMaybe defaultPath . preview packageDb . topPackageDb)
ghcModWorker :: Either Project PackageDbStack -> IO (Worker (GhcModT IO))
ghcModWorker p = do
home <- getHomeDirectory
startWorker (runGhcModT'' $ ghcModEnvPath home p) id liftThrow
where
runGhcModT'' :: FilePath -> GhcModT IO () -> IO ()
runGhcModT'' cur act = void $ do
out <- gmOut
flip runReaderT out $
GhcMod.unGmOutT $
GhcMod.withGhcModEnv cur GhcMod.defaultOptions $ \(env, _) ->
GhcMod.runGhcModT' env GhcMod.defaultGhcModState (act `catchError` (void . return))
type WorkerMap = MVar (M.Map FilePath (Worker (GhcModT IO)))
ghcModMultiWorker :: IO (Worker (ReaderT WorkerMap IO))
ghcModMultiWorker = newMVar M.empty >>= \m -> startWorker (`runReaderT` m) id id
instance MonadThrow (GhcMod.GmOutT IO) where
throwM = lift . throwM
instance MonadCatch (GhcMod.GmOutT IO) where
catch = gcatch
instance MonadThrow (GhcModT IO) where
throwM = lift . throwM
instance MonadCatch (GhcModT IO) where
catch = gcatch
dispatch :: FilePath -> GhcModT IO a -> ReaderT WorkerMap IO (Async a)
dispatch file act = do
mvar <- ask
home <- liftIO getHomeDirectory
env' <- liftIO $ locateGhcModEnv file
let
envPath' = ghcModEnvPath home env'
liftIO $ modifyMVar mvar $ \wmap -> do
w <- maybe (ghcModWorker env') return $ M.lookup envPath' wmap
t <- pushTask w act
return (M.insert envPath' w wmap, t)
waitMultiGhcMod :: Worker (ReaderT WorkerMap IO) -> FilePath -> GhcModT IO a -> ExceptT String IO a
waitMultiGhcMod w f =
liftIO . pushTask w . dispatch f >=>
asExceptT . waitCatch >=>
asExceptT . waitCatch
where
asExceptT :: Monad m => m (Either SomeException a) -> ExceptT String m a
asExceptT = ExceptT . liftM (left (\(SomeException e) -> show e))