Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Fixes the code that resolves module not found errors by adding packag…

…e dependancies to the .cabal file.
  • Loading branch information...
commit 2c8bd21bd6f976a0b5793b8cafb428a1eda6a47a 1 parent 335860e
@hamishmack hamishmack authored
Showing with 477 additions and 421 deletions.
  1. +8 −0 leksah.cabal
  2. +427 −421 src/IDE/ImportTool.hs
  3. +42 −0 tests/Tests.hs
View
8 leksah.cabal
@@ -204,6 +204,14 @@ Executable leksah
ghc-shared-options: -auto-all
ghc-options: -fwarn-missing-fields -fwarn-incomplete-patterns -ferror-spans
+test-suite tests
+ default-language: Haskell2010
+ type: exitcode-stdio-1.0
+ hs-source-dirs: tests
+ main-is: Tests.hs
+ build-depends: base >= 4.0.0.0 && <4.6, Cabal >=1.6.0.1 && <1.15, QuickCheck >=2.4.2 && <2.5,
+ leksah ==0.12.1.0
+
View
848 src/IDE/ImportTool.hs
@@ -1,426 +1,432 @@
{-# LANGUAGE CPP #-}
------------------------------------------------------------------------------
---
--- Module : IDE.ImportTool
--- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie
--- License : GPL
---
--- Maintainer : Jutaro <jutaro@leksah.org>
--- Stability : provisional
--- Portability :
---
--- | Help for constructing import statements
---
------------------------------------------------------------------------------
-
-module IDE.ImportTool (
- resolveErrors
-, addOneImport
-, addImport
-, addPackage
-, parseNotInScope
+-----------------------------------------------------------------------------
+--
+-- Module : IDE.ImportTool
+-- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie
+-- License : GPL
+--
+-- Maintainer : Jutaro <jutaro@leksah.org>
+-- Stability : provisional
+-- Portability :
+--
+-- | Help for constructing import statements
+--
+-----------------------------------------------------------------------------
+
+module IDE.ImportTool (
+ resolveErrors
+, addOneImport
+, addImport
+, addPackage
+, parseNotInScope
, parseHiddenModule
-) where
-
-import IDE.Core.State
-import Data.Maybe (isNothing,isJust)
-import IDE.Metainfo.Provider
- (getPackageImportInfo, getIdentifierDescr)
-import Text.PrettyPrint (render)
-import Distribution.Text (simpleParse, display, disp)
-import IDE.Pane.SourceBuffer
-import Graphics.UI.Gtk
-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 Data.Maybe (fromJust)
-import Text.ParserCombinators.Parsec hiding (parse)
-import qualified Text.ParserCombinators.Parsec as Parsec (parse)
-import Graphics.UI.Editor.Simple (staticListEditor)
-import Control.Monad (forM, when)
-import Data.List (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)
-import Distribution.PackageDescription
- (CondTree(..), condExecutables, condLibrary, packageDescription,
- buildDepends)
-import Distribution.PackageDescription.Configuration
- (flattenPackageDescription)
-import IDE.BufferMode (editInsertCode)
-import Control.Monad.IO.Class (MonadIO(..))
-#if MIN_VERSION_Cabal(1,10,0)
-import Distribution.PackageDescription.PrettyPrintCopied
- (writeGenericPackageDescription)
-#else
-import Distribution.PackageDescription.Parse
- (writePackageDescription)
-import Distribution.PackageDescription
- (CondTree(..))
-#endif
-
--- | Add all imports which gave error messages ...
-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]
- when (not (or addPackageResults) && null notInScopes) $ ideMessage Normal $ "No errors that can be auto resolved"
- addAll buildInBackground notInScopes (True,[])
- where
- addAll :: Bool -> [LogRef] -> (Bool,[Descr]) -> IDEM ()
- addAll bib (errorSpec:rest) (True,descrList) = addImport errorSpec descrList (addAll bib rest)
- addAll bib _ _ = finally bib
-
- finally buildInBackground = when buildInBackground $ do
- prefs' <- readIDE prefs
- modifyIDE_ (\ide -> ide{prefs = prefs'{backgroundBuild = True}})
-
--- | Add import for current error ...
-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 ())
-
--- | Add one missing import
--- Returns a boolean, if the process should be stopped in case of multiple addition
--- Returns a list of already added descrs, so that it will not be added two times and can
--- be used for default selection
-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
- case currentInfo' of
- Nothing -> continuation (True,descrList)
- Just (GenScopeC(PackScope _ symbolTable1),GenScopeC(PackScope _ symbolTable2)) ->
- let list = getIdentifierDescr (id' nis) symbolTable1 symbolTable2
- in case list of
- [] -> do
- ideMessage Normal $ "Identifier " ++ (id' nis) ++
- " not found in imported packages"
- continuation (True, descrList)
- descr : [] -> addImport' nis (logRefFullFilePath error) descr descrList continuation
- 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 elem descr descrList
- then continuation (True,descrList)
- else addImport' nis (logRefFullFilePath error)
- descr descrList continuation
-
-addPackage :: LogRef -> IDEM Bool
-addPackage error = do
- 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 " ++ (display $ pkgName pack)
-#if MIN_VERSION_Cabal(1,10,0)
- liftIO $ writeGenericPackageDescription (ipdCabalFile $ idePackage)
- gpd { condLibrary = addDepToLib (packageName pack) (condLibrary gpd),
- condExecutables = map (addDepToExe (packageName pack))
- (condExecutables gpd)}
- return True
-#else
- if hasConfigs gpd
- then return False
- else do
- let flat = flattenPackageDescription gpd
- liftIO $ writePackageDescription (ipdCabalFile $ idePackage)
- flat { buildDepends =
- Dependency (pkgName pack) anyVersion : buildDepends flat}
- return True
-#endif
- where
- addDepToLib n Nothing = Nothing
- addDepToLib n (Just cn@CondNode{condTreeConstraints = deps}) =
- Just (cn{condTreeConstraints = (Dependency n anyVersion) : deps})
- addDepToExe n (str,cn@CondNode{condTreeConstraints = deps}) =
- (str,cn{condTreeConstraints = (Dependency n anyVersion) : deps})
-
-getScopeForActiveBuffer :: IDEM (Maybe (GenScope, GenScope))
-getScopeForActiveBuffer = do
- mbActiveBuf <- maybeActiveBuf
- case mbActiveBuf of
- Nothing -> return Nothing
- Just buf -> do
- mbPackage <- belongsToPackage buf
- case mbPackage of
- Nothing -> return Nothing
- Just 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) -> do
- inActiveBufContext () $ \ nb gtkbuf idebuf n -> do
- ideMessage Normal $ "addImport " ++ show (dscName descr) ++ " from "
- ++ (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 0 (map (locationELine . importLoc) 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 " ++ 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 == 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 = display mod,
- importQualified = isJust (mbQual' nis),
- importSrc = False,
- importPkg = Nothing,
- importAs = if isJust (mbQual' nis)
- then Just (fromJust (mbQual' nis))
- else 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 -> String
-qualString impDecl = case importAs impDecl of
- Nothing -> ""
- Just modName -> modName
-
--- | The import data
-
-data NotInScopeParseResult = NotInScopeParseResult {
- mbQual' :: Maybe String
- , id' :: String
- , isSub' :: Bool
- , isOp' :: Bool}
- deriving Eq
-
--- |* The error line parser
-
-lexer = P.makeTokenParser haskellStyle
-whiteSpace = P.whiteSpace lexer
-lexeme = P.lexeme lexer
-symbol = P.symbol lexer
-identifier = P.identifier lexer
-dot = P.dot lexer
-operator = P.operator lexer
-
-parseNotInScope :: String -> (Maybe NotInScopeParseResult)
-parseNotInScope str =
- case Parsec.parse scopeParser "" 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"]))
- symbol "`"
- mbQual <- optionMaybe (try (do
- q <- lexeme conid
- dot
- return q))
- id <- optionMaybe (try identifier)
- case id of
- Just id -> return (NotInScopeParseResult mbQual
- (take (length id - 1) id) (isJust isSub) False)
- Nothing -> do
- op <- operator
- symbol "'"
- return (NotInScopeParseResult mbQual op (isJust isSub) True)
- <?> "scopeParser"
-
-conid = do
- c <- upper
- cs <- many (alphaNum <|> oneOf "_'")
- return (c:cs)
- <?> "conid"
-
-
--- |* The little dialog to choose between possible modules
-
-moduleFields :: [String] -> String -> FieldDescription String
-moduleFields list ident =
- mkField
- (paraName <<<- ParaName ("From which module is " ++ ident)
- $ paraMultiSel <<<- ParaMultiSel False
- $ paraMinSize <<<- ParaMinSize (300,400)
- $ emptyParams)
- (\ a -> a)
- (\ a b -> a)
- (staticListEditor ( list) id)
-
-selectModuleDialog :: Window -> [Descr] -> String -> Maybe String -> Maybe Descr -> IO (Maybe Descr)
-selectModuleDialog parentWindow list id mbQual mbDescr =
- let selectionList = (nub . sort) $ map (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 ((render . disp . modu) pm)
- let realSelectionString = case mbSelectedString of
- Nothing -> head selectionList
- Just str -> if elem str selectionList
- then str
- else head selectionList
- let qualId = case mbQual of
- Nothing -> id
- Just str -> str ++ "." ++ id
- dia <- dialogNew
- windowSetTransientFor dia parentWindow
- upper <- dialogGetUpper dia
- okButton <- dialogAddButton dia "Ok" ResponseOk
- dialogAddButton dia "Cancel" ResponseCancel
- (widget,inj,ext,_) <- buildEditor (moduleFields selectionList qualId) realSelectionString
- boxPackStart upper widget PackGrow 7
- dialogSetDefaultResponse dia ResponseOk --does not work for the tree view
- widgetShowAll dia
- rw <- getRealWidget widget
- set okButton [widgetCanDefault := True]
- widgetGrabDefault okButton
- resp <- dialogRun dia
- value <- ext ([])
- 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 -> (render . disp . modu) pm == v) list)))
- _ -> return Nothing
-
---testString = " Could not find module `Graphics.UI.Gtk':\n"
--- ++ " It is a member of the hidden package `gtk-0.11.0'.\n"
--- ++ " Perhaps you need to add `gtk' to the build-depends in your .cabal file.\n"
--- ++ " Use -v to see a list of the files searched for."
---
---test = parseHiddenModule testString == Just (HiddenModuleResult {hiddenModule = "Graphics.UI.Gtk", missingPackage = PackageIdentifier {pkgName = PackageName "gtk", pkgVersion = Version {versionBranch = [0,11,0], versionTags = []}}})
-
-data HiddenModuleResult = HiddenModuleResult {
- hiddenModule :: String
- , missingPackage :: PackageId}
- deriving (Eq, Show)
+, HiddenModuleResult(..)
+) where
+
+import IDE.Core.State
+import Data.Maybe (isNothing,isJust)
+import IDE.Metainfo.Provider
+ (getPackageImportInfo, getIdentifierDescr)
+import Text.PrettyPrint (render)
+import Distribution.Text (simpleParse, display, disp)
+import IDE.Pane.SourceBuffer
+import Graphics.UI.Gtk
+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 Data.Maybe (fromJust)
+import Text.ParserCombinators.Parsec hiding (parse)
+import qualified Text.ParserCombinators.Parsec as Parsec (parse)
+import Graphics.UI.Editor.Simple (staticListEditor)
+import Control.Monad (forM, when)
+import Data.List (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
+ (CondTree(..), condExecutables, condLibrary, packageDescription,
+ buildDepends)
+import Distribution.PackageDescription.Configuration
+ (flattenPackageDescription)
+import IDE.BufferMode (editInsertCode)
+import Control.Monad.IO.Class (MonadIO(..))
+#if MIN_VERSION_Cabal(1,10,0)
+import Distribution.PackageDescription.PrettyPrintCopied
+ (writeGenericPackageDescription)
+#else
+import Distribution.PackageDescription.Parse
+ (writePackageDescription)
+import Distribution.PackageDescription
+ (CondTree(..))
+#endif
+
+-- | Add all imports which gave error messages ...
+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]
+ when (not (or addPackageResults) && null notInScopes) $ ideMessage Normal $ "No errors that can be auto resolved"
+ addAll buildInBackground notInScopes (True,[])
+ where
+ addAll :: Bool -> [LogRef] -> (Bool,[Descr]) -> IDEM ()
+ addAll bib (errorSpec:rest) (True,descrList) = addImport errorSpec descrList (addAll bib rest)
+ addAll bib _ _ = finally bib
+
+ finally buildInBackground = when buildInBackground $ do
+ prefs' <- readIDE prefs
+ modifyIDE_ (\ide -> ide{prefs = prefs'{backgroundBuild = True}})
+
+-- | Add import for current error ...
+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 ())
+
+-- | Add one missing import
+-- Returns a boolean, if the process should be stopped in case of multiple addition
+-- Returns a list of already added descrs, so that it will not be added two times and can
+-- be used for default selection
+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
+ case currentInfo' of
+ Nothing -> continuation (True,descrList)
+ Just (GenScopeC(PackScope _ symbolTable1),GenScopeC(PackScope _ symbolTable2)) ->
+ let list = getIdentifierDescr (id' nis) symbolTable1 symbolTable2
+ in case list of
+ [] -> do
+ ideMessage Normal $ "Identifier " ++ (id' nis) ++
+ " not found in imported packages"
+ continuation (True, descrList)
+ descr : [] -> addImport' nis (logRefFullFilePath error) descr descrList continuation
+ 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 elem descr descrList
+ then continuation (True,descrList)
+ else addImport' nis (logRefFullFilePath error)
+ descr descrList continuation
+
+addPackage :: LogRef -> IDEM Bool
+addPackage error = do
+ 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 " ++ (display $ pkgName pack)
+#if MIN_VERSION_Cabal(1,10,0)
+ liftIO $ writeGenericPackageDescription (ipdCabalFile $ idePackage)
+ gpd { condLibrary = addDepToLib pack (condLibrary gpd),
+ condExecutables = map (addDepToExe pack)
+ (condExecutables gpd)}
+ return True
+#else
+ if hasConfigs gpd
+ then return False
+ else do
+ let flat = flattenPackageDescription gpd
+ liftIO $ writePackageDescription (ipdCabalFile $ idePackage)
+ flat { buildDepends = dep pack : buildDepends flat}
+ return True
+#endif
+ where
+ addDepToLib _ Nothing = Nothing
+ addDepToLib p (Just cn@CondNode{condTreeConstraints = deps}) =
+ Just (cn{condTreeConstraints = dep p : deps})
+ addDepToExe p (str,cn@CondNode{condTreeConstraints = deps}) =
+ (str,cn{condTreeConstraints = dep p : deps})
+ -- Empty version is probably only going to happen for ghc-prim
+ dep p | null . versionBranch $ packageVersion p = Dependency (packageName p) (anyVersion)
+ dep p = Dependency (packageName p) (
+ intersectVersionRanges (orLaterVersion (packageVersion p))
+ (earlierVersion (majorAndMinor (packageVersion p))))
-parseHiddenModule :: String -> (Maybe HiddenModuleResult)
-parseHiddenModule str =
- case Parsec.parse hiddenModuleParser "" str of
- Left e -> Nothing
- Right (mod, pack) ->
- case simpleParse pack of
- Just p -> Just $ HiddenModuleResult mod p
- Nothing -> Nothing
+ majorAndMinor v@Version{versionBranch = b} = v{versionBranch = nextMinor b}
+ nextMinor = nextMinor' . (++[0,0])
+ nextMinor' (major:minor:_) = [major, minor+1]
+ nextMinor' _ = undefined
-hiddenModuleParser :: CharParser () (String, String)
-hiddenModuleParser = do
- whiteSpace
- symbol "Could not find module `"
+getScopeForActiveBuffer :: IDEM (Maybe (GenScope, GenScope))
+getScopeForActiveBuffer = do
+ mbActiveBuf <- maybeActiveBuf
+ case mbActiveBuf of
+ Nothing -> return Nothing
+ Just buf -> do
+ mbPackage <- belongsToPackage buf
+ case mbPackage of
+ Nothing -> return Nothing
+ Just 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) -> do
+ inActiveBufContext () $ \ nb gtkbuf idebuf n -> do
+ ideMessage Normal $ "addImport " ++ show (dscName descr) ++ " from "
+ ++ (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 0 (map (locationELine . importLoc) 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 " ++ 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 == 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 = display mod,
+ importQualified = isJust (mbQual' nis),
+ importSrc = False,
+ importPkg = Nothing,
+ importAs = if isJust (mbQual' nis)
+ then Just (fromJust (mbQual' nis))
+ else 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 -> String
+qualString impDecl = case importAs impDecl of
+ Nothing -> ""
+ Just modName -> modName
+
+-- | The import data
+
+data NotInScopeParseResult = NotInScopeParseResult {
+ mbQual' :: Maybe String
+ , id' :: String
+ , isSub' :: Bool
+ , isOp' :: Bool}
+ deriving Eq
+
+-- |* The error line parser
+
+lexer = P.makeTokenParser haskellStyle
+whiteSpace = P.whiteSpace lexer
+lexeme = P.lexeme lexer
+symbol = P.symbol lexer
+identifier = P.identifier lexer
+dot = P.dot lexer
+operator = P.operator lexer
+
+parseNotInScope :: String -> (Maybe NotInScopeParseResult)
+parseNotInScope str =
+ case Parsec.parse scopeParser "" 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"]))
+ symbol "`"
+ mbQual <- optionMaybe (try (do
+ q <- lexeme conid
+ dot
+ return q))
+ id <- optionMaybe (try identifier)
+ case id of
+ Just id -> return (NotInScopeParseResult mbQual
+ (take (length id - 1) id) (isJust isSub) False)
+ Nothing -> do
+ op <- operator
+ symbol "'"
+ return (NotInScopeParseResult mbQual op (isJust isSub) True)
+ <?> "scopeParser"
+
+conid = do
+ c <- upper
+ cs <- many (alphaNum <|> oneOf "_'")
+ return (c:cs)
+ <?> "conid"
+
+
+-- |* The little dialog to choose between possible modules
+
+moduleFields :: [String] -> String -> FieldDescription String
+moduleFields list ident =
+ mkField
+ (paraName <<<- ParaName ("From which module is " ++ ident)
+ $ paraMultiSel <<<- ParaMultiSel False
+ $ paraMinSize <<<- ParaMinSize (300,400)
+ $ emptyParams)
+ (\ a -> a)
+ (\ a b -> a)
+ (staticListEditor ( list) id)
+
+selectModuleDialog :: Window -> [Descr] -> String -> Maybe String -> Maybe Descr -> IO (Maybe Descr)
+selectModuleDialog parentWindow list id mbQual mbDescr =
+ let selectionList = (nub . sort) $ map (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 ((render . disp . modu) pm)
+ let realSelectionString = case mbSelectedString of
+ Nothing -> head selectionList
+ Just str -> if elem str selectionList
+ then str
+ else head selectionList
+ let qualId = case mbQual of
+ Nothing -> id
+ Just str -> str ++ "." ++ id
+ dia <- dialogNew
+ windowSetTransientFor dia parentWindow
+ upper <- dialogGetUpper dia
+ okButton <- dialogAddButton dia "Ok" ResponseOk
+ dialogAddButton dia "Cancel" ResponseCancel
+ (widget,inj,ext,_) <- buildEditor (moduleFields selectionList qualId) realSelectionString
+ boxPackStart upper widget PackGrow 7
+ dialogSetDefaultResponse dia ResponseOk --does not work for the tree view
+ widgetShowAll dia
+ rw <- getRealWidget widget
+ set okButton [widgetCanDefault := True]
+ widgetGrabDefault okButton
+ resp <- dialogRun dia
+ value <- ext ([])
+ 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 -> (render . disp . modu) pm == v) list)))
+ _ -> return Nothing
+
+data HiddenModuleResult = HiddenModuleResult {
+ hiddenModule :: String
+ , missingPackage :: PackageId}
+ deriving (Eq, Show)
+
+parseHiddenModule :: String -> (Maybe HiddenModuleResult)
+parseHiddenModule str =
+ case Parsec.parse hiddenModuleParser "" str of
+ Left e -> Nothing
+ Right (mod, pack) ->
+ case simpleParse pack of
+ Just p -> Just $ HiddenModuleResult mod p
+ Nothing -> Nothing
+
+hiddenModuleParser :: CharParser () (String, String)
+hiddenModuleParser = do
+ whiteSpace
+ symbol "Could not find module `"
mod <- many (noneOf "'")
- symbol "':\n"
- whiteSpace
- symbol "It is a member of the hidden package `"
- pack <- many (noneOf "'")
- symbol "'.\n"
- many anyChar
- return (mod, pack)
- <?> "hiddenModuleParser"
+ many (noneOf "\n")
+ symbol "\n"
+ whiteSpace
+ symbol "It is a member of the hidden package `"
+ pack <- many (noneOf "'")
+ symbol "'.\n"
+ many anyChar
+ return (mod, pack)
+ <?> "hiddenModuleParser"
View
42 tests/Tests.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE TemplateHaskell #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Tests
+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie
+-- License : GNU-GPL
+--
+-- Maintainer : <maintainer at leksah.org>
+-- Stability : provisional
+-- Portability : portable
+--
+-- |
+--
+-------------------------------------------------------------------------------
+module Main (main) where
+
+import System.Exit (exitFailure)
+import Test.QuickCheck.All (quickCheckAll)
+import IDE.ImportTool (parseHiddenModule, HiddenModuleResult(..))
+import Control.Monad (unless)
+import Distribution.Package
+ (PackageName(..), PackageIdentifier(..))
+import Distribution.Version (Version(..))
+
+testString = " Could not find module `Graphics.UI.Gtk':\n"
+ ++ " It is a member of the hidden package `gtk-0.11.0'.\n"
+ ++ " Perhaps you need to add `gtk' to the build-depends in your .cabal file.\n"
+ ++ " Use -v to see a list of the files searched for."
+
+prop_parseHiddenModule = parseHiddenModule testString == Just (HiddenModuleResult {hiddenModule = "Graphics.UI.Gtk", missingPackage = PackageIdentifier {pkgName = PackageName "gtk", pkgVersion = Version {versionBranch = [0,11,0], versionTags = []}}})
+
+-- At some point the : was removed from this message...
+testString2 = " Could not find module `Data.Attoparsec.Lazy'\n"
+ ++ " It is a member of the hidden package `attoparsec-0.10.2.0'.\n"
+ ++ " Perhaps you need to add `attoparsec' to the build-depends in your .cabal file.\n"
+ ++ " Use -v to see a list of the files searched for.\n"
+
+prop_parseHiddenModule2 = parseHiddenModule testString2 == Just (HiddenModuleResult {hiddenModule = "Data.Attoparsec.Lazy", missingPackage = PackageIdentifier {pkgName = PackageName "attoparsec", pkgVersion = Version {versionBranch = [0,10,2,0], versionTags = []}}})
+
+main = do
+ allPass <- $quickCheckAll -- Run QuickCheck on all prop_ functions
+ unless allPass exitFailure
Please sign in to comment.
Something went wrong with that request. Please try again.