module IDE.ImportTool (
resolveErrors
, addOneImport
, addResolveMenuItems
, parseHiddenModule
, HiddenModuleResult(..)
) where
import IDE.Core.State
import Data.Maybe
(mapMaybe, fromMaybe, catMaybes, fromJust, isNothing, isJust)
import IDE.Metainfo.Provider
(getWorkspaceInfo, getPackageImportInfo, getIdentifierDescr)
import Text.PrettyPrint (render)
import Distribution.Text (simpleParse, display, disp)
import IDE.Pane.SourceBuffer
import IDE.HLint (resolveActiveHLint)
import Graphics.UI.Gtk
import IDE.Utils.GUIUtils
import Text.ParserCombinators.Parsec.Language (haskellStyle)
import Graphics.UI.Editor.MakeEditor
(getRealWidget, FieldDescription(..), buildEditor, mkField)
import Graphics.UI.Editor.Parameters
((<<<-), paraMinSize, emptyParams, Parameter(..), paraMultiSel,
paraName)
import Text.ParserCombinators.Parsec hiding (parse)
import qualified Text.ParserCombinators.Parsec as Parsec (parse)
import Graphics.UI.Editor.Simple (staticListEditor)
import Control.Monad (void, MonadPlus(..), unless, forM, when)
import Control.Applicative ((<$>))
import Data.List (stripPrefix, sort, nub, nubBy)
import IDE.Utils.ServerConnection
import Text.PrinterParser (prettyPrint)
import IDE.TextEditor (delete, setModified, insert, getIterAtLine)
import qualified Distribution.ModuleName as D (ModuleName(..))
import qualified Text.ParserCombinators.Parsec.Token as P
(operator, dot, identifier, symbol, lexeme, whiteSpace,
makeTokenParser)
import Distribution.PackageDescription.Parse
(readPackageDescription)
import Distribution.Verbosity (normal)
import IDE.Pane.PackageEditor (hasConfigs)
import Distribution.Package
import Distribution.Version
(anyVersion, orLaterVersion, intersectVersionRanges,
earlierVersion, Version(..))
import Distribution.PackageDescription
(GenericPackageDescription(..), Benchmark(..), TestSuite(..),
Executable(..), BuildInfo(..), Library(..), CondTree(..),
condExecutables, condLibrary, packageDescription, buildDepends)
import Distribution.PackageDescription.Configuration
(flattenPackageDescription)
import IDE.BufferMode (editInsertCode)
import Control.Monad.IO.Class (MonadIO(..))
import Distribution.PackageDescription.PrettyPrint
(writeGenericPackageDescription)
import qualified Data.Text as T
(takeWhile, stripPrefix, lines, dropWhile, empty, length, take,
pack, unpack)
import Language.Haskell.Exts (KnownExtension)
import Data.Text (Text)
import Data.Monoid ((<>))
readMaybe :: Read a => Text -> Maybe a
readMaybe s = case reads $ T.unpack s of
[(x, "")] -> Just x
_ -> Nothing
resolveErrors :: IDEAction
resolveErrors = do
prefs' <- readIDE prefs
let buildInBackground = backgroundBuild prefs'
when buildInBackground $
modifyIDE_ (\ide -> ide{prefs = prefs'{backgroundBuild = False}})
errors <- readIDE errorRefs
addPackageResults <- forM errors addPackage
let notInScopes = [ y | (x,y) <-
nubBy (\ (p1,_) (p2,_) -> p1 == p2)
[(x,y) | (x,y) <- [((parseNotInScope . refDescription) e, e) | e <- errors]],
isJust x]
let extensions = [ y | (x,y) <-
nubBy (\ (p1,_) (p2,_) -> p1 == p2)
[(x,y) | (x,y) <- [((parsePerhapsYouIntendedToUse . refDescription) e, e) | e <- errors]],
length x == 1]
when (not (or addPackageResults) && null notInScopes && null extensions) $ do
hlintResolved <- resolveActiveHLint
unless hlintResolved $ ideMessage Normal "No errors, warnings or selected hlints that can be auto resolved"
addAll buildInBackground notInScopes extensions
where
addAll buildInBackground notInScopes extensions = addAllImports notInScopes (True,[])
where
addAllImports :: [LogRef] -> (Bool,[Descr]) -> IDEM ()
addAllImports (errorSpec:rest) (True,descrList) = addImport errorSpec descrList (addAllImports rest)
addAllImports _ (cont, _) = addAllExtensions extensions cont
addAllExtensions :: [LogRef] -> Bool -> IDEM ()
addAllExtensions (errorSpec:rest) True = addExtension errorSpec (addAllExtensions rest)
addAllExtensions _ _ = finally
finally = when buildInBackground $ do
prefs' <- readIDE prefs
modifyIDE_ (\ide -> ide{prefs = prefs'{backgroundBuild = True}})
addOneImport :: IDEAction
addOneImport = do
errors' <- readIDE errorRefs
currentErr' <- readIDE currentError
case currentErr' of
Nothing -> do
ideMessage Normal "No error selected"
return ()
Just ref -> addImport ref [] (\ _ -> return ())
addImport :: LogRef -> [Descr] -> ((Bool,[Descr]) -> IDEAction) -> IDEAction
addImport error descrList continuation =
case parseNotInScope $ refDescription error of
Nothing -> continuation (True,descrList)
Just nis -> do
currentInfo' <- getScopeForActiveBuffer
wsInfo' <- getWorkspaceInfo
case (currentInfo', wsInfo') of
(Nothing, _) -> continuation (True,descrList)
(_, Nothing) -> continuation (True,descrList)
(Just (GenScopeC(PackScope _ symbolTable1),GenScopeC(PackScope _ symbolTable2)),
Just (GenScopeC(PackScope _ symbolTable3),GenScopeC(PackScope _ symbolTable4))) ->
let list = getIdentifierDescr (id' nis) symbolTable1 symbolTable2
wslist = getIdentifierDescr (id' nis) symbolTable3 symbolTable4
in case (list, wslist) of
([], []) -> do
ideMessage Normal $ "Identifier " <> id' nis <> " not found"
continuation (True, descrList)
([], list) -> do
window' <- getMainWindow
mbDescr <- liftIO $ selectModuleDialog window' list (id' nis) (mbQual' nis)
(if null descrList
then Nothing
else Just (head descrList))
case mbDescr of
Nothing -> continuation (False, [])
Just descr -> if descr `elem` descrList
then continuation (True,descrList)
else addImport' nis (logRefFullFilePath error)
descr descrList continuation
([descr], _) -> addImport' nis (logRefFullFilePath error) descr descrList continuation
_ -> do
let fullList = list ++ wslist
window' <- getMainWindow
mbDescr <- liftIO $ selectModuleDialog window' fullList (id' nis) (mbQual' nis)
(if null descrList
then Nothing
else Just (head descrList))
case mbDescr of
Nothing -> continuation (False, [])
Just descr -> if descr `elem` descrList
then continuation (True,descrList)
else addImport' nis (logRefFullFilePath error)
descr descrList continuation
addPackage :: LogRef -> IDEM Bool
addPackage error =
case parseHiddenModule $ refDescription error of
Nothing -> return False
Just (HiddenModuleResult mod pack) -> do
let idePackage = logRefPackage error
gpd <- liftIO $ readPackageDescription normal (ipdCabalFile idePackage)
ideMessage Normal $ "addPackage " <> (T.pack . display $ pkgName pack)
liftIO $ writeGenericPackageDescription (ipdCabalFile idePackage)
gpd { condLibrary = addDepToLib pack (condLibrary gpd),
condExecutables = map (addDepToExe pack)
(condExecutables gpd),
condTestSuites = map (addDepToTest pack)
(condTestSuites gpd),
condBenchmarks = map (addDepToBenchmark pack)
(condBenchmarks gpd)}
return True
where
addDepToLib _ Nothing = Nothing
addDepToLib p (Just cn@CondNode{
condTreeConstraints = deps,
condTreeData = lib@Library{libBuildInfo = bi}}) = Just (cn{
condTreeConstraints = deps <> [dep p],
condTreeData = lib {libBuildInfo = bi {targetBuildDepends = targetBuildDepends bi <> [dep p]}}})
addDepToExe p (str,cn@CondNode{
condTreeConstraints = deps,
condTreeData = exe@Executable{buildInfo = bi}}) = (str,cn{
condTreeConstraints = deps <> [dep p],
condTreeData = exe { buildInfo = bi {targetBuildDepends = targetBuildDepends bi <> [dep p]}}})
addDepToTest p (str,cn@CondNode{
condTreeConstraints = deps,
condTreeData = test@TestSuite{testBuildInfo = bi}}) = (str,cn{
condTreeConstraints = deps <> [dep p],
condTreeData = test { testBuildInfo = bi {targetBuildDepends = targetBuildDepends bi <> [dep p]}}})
addDepToBenchmark p (str,cn@CondNode{
condTreeConstraints = deps,
condTreeData = bm@Benchmark{benchmarkBuildInfo = bi}}) = (str,cn{
condTreeConstraints = deps <> [dep p],
condTreeData = bm { benchmarkBuildInfo = bi {targetBuildDepends = targetBuildDepends bi <> [dep p]}}})
dep p | null . versionBranch $ packageVersion p = Dependency (packageName p) anyVersion
dep p = Dependency (packageName p) (
intersectVersionRanges (orLaterVersion (packageVersion p))
(earlierVersion (majorAndMinor (packageVersion p))))
majorAndMinor v@Version{versionBranch = b} = v{versionBranch = nextMinor b}
nextMinor = nextMinor' . (++[0,0])
nextMinor' (major:minor:_) = [major, minor+1]
nextMinor' _ = undefined
getScopeForActiveBuffer :: IDEM (Maybe (GenScope, GenScope))
getScopeForActiveBuffer = do
mbActiveBuf <- maybeActiveBuf
case mbActiveBuf of
Nothing -> return Nothing
Just buf -> do
packages <- belongsToPackages buf
case packages of
[] -> return Nothing
pack:_ -> getPackageImportInfo pack
addImport' :: NotInScopeParseResult -> FilePath -> Descr -> [Descr] -> ((Bool,[Descr]) -> IDEAction) -> IDEAction
addImport' nis filePath descr descrList continuation = do
mbBuf <- selectSourceBuf filePath
let mbMod = case dsMbModu descr of
Nothing -> Nothing
Just pm -> Just (modu pm)
case (mbBuf,mbMod) of
(Just buf,Just mod) ->
inActiveBufContext () $ \ nb _ gtkbuf idebuf n -> do
ideMessage Normal $ "addImport " <> T.pack (show $ dscName descr) <> " from "
<> T.pack (render $ disp mod)
doServerCommand (ParseHeaderCommand filePath) $ \ res ->
case res of
ServerHeader (Left imports) ->
case filter (qualifyAsImportStatement mod) imports of
[] -> let newLine = prettyPrint (newImpDecl mod) <> "\n"
lastLine = foldr (max . locationELine . importLoc) 0 imports
in do
i1 <- getIterAtLine gtkbuf lastLine
editInsertCode gtkbuf i1 newLine
fileSave False
setModified gtkbuf True
continuation (True, descr : descrList)
l@(impDecl:_) ->
let newDecl = addToDecl impDecl
newLine = prettyPrint newDecl <> "\n"
myLoc = importLoc impDecl
lineStart = locationSLine myLoc
lineEnd = locationELine myLoc
in do
i1 <- getIterAtLine gtkbuf (lineStart 1)
i2 <- getIterAtLine gtkbuf lineEnd
delete gtkbuf i1 i2
editInsertCode gtkbuf i1 newLine
fileSave False
setModified gtkbuf True
continuation (True, descr : descrList)
ServerHeader (Right lastLine) ->
let newLine = prettyPrint (newImpDecl mod) <> "\n"
in do
i1 <- getIterAtLine gtkbuf lastLine
editInsertCode gtkbuf i1 newLine
fileSave False
setModified gtkbuf True
continuation (True, descr : descrList)
ServerFailed string -> do
ideMessage Normal ("Can't parse module header " <> T.pack filePath <>
" failed with: " <> string)
continuation (False,[])
_ -> do
ideMessage Normal "ImportTool>>addImport: Impossible server answer"
continuation (False,[])
_ -> return ()
where
qualifyAsImportStatement :: D.ModuleName -> ImportDecl -> Bool
qualifyAsImportStatement moduleName impDecl =
let importName = importModule impDecl
getHiding (ImportSpecList isHiding _) = isHiding
in importName == T.pack (display moduleName)
&& ((isNothing (mbQual' nis) && not (importQualified impDecl)) ||
(isJust (mbQual' nis) && importQualified impDecl
&& fromJust (mbQual' nis) == qualString impDecl))
&& (isNothing (importSpecs impDecl) || not (getHiding (fromJust (importSpecs impDecl))))
newImpDecl :: D.ModuleName -> ImportDecl
newImpDecl mod = ImportDecl {
importLoc = noLocation,
importModule = T.pack $ display mod,
importQualified = isJust (mbQual' nis),
importSrc = False,
importPkg = Nothing,
importAs = mplus (mbQual' nis) Nothing,
importSpecs = Just (ImportSpecList False [newImportSpec])}
newImportSpec :: ImportSpec
newImportSpec = getRealId descr (id' nis)
addToDecl :: ImportDecl -> ImportDecl
addToDecl impDecl = case importSpecs impDecl of
Just (ImportSpecList True listIE) -> throwIDE "ImportTool>>addToDecl: ImpList is hiding"
Just (ImportSpecList False listIE) ->
impDecl{importSpecs = Just (ImportSpecList False (nub (newImportSpec : listIE)))}
Nothing ->
impDecl{importSpecs = Just (ImportSpecList False [newImportSpec])}
noLocation = Location "" 0 0 0 0
getRealId descr id = case descr of
Reexported rdescr -> getRealId (dsrDescr rdescr) id
Real edescr -> getReal (dscTypeHint' edescr)
where
getReal (FieldDescr d) = IThingAll (dscName d)
getReal (ConstructorDescr d) = IThingAll (dscName d)
getReal (MethodDescr d) = IThingAll (dscName d)
getReal _ = IVar id
qualString :: ImportDecl -> Text
qualString impDecl = fromMaybe "" (importAs impDecl)
data NotInScopeParseResult = NotInScopeParseResult {
mbQual' :: Maybe Text
, id' :: Text
, isSub' :: Bool
, isOp' :: Bool}
deriving Eq
lexer = P.makeTokenParser haskellStyle
whiteSpace = P.whiteSpace lexer
lexeme = (T.pack <$>) . P.lexeme lexer
symbol = P.symbol lexer
identifier = T.pack <$> P.identifier lexer
dot = P.dot lexer
operator = T.pack <$> P.operator lexer
parseNotInScope :: Text -> Maybe NotInScopeParseResult
parseNotInScope str =
case Parsec.parse scopeParser "" $ T.unpack str of
Left e -> Nothing
Right r -> Just r
scopeParser :: CharParser () NotInScopeParseResult
scopeParser = do whiteSpace
symbol "Not in scope:"
isSub <- optionMaybe
(try
(choice
[symbol "type constructor or class", symbol "data constructor"]))
(do char '`'
mbQual <- optionMaybe
(try
(do q <- lexeme conid
dot
return q))
id <- optionMaybe (try identifier)
case id of
Just id -> return
(NotInScopeParseResult mbQual (T.take (T.length id 1) id)
(isJust isSub)
False)
Nothing -> do op <- operator
char '\''
return (NotInScopeParseResult mbQual op (isJust isSub) True))
<|>
(do choice [char '\8219', char '\8216']
mbQual <- optionMaybe
(try
(do q <- lexeme conid
dot
return q))
id <- optionMaybe (try identifier)
result <- case id of
Just id -> return
(NotInScopeParseResult mbQual id (isJust isSub) False)
Nothing -> do op <- operator
return (NotInScopeParseResult mbQual op (isJust isSub) True)
char '\8217'
return result)
<?> "scopeParser"
conid = do
c <- upper
cs <- many (alphaNum <|> oneOf "_'")
return (c:cs)
<?> "conid"
moduleFields :: [Text] -> Text -> FieldDescription Text
moduleFields list ident =
mkField
(paraName <<<- ParaName ("From which module is " <> ident)
$ paraMultiSel <<<- ParaMultiSel False
$ paraMinSize <<<- ParaMinSize (300,400)
$ emptyParams)
id
const
(staticListEditor list id)
selectModuleDialog :: Window -> [Descr] -> Text -> Maybe Text -> Maybe Descr -> IO (Maybe Descr)
selectModuleDialog parentWindow list id mbQual mbDescr =
let selectionList = (nub . sort) $ map (T.pack . render . disp . modu . fromJust . dsMbModu) list
in if length selectionList == 1
then return (Just (head list))
else do
let mbSelectedString = case mbDescr of
Nothing -> Nothing
Just descr -> case dsMbModu descr of
Nothing -> Nothing
Just pm -> Just ((T.pack . render . disp . modu) pm)
let realSelectionString = case mbSelectedString of
Nothing -> head selectionList
Just str -> if str `elem` selectionList
then str
else head selectionList
let qualId = case mbQual of
Nothing -> id
Just str -> str <> "." <> id
dia <- dialogNew
set dia [ windowTransientFor := parentWindow ]
#ifdef MIN_VERSION_gtk3
upper <- dialogGetContentArea dia
#else
upper <- dialogGetUpper dia
#endif
okButton <- dialogAddButton dia (__"Add Import") ResponseOk
dialogAddButton dia (__"Cancel") ResponseCancel
(widget,inj,ext,_) <- buildEditor (moduleFields selectionList qualId) realSelectionString
boxPackStart (castToBox upper) widget PackGrow 7
dialogSetDefaultResponse dia ResponseOk
widgetShowAll dia
rw <- getRealWidget widget
set okButton [widgetCanDefault := True]
widgetGrabDefault okButton
resp <- dialogRun dia
value <- ext T.empty
widgetHide dia
widgetDestroy dia
--find
case (resp,value) of
(ResponseOk,Just v) -> return (Just (head
(filter (\e -> case dsMbModu e of
Nothing -> False
Just pm -> (T.pack . render . disp . modu) pm == v) list)))
_ -> return Nothing
data HiddenModuleResult = HiddenModuleResult {
hiddenModule :: Text
, missingPackage :: PackageId}
deriving (Eq, Show)
parseHiddenModule :: Text -> Maybe HiddenModuleResult
parseHiddenModule str =
case Parsec.parse hiddenModuleParser "" $ T.unpack str of
Left e -> Nothing
Right (mod, pack) ->
case simpleParse $ T.unpack pack of
Just p -> Just $ HiddenModuleResult mod p
Nothing -> Nothing
hiddenModuleParser :: CharParser () (Text, Text)
hiddenModuleParser = do
whiteSpace
symbol "Could not find module "
char '`' <|> char '‛' <|> char '‘'
mod <- T.pack <$> many (noneOf "'’")
many (noneOf "\n")
symbol "\n"
whiteSpace
symbol "It is a member of the hidden package "
char '`' <|> char '‛' <|> char '‘'
pack <- T.pack <$> many (noneOf "'’@")
many (noneOf "'’")
char '\'' <|> char '’'
symbol ".\n"
many anyChar
return (mod, pack)
<?> "hiddenModuleParser"
parsePerhapsYouIntendedToUse :: Text -> [KnownExtension]
parsePerhapsYouIntendedToUse =
concatMap (parseLine . T.dropWhile (==' ')) . T.lines
where
parseLine :: Text -> [KnownExtension]
parseLine line = take 1 . mapMaybe readMaybe $ catMaybes [
T.stripPrefix "Perhaps you intended to use -X" line
, T.stripPrefix "Perhaps you intended to use " line
, T.takeWhile (/=' ') <$> T.stripPrefix "Use -X" line
, T.takeWhile (/=' ') <$> T.stripPrefix "Use " line
, T.takeWhile (/=' ') <$> T.stripPrefix "(Use -X" line
, T.takeWhile (/=' ') <$> T.stripPrefix "(Use " line
, T.takeWhile (/=' ') <$> T.stripPrefix "You need -X" line
, T.takeWhile (/=' ') <$> T.stripPrefix "You need " line]
addExtension :: LogRef -> (Bool -> IDEAction) -> IDEAction
addExtension error continuation =
case parsePerhapsYouIntendedToUse $ refDescription error of
[] -> continuation True
[ext] -> addExtension' (T.pack $ show ext) (logRefFullFilePath error) continuation
list -> continuation True
addExtension' :: Text -> FilePath -> (Bool -> IDEAction) -> IDEAction
addExtension' ext filePath continuation = do
mbBuf <- selectSourceBuf filePath
case mbBuf of
Just buf ->
inActiveBufContext () $ \ nb _ gtkbuf idebuf n -> do
ideMessage Normal $ "addExtension " <> ext
i1 <- getIterAtLine gtkbuf 0
editInsertCode gtkbuf i1 $ "{-# LANGUAGE " <> ext <> " #-}\n"
fileSave False
setModified gtkbuf True
continuation True
_ -> return ()
addResolveMenuItems ideR theMenu logRef = do
let msg = refDescription logRef
when (isJust $ parseNotInScope msg) $
addFixMenuItem (__"Add Import") $ addImport logRef [] (\ _ -> return ())
when (isJust $ parseHiddenModule msg) $
addFixMenuItem (__"Add Package") $ addPackage logRef
when (length (parsePerhapsYouIntendedToUse msg) == 1) $
addFixMenuItem (__"Add Extension") $ addExtension logRef (\ _ -> return ())
where
addFixMenuItem name fix = do
item <- menuItemNewWithLabel name
item `on` menuItemActivate $ reflectIDE (void fix) ideR
menuShellAppend theMenu item