diff --git a/leksah.cabal b/leksah.cabal
--- a/leksah.cabal
+++ b/leksah.cabal
@@ -1,5 +1,5 @@
name: leksah
-version: 0.14.1.1
+version: 0.14.2.0
cabal-version: >=1.18
build-type: Simple
license: GPL
@@ -190,10 +190,6 @@
Description: Use GTK3 rather than GTK2
Default: True
-flag webkit
- Description: Use WebKitGTK+
- Default: True
-
flag loc
Description: Experimental localization support
Default: False
@@ -216,7 +212,9 @@
build-depends: gtk-mac-integration >= 0.3.0.0 && <0.4
if flag(yi)
- build-depends: yi >=0.8.1 && <0.10
+ build-depends: yi >=0.11.2 && <0.12,
+ yi-language >=0.1.0.8 && <0.2,
+ yi-rope >=0.7.0.0 && <0.8
cpp-options: -DLEKSAH_WITH_YI
if flag(yi) && flag(dyre)
@@ -232,14 +230,13 @@
else
build-depends: gtk >=0.13.0.0 && <0.14, gtksourceview2 >=0.13.1.0 && <0.14
- if flag(webkit)
- if flag(gtk3)
- build-depends: webkitgtk3 -any, webkitgtk3-javascriptcore -any
- else
- build-depends: webkit -any, webkit-javascriptcore -any
- build-depends: jsaddle -any, ghcjs-codemirror -any, hamlet -any, blaze-html -any,
- lens -any, pretty-show >=1.6.3 && <1.7
- cpp-options: -DWEBKITGTK -DLEKSAH_WITH_CODE_MIRROR
+ if flag(gtk3)
+ build-depends: webkitgtk3 -any, webkitgtk3-javascriptcore -any
+ else
+ build-depends: webkit -any, webkit-javascriptcore -any
+ build-depends: jsaddle -any, ghcjs-codemirror -any, hamlet -any, blaze-html -any,
+ lens -any, pretty-show >=1.6.3 && <1.7
+ cpp-options: -DWEBKITGTK -DLEKSAH_WITH_CODE_MIRROR
if flag(loc) && os(linux)
cpp-options: -DLOCALIZATION
@@ -313,7 +310,7 @@
ghc-options: -threaded
hs-source-dirs: main
- build-depends: leksah == 0.14.1.1, base >= 4.0.0.0 && <=4.8, gtk3 -any
+ build-depends: leksah == 0.14.2.0, base >= 4.0.0.0 && <=4.8, gtk3 -any
if os(linux) && flag(loc)
cpp-options: -DLOCALIZATION
build-depends: hgettext, setlocale
@@ -329,18 +326,15 @@
ghc-options: -rtsopts -O2 -fwarn-missing-fields -fwarn-incomplete-patterns -ferror-spans
executable bewleksah
- if !flag(webkit)
- buildable: False
+ build-depends: leksah ==0.14.2.0, base >=4.0.0.0 && <=4.8,
+ jsaddle -any, ghcjs-dom -any
+ if flag(gtk3)
+ build-depends: gtk3 >=0.13.0.0 && <0.14, gtksourceview3 >=0.13.1.0 && <0.14,
+ webkitgtk3 -any, webkitgtk3-javascriptcore -any
+ cpp-options: -DMIN_VERSION_gtk=MIN_VERSION_gtk3
else
- build-depends: leksah ==0.14.1.1, base >=4.0.0.0 && <=4.8,
- jsaddle -any, ghcjs-dom -any
- if flag(gtk3)
- build-depends: gtk3 >=0.13.0.0 && <0.14, gtksourceview3 >=0.13.1.0 && <0.14,
- webkitgtk3 -any, webkitgtk3-javascriptcore -any
- cpp-options: -DMIN_VERSION_gtk=MIN_VERSION_gtk3
- else
- build-depends: gtk >=0.13.0.0 && <0.14, gtksourceview2 >=0.13.1.0 && <0.14,
- webkit -any, webkit-javascriptcore -any
+ build-depends: gtk >=0.13.0.0 && <0.14, gtksourceview2 >=0.13.1.0 && <0.14,
+ webkit -any, webkit-javascriptcore -any
main-is: Main.hs
buildable: True
@@ -349,7 +343,7 @@
test-suite tests
build-depends: base >=4.0.0.0 && <4.8, Cabal >=1.10.2.0 && <1.22,
- QuickCheck >=2.4.2 && <2.8, leksah ==0.14.1.1,
+ QuickCheck >=2.4.2 && <2.8, leksah ==0.14.2.0,
containers, ltk, leksah-server, hslogger,
transformers, glib, monad-loops, text
if flag(gtk3)
@@ -358,7 +352,7 @@
else
build-depends: gtk >=0.13.0.0 && <0.14, gtksourceview2 >=0.13.1.0 && <0.14, webkit -any
if flag(yi)
- build-depends: yi >=0.6.6.1 && <0.7
+ build-depends: yi
type: exitcode-stdio-1.0
main-is: Tests.hs
other-modules: IDE.TextEditor.Tests
diff --git a/osx/leksah.bundle b/osx/leksah.bundle
--- a/osx/leksah.bundle
+++ b/osx/leksah.bundle
@@ -71,12 +71,6 @@
${prefix}/lib/${gtkdir}/${pkg:${gtk}:gtk_binary_version}/immodules/*.so
-
-
- ${prefix}/lib/${gtkdir}/${pkg:${gtk}:gtk_binary_version}/theming-engines/*.so
-
-
-
${prefix}/lib/${gtkdir}/${pkg:${gtk}:gtk_binary_version}/printbackends/*.so
@@ -139,7 +133,7 @@
- ${prefix:hlint}
+ ${prefix:hlint}/share
- hicolor
+ Adwaita
diff --git a/scripts/stage.sh b/scripts/stage.sh
--- a/scripts/stage.sh
+++ b/scripts/stage.sh
@@ -33,7 +33,7 @@
# export DYLD_LIBRARY_PATH="/System/Library/Frameworks/ApplicationServices.framework/Versions/A/Frameworks/ImageIO.framework/Versions/A/Resources:$GTK_PREFIX/lib:$DYLD_LIBRARY_PATH"
if test "`uname`" = "Darwin"; then
- cabal install ./ ./vendor/ltk ./vendor/leksah-server ./vendor/yi/yi gtk3 ghcjs-dom jsaddle vendor/haskellVCSWrapper/vcswrapper vendor/haskellVCSGUI/vcsgui --with-ghc=ghc$GHCVERSION -j4 -fhave-quartz-gtk -fwebkit -flibcurl -fyi -fpango --with-gcc=gcc-mp-4.8 || exit
+ cabal install ./ ./vendor/ltk ./vendor/leksah-server ./vendor/yi gtk3 ghcjs-dom jsaddle vendor/haskellVCSWrapper/vcswrapper vendor/haskellVCSGUI/vcsgui --with-ghc=ghc$GHCVERSION -j4 -fhave-quartz-gtk -fwebkit -flibcurl -fyi -fpango --with-gcc=gcc-mp-4.8 || exit
else
cabal install ./ ./vendor/ltk ./vendor/leksah-server gtk3 ghcjs-dom jsaddle vendor/haskellVCSWrapper/vcswrapper vendor/haskellVCSGUI/vcsgui --with-ghc=ghc$GHCVERSION -j4 -fwebkit -flibcurl -f-yi -fpango -f-vty --force-reinstalls --extra-lib-dirs=/c/MinGWRPM/lib || bash || exit
# if [ "$GHC_VER" != "7.0.3" ] && [ "$GHC_VER" != "7.0.4" ] && [ "$GHC_VER" != "7.6.1" ]; then
diff --git a/src/IDE/Build.hs b/src/IDE/Build.hs
--- a/src/IDE/Build.hs
+++ b/src/IDE/Build.hs
@@ -146,7 +146,7 @@
chainFor :: IDEPackage -> MakeSettings -> MakeOp -> Chain MakeOp IDEPackage
-> Maybe (Chain MakeOp IDEPackage)
-> Chain MakeOp IDEPackage
-chainFor target settings (MoComposed (hdOp:[])) cont mbNegCont =
+chainFor target settings (MoComposed [hdOp]) cont mbNegCont =
chainFor target settings hdOp cont mbNegCont
chainFor target settings (MoComposed (hdOp:rest)) cont mbNegCont =
chainFor target settings hdOp (chainFor target settings (MoComposed rest) cont mbNegCont)
diff --git a/src/IDE/Command.hs b/src/IDE/Command.hs
--- a/src/IDE/Command.hs
+++ b/src/IDE/Command.hs
@@ -863,8 +863,8 @@
GenScopeC (PackScope _ symbolTable2)) ->
case filter (not . isReexported) (getIdentifierDescr symbol symbolTable1 symbolTable2) of
[] -> return ()
- a:[] -> selectIdentifier a openSource
- a:b:[] -> if isJust (dscMbModu a) && dscMbModu a == dscMbModu b &&
+ [a] -> selectIdentifier a openSource
+ [a, b] -> if isJust (dscMbModu a) && dscMbModu a == dscMbModu b &&
isNear (dscMbLocation a) (dscMbLocation b)
then selectIdentifier a openSource
else setChoices search [a,b]
@@ -890,7 +890,8 @@
return ()
return e)
registerEvent stRef "SelectInfo"
- (\ e@(SelectInfo str gotoSource) -> setSymbol str gotoSource >> return e)
+ (\ e@(SelectInfo str gotoSource)
+ -> setSymbol str gotoSource >> return e)
registerEvent stRef "SelectIdent"
(\ e@(SelectIdent id) -> selectIdentifier id False >> return e)
registerEvent stRef "InfoChanged"
@@ -899,7 +900,7 @@
(\ e@UpdateWorkspaceInfo -> updateWorkspaceInfo >> return e)
registerEvent stRef "WorkspaceChanged"
(\ e@(WorkspaceChanged showPane updateFileCache)
- -> updateWorkspace showPane updateFileCache >> return e)
+ -> postAsyncIDE (updateWorkspace showPane updateFileCache) >> return e)
registerEvent stRef "RecordHistory"
(\ rh@(RecordHistory h) -> recordHistory h >> return rh)
registerEvent stRef "Sensitivity"
@@ -907,7 +908,7 @@
registerEvent stRef "SearchMeta"
(\ e@(SearchMeta string) -> getSearch Nothing >>= flip searchMetaGUI string >> return e)
registerEvent stRef "StartFindInitial"
- (\ e@StartFindInitial -> editFindInc Initial >> return e)
+ (\ e@StartFindInitial -> editFindInc Initial >> return e)
registerEvent stRef "LoadSession"
(\ e@(LoadSession fp) -> loadSession fp >> return e)
registerEvent stRef "SaveSession"
diff --git a/src/IDE/Metainfo/Provider.hs b/src/IDE/Metainfo/Provider.hs
--- a/src/IDE/Metainfo/Provider.hs
+++ b/src/IDE/Metainfo/Provider.hs
@@ -73,6 +73,8 @@
import Data.Text (Text)
import qualified Data.Text as T (null, isPrefixOf, unpack, pack)
import Data.Monoid ((<>))
+import qualified Control.Arrow as A (Arrow(..))
+import Data.Function (on)
-- ---------------------------------------------------------------------
-- Updating metadata
@@ -91,7 +93,7 @@
ideMessage Normal "Now loading metadata ..."
loadSystemInfo
updateWorkspaceInfo' False $ \ _ -> do
- triggerEventIDE (InfoChanged True) >> return ()
+ void (triggerEventIDE (InfoChanged True))
liftIO $ infoM "leksah" "initInfo continuing"
continuation
@@ -100,22 +102,21 @@
loadSystemInfo
updateWorkspaceInfo' False $ \ _ -> do
ideMessage Normal "Finished"
- triggerEventIDE (InfoChanged True) >> return ()
+ void (triggerEventIDE (InfoChanged True))
continuation
updateSystemInfo :: IDEAction
updateSystemInfo = do
liftIO $ infoM "leksah" "update sys info called"
updateSystemInfo' False $ \ _ ->
- updateWorkspaceInfo' False $ \ _ -> do
- triggerEventIDE (InfoChanged False) >> return ()
+ updateWorkspaceInfo' False $ \ _ -> void (triggerEventIDE (InfoChanged False))
rebuildSystemInfo :: IDEAction
rebuildSystemInfo = do
liftIO $ infoM "leksah" "rebuild sys info called"
updateSystemInfo' True $ \ _ ->
updateWorkspaceInfo' True $ \ _ ->
- triggerEventIDE (InfoChanged False) >> return ()
+ void (triggerEventIDE (InfoChanged False))
updateWorkspaceInfo :: IDEAction
updateWorkspaceInfo = do
@@ -123,15 +124,15 @@
currentState' <- readIDE currentState
case currentState' of
IsStartingUp -> return ()
- _ -> do
- updateWorkspaceInfo' False $ \ _ -> do
- triggerEventIDE (InfoChanged False) >> return ()
+ _ ->
+ updateWorkspaceInfo' False $ \ _ ->
+ void (triggerEventIDE (InfoChanged False))
rebuildWorkspaceInfo :: IDEAction
rebuildWorkspaceInfo = do
liftIO $ infoM "leksah" "rebuild workspace info called"
- updateWorkspaceInfo' True $ \ _ -> do
- triggerEventIDE (InfoChanged False) >> return ()
+ updateWorkspaceInfo' True $ \ _ ->
+ void (triggerEventIDE (InfoChanged False))
--
-- | Load all infos for all installed and exposed packages
@@ -139,14 +140,14 @@
--
loadSystemInfo :: IDEAction
loadSystemInfo = do
- collectorPath <- liftIO $ getCollectorPath
- packageIds <- liftM nub $ liftIO $ getInstalledPackageIds
+ collectorPath <- liftIO getCollectorPath
+ packageIds <- liftM nub $ liftIO getInstalledPackageIds
packageList <- liftIO $ mapM (loadInfosForPackage collectorPath)
packageIds
let scope = foldr buildScope (PackScope Map.empty getEmptyDefaultScope)
$ catMaybes packageList
-- liftIO performGC
- modifyIDE_ (\ide -> ide{systemInfo = (Just (GenScopeC (addOtherToScope scope False)))})
+ modifyIDE_ (\ide -> ide{systemInfo = Just (GenScopeC (addOtherToScope scope False))})
return ()
@@ -160,21 +161,19 @@
case wi of
Nothing -> loadSystemInfo
Just (GenScopeC (PackScope psmap psst)) -> do
- packageIds <- liftIO $ getInstalledPackageIds
- let newPackages = filter (\ pi -> Map.member pi psmap) packageIds
- let trashPackages = filter (\ e -> not (elem e packageIds))(Map.keys psmap)
+ packageIds <- liftIO getInstalledPackageIds
+ let newPackages = filter (`Map.member` psmap) packageIds
+ let trashPackages = filter (`notElem` packageIds) (Map.keys psmap)
if null newPackages && null trashPackages
then continuation True
- else do
+ else
callCollector rebuild True True $ \ _ -> do
- collectorPath <- lift $ getCollectorPath
- newPackageInfos <- liftIO $ mapM (\pid -> loadInfosForPackage collectorPath pid)
+ collectorPath <- lift getCollectorPath
+ newPackageInfos <- liftIO $ mapM (loadInfosForPackage collectorPath)
newPackages
- let psmap2 = foldr (\e m -> Map.insert (pdPackage e) e m)
- psmap
- (map fromJust
- $ filter isJust newPackageInfos)
- let psmap3 = foldr (\e m -> Map.delete e m) psmap2 trashPackages
+ let psmap2 = foldr ((\ e m -> Map.insert (pdPackage e) e m) . fromJust) psmap
+ (filter isJust newPackageInfos)
+ let psmap3 = foldr Map.delete psmap2 trashPackages
let scope :: PackScope (Map Text [Descr])
= foldr buildScope (PackScope Map.empty symEmpty)
(Map.elems psmap3)
@@ -188,7 +187,7 @@
-- | Rebuilds system info
--
rebuildSystemInfo' :: (Bool -> IDEAction) -> IDEAction
-rebuildSystemInfo' continuation = do
+rebuildSystemInfo' continuation =
callCollector True True True $ \ _ -> do
loadSystemInfo
continuation True
@@ -208,14 +207,14 @@
liftIO $ infoM "leksah" "updateWorkspaceInfo' no workspace"
modifyIDE_ (\ide -> ide{workspaceInfo = Nothing, packageInfo = Nothing})
continuation False
- Just ws -> do
+ Just ws ->
updatePackageInfos rebuild (wsAllPackages ws) $ \ _ packDescrs -> do
- let dependPackIds = (nub $ concatMap pdBuildDepends packDescrs)
- \\ map pdPackage packDescrs
+ let dependPackIds = nub (concatMap pdBuildDepends packDescrs) \\
+ map pdPackage packDescrs
let packDescrsI = case systemInfo' of
Nothing -> []
Just (GenScopeC (PackScope pdmap _)) ->
- catMaybes $ map (\ pid -> pid `Map.lookup` pdmap) dependPackIds
+ mapMaybe (`Map.lookup` pdmap) dependPackIds
let scope1 :: PackScope (Map Text [Descr])
= foldr buildScope (PackScope Map.empty symEmpty) packDescrs
let scope2 :: PackScope (Map Text [Descr])
@@ -225,24 +224,22 @@
-- Now care about active package
activePack <- readIDE activePack
case activePack of
- Nothing -> do
- modifyIDE_ (\ide -> ide{packageInfo = Nothing})
- Just pack -> do
+ Nothing -> modifyIDE_ (\ ide -> ide{packageInfo = Nothing})
+ Just pack ->
case filter (\pd -> pdPackage pd == ipdPackageId pack) packDescrs of
[pd] -> let impPackDescrs =
case systemInfo' of
Nothing -> []
Just (GenScopeC (PackScope pdmap _)) ->
- catMaybes $ map (\ pid -> pid `Map.lookup` pdmap)
- (pdBuildDepends pd)
+ mapMaybe (`Map.lookup` pdmap) (pdBuildDepends pd)
-- The imported from the workspace should be treated different
workspacePackageIds = map ipdPackageId (wsAllPackages ws)
- impPackDescrs' = filter (\pd -> not (elem (pdPackage pd)
- workspacePackageIds)) impPackDescrs
- impPackDescrs'' = catMaybes $ map (\pd ->
- if (elem (pdPackage pd) workspacePackageIds)
- then find (\pd' -> pdPackage pd == pdPackage pd') packDescrs
- else Nothing) impPackDescrs
+ impPackDescrs' = filter (\pd -> pdPackage pd `notElem` workspacePackageIds) impPackDescrs
+ impPackDescrs'' = mapMaybe
+ (\ pd -> if pdPackage pd `elem` workspacePackageIds
+ then find (\ pd' -> pdPackage pd == pdPackage pd') packDescrs
+ else Nothing)
+ impPackDescrs
scope1 :: PackScope (Map Text [Descr])
= buildScope pd (PackScope Map.empty symEmpty)
scope2 :: PackScope (Map Text [Descr])
@@ -256,7 +253,7 @@
postAsyncIDE $ ideMessage Normal "Finished updating workspace metadata"
updatePackageInfos :: Bool -> [IDEPackage] -> (Bool -> [PackageDescr] -> IDEAction) -> IDEAction
-updatePackageInfos rebuild packs conts = updatePackageInfos' [] rebuild packs conts
+updatePackageInfos = updatePackageInfos' []
where
updatePackageInfos' collector _ [] continuation = continuation True collector
updatePackageInfos' collector rebuild (hd:tail) continuation =
@@ -285,8 +282,8 @@
[] -> modPairsMb
hd:_ -> hd : modPairsMb
let (modWith,modWithout) = partition (\(x,y) -> isJust y) modPairsMb'
- let modWithSources = map (\(f,s) -> (f,fromJust s)) modWith
- let modWithoutSources = map fst $ modWithout
+ let modWithSources = map (A.second fromJust) modWith
+ let modWithoutSources = map fst modWithout
-- Now see which modules have to be truely updated
modToUpdate <- if rebuild
then return modWithSources
@@ -299,7 +296,7 @@
(map (\(x,y) -> (T.pack $ display x,y)) modToUpdate)
(\ b -> do
buildDepends <- liftIO $ findFittingPackages (ipdDepends idePack)
- collectorPath <- liftIO $ getCollectorPath
+ collectorPath <- liftIO getCollectorPath
let packageCollectorPath = collectorPath T.unpack (packageIdentifierToString pi)
(moduleDescrs,packageMap, changed, modWithout)
<- liftIO $ foldM
@@ -308,14 +305,14 @@
modPairsMb'
when changed $ modifyIDE_ (\ide -> ide{workspInfoCache =
Map.insert pi packageMap workspInfoCache'})
- continuation True $ (PackageDescr {
+ continuation True PackageDescr {
pdPackage = pi,
pdMbSourcePath = Just $ ipdCabalFile idePack,
pdModules = moduleDescrs,
- pdBuildDepends = buildDepends}))
+ pdBuildDepends = buildDepends})
where
- basePath = normalise $ (takeDirectory (ipdCabalFile idePack))
- srcDirs' bi = map (basePath ) ("dist/build":(hsSourceDirs bi))
+ basePath = normalise $ takeDirectory (ipdCabalFile idePack)
+ srcDirs' bi = map (basePath ) ("dist/build":hsSourceDirs bi)
pi = ipdPackageId idePack
figureOutRealSources :: IDEPackage -> [(ModuleName,FilePath)] -> IO [(ModuleName,FilePath)]
@@ -329,14 +326,12 @@
let collectorModulePath = packageCollectorPath modId <.> leksahMetadataWorkspaceFileExtension
existCollectorFile <- doesFileExist collectorModulePath
existSourceFile <- doesFileExist fp
- if (not existSourceFile)
+ if not existSourceFile || not existCollectorFile
then return True -- Maybe with preprocessing
- else if not existCollectorFile
- then return True
- else do
- sourceModTime <- getModificationTime fp
- collModTime <- getModificationTime collectorModulePath
- return (sourceModTime > collModTime)
+ else do
+ sourceModTime <- getModificationTime fp
+ collModTime <- getModificationTime collectorModulePath
+ return (sourceModTime > collModTime)
getModuleDescr :: FilePath
@@ -402,7 +397,7 @@
throwIDE ("Metadata has a wrong version."
<> " Consider rebuilding metadata with: leksah-server -osb +RTS -N2 -RTS")
else do
- packageInfo `deepseq` (hClose file)
+ packageInfo `deepseq` hClose file
exists' <- doesFileExist filePath2
sourcePath <- if exists'
then liftM Just (readFile filePath2)
@@ -422,7 +417,7 @@
pdMbSourcePath = Nothing,
pdModules = map (injectSourceInMod Nothing) (pdModules pd)}
injectSourceInPack (Just pp) pd = pd{
- pdMbSourcePath = (Just pp),
+ pdMbSourcePath = Just pp,
pdModules = map (injectSourceInMod (Just (dropFileName pp))) (pdModules pd)}
injectSourceInMod :: Maybe FilePath -> ModuleDescr -> ModuleDescr
@@ -449,7 +444,7 @@
throwIDE ("Metadata has a wrong version."
<> " Consider rebuilding metadata with -r option")
else do
- moduleInfo `deepseq` (hClose file)
+ moduleInfo `deepseq` hClose file
return (Just moduleInfo))
(\ (e :: SomeException) -> do sysMessage Normal (T.pack $ "loadInfosForModule: " ++ show e); return Nothing)
else do
@@ -466,7 +461,7 @@
name == dname && withinRange version versionRange)
packages
in if length filtered > 1
- then [maximumBy (\a b -> compare (pkgVersion a) (pkgVersion b)) filtered]
+ then [maximumBy (compare `on` pkgVersion) filtered]
else filtered
-- ---------------------------------------------------------------------
@@ -482,7 +477,7 @@
packageInfo' <- getPackageInfo
case packageInfo' of
Nothing -> return Nothing
- Just (GenScopeC (PackScope map _),(GenScopeC (PackScope _ _))) ->
+ Just (GenScopeC (PackScope map _), GenScopeC (PackScope _ _)) ->
return (ipdPackageId pack `Map.lookup` map)
--
@@ -514,7 +509,7 @@
workspaceInfo' <- getWorkspaceInfo
case workspaceInfo' of
Nothing -> return []
- Just ((GenScopeC (PackScope _ symbolTable1)),(GenScopeC (PackScope _ symbolTable2))) ->
+ Just (GenScopeC (PackScope _ symbolTable1), GenScopeC (PackScope _ symbolTable2)) ->
return $ getIdentifiersStartingWith prefix symbolTable1 symbolTable2
getDescription :: Text -> IDEM Text
@@ -522,9 +517,9 @@
workspaceInfo' <- getWorkspaceInfo
case workspaceInfo' of
Nothing -> return ""
- Just ((GenScopeC (PackScope _ symbolTable1)),(GenScopeC (PackScope _ symbolTable2))) ->
- return $ T.pack ((foldr (\d f -> shows (Present d) . showChar '\n' . f) id
- (getIdentifierDescr name symbolTable1 symbolTable2)) "")
+ Just (GenScopeC (PackScope _ symbolTable1), GenScopeC (PackScope _ symbolTable2)) ->
+ return $ T.pack (foldr (\d f -> shows (Present d) . showChar '\n' . f) id
+ (getIdentifierDescr name symbolTable1 symbolTable2) "")
getPackageInfo :: IDEM (Maybe (GenScope, GenScope))
getPackageInfo = readIDE packageInfo
@@ -547,7 +542,7 @@
Nothing -> do
liftIO $ infoM "leksah" "getPackageImportInfo: no package info"
return Nothing
- Just ((GenScopeC (PackScope pdmap _)),_) -> do
+ Just (GenScopeC (PackScope pdmap _), _) ->
case Map.lookup (ipdPackageId idePack) pdmap of
Nothing -> do
liftIO $ infoM "leksah" "getPackageImportInfo: package not found in package"
@@ -559,7 +554,7 @@
Nothing -> do
liftIO $ infoM "leksah" "getPackageImportInfo: no workspace info"
return Nothing
- Just ((GenScopeC (PackScope pdmap _)),_) ->
+ Just (GenScopeC (PackScope pdmap _), _) ->
case Map.lookup (ipdPackageId idePack) pdmap of
Nothing -> do
liftIO $ infoM "leksah" "getPackageImportInfo: package not found in workspace"
@@ -575,8 +570,7 @@
liftIO $ infoM "leksah" "getPackageImportInfo: no system info"
return Nothing
Just (GenScopeC (PackScope pdmap' _)) ->
- let impPackDescrs = catMaybes $ map (\ pid -> pid `Map.lookup` pdmap')
- (pdBuildDepends pd)
+ let impPackDescrs = mapMaybe (`Map.lookup` pdmap') (pdBuildDepends pd)
pd' = pd{pdModules = map filterPrivate (pdModules pd)}
scope1 :: PackScope (Map Text [Descr])
= buildScope pd (PackScope Map.empty symEmpty)
@@ -593,24 +587,24 @@
packageInfo' <- getPackageInfo
case packageInfo' of
Nothing -> return []
- Just ((GenScopeC (PackScope _ rl)),_) -> return (searchInScope searchType searchString rl)
+ Just (GenScopeC (PackScope _ rl), _) -> return (searchInScope searchType searchString rl)
searchMeta (PackageScope True) searchString searchType = do
packageInfo' <- getPackageInfo
case packageInfo' of
Nothing -> return []
- Just ((GenScopeC (PackScope _ rl)),(GenScopeC (PackScope _ rr))) ->
+ Just (GenScopeC (PackScope _ rl), GenScopeC (PackScope _ rr)) ->
return (searchInScope searchType searchString rl
++ searchInScope searchType searchString rr)
searchMeta (WorkspaceScope False) searchString searchType = do
workspaceInfo' <- getWorkspaceInfo
case workspaceInfo' of
Nothing -> return []
- Just ((GenScopeC (PackScope _ rl)),_) -> return (searchInScope searchType searchString rl)
+ Just (GenScopeC (PackScope _ rl), _) -> return (searchInScope searchType searchString rl)
searchMeta (WorkspaceScope True) searchString searchType = do
workspaceInfo' <- getWorkspaceInfo
case workspaceInfo' of
Nothing -> return []
- Just ((GenScopeC (PackScope _ rl)),(GenScopeC (PackScope _ rr))) ->
+ Just (GenScopeC (PackScope _ rl), GenScopeC (PackScope _ rr)) ->
return (searchInScope searchType searchString rl
++ searchInScope searchType searchString rr)
searchMeta SystemScope searchString searchType = do
@@ -620,12 +614,12 @@
Nothing ->
case packageInfo' of
Nothing -> return []
- Just ((GenScopeC (PackScope _ rl)),_) ->
+ Just (GenScopeC (PackScope _ rl), _) ->
return (searchInScope searchType searchString rl)
Just (GenScopeC (PackScope _ s)) ->
case packageInfo' of
Nothing -> return (searchInScope searchType searchString s)
- Just ((GenScopeC (PackScope _ rl)),_) -> return (searchInScope searchType searchString rl
+ Just (GenScopeC (PackScope _ rl), _) -> return (searchInScope searchType searchString rl
++ searchInScope searchType searchString s)
searchInScope :: SymbolTable alpha => SearchMode -> Text -> alpha -> [Descr]
@@ -654,13 +648,13 @@
searchInScopeCaseIns' (a:l) st pre | isLower a =
let s1 = pre ++ [a]
s2 = pre ++ [toUpper a]
- in (symUnion (searchInScopeCaseIns' l (searchInScopePrefix (T.pack s1) st) s1)
- (searchInScopeCaseIns' l (searchInScopePrefix (T.pack s2) st) s2))
+ in symUnion (searchInScopeCaseIns' l (searchInScopePrefix (T.pack s1) st) s1)
+ (searchInScopeCaseIns' l (searchInScopePrefix (T.pack s2) st) s2)
| isUpper a =
let s1 = pre ++ [a]
s2 = pre ++ [toLower a]
- in (symUnion (searchInScopeCaseIns' l (searchInScopePrefix (T.pack s1) st) s1)
- (searchInScopeCaseIns' l (searchInScopePrefix (T.pack s2) st) s2))
+ in symUnion (searchInScopeCaseIns' l (searchInScopePrefix (T.pack s1) st) s1)
+ (searchInScopeCaseIns' l (searchInScopePrefix (T.pack s2) st) s2)
| otherwise =
let s = pre ++ [a]
in searchInScopeCaseIns' l (searchInScopePrefix (T.pack s) st) s
@@ -672,7 +666,7 @@
Left err ->
unsafePerformIO $ sysMessage Normal (T.pack $ show err) >> return []
Right regex ->
- filter (\e -> do
+ filter (\e ->
case execute regex (dscName e) of
Left e -> False
Right Nothing -> False
@@ -697,9 +691,9 @@
buildScope packageD (PackScope packageMap symbolTable) =
let pid = pdPackage packageD
in if pid `Map.member` packageMap
- then (PackScope packageMap symbolTable)
- else (PackScope (Map.insert pid packageD packageMap)
- (buildSymbolTable packageD symbolTable))
+ then PackScope packageMap symbolTable
+ else PackScope (Map.insert pid packageD packageMap)
+ (buildSymbolTable packageD symbolTable)
buildSymbolTable :: SymbolTable alpha => PackageDescr -> alpha -> alpha
buildSymbolTable pDescr symbolTable =
@@ -715,29 +709,29 @@
| otherwise =
case dscTypeHint descr of
DataDescr constructors fields ->
- descr : (map (\(SimpleDescr fn ty loc comm exp) ->
- Real $ RealDescr{dscName' = fn, dscMbTypeStr' = ty,
+ descr : map (\(SimpleDescr fn ty loc comm exp) ->
+ Real RealDescr{dscName' = fn, dscMbTypeStr' = ty,
dscMbModu' = dscMbModu descr, dscMbLocation' = loc,
dscMbComment' = comm, dscTypeHint' = FieldDescr descr, dscExported' = exp})
- fields)
- ++ (map (\(SimpleDescr fn ty loc comm exp) ->
- Real $ RealDescr{dscName' = fn, dscMbTypeStr' = ty,
+ fields
+ ++ map (\(SimpleDescr fn ty loc comm exp) ->
+ Real RealDescr{dscName' = fn, dscMbTypeStr' = ty,
dscMbModu' = dscMbModu descr, dscMbLocation' = loc,
dscMbComment' = comm, dscTypeHint' = ConstructorDescr descr, dscExported' = exp})
- constructors)
+ constructors
ClassDescr _ methods ->
- descr : (map (\(SimpleDescr fn ty loc comm exp) ->
- Real $ RealDescr{dscName' = fn, dscMbTypeStr' = ty,
+ descr : map (\(SimpleDescr fn ty loc comm exp) ->
+ Real RealDescr{dscName' = fn, dscMbTypeStr' = ty,
dscMbModu' = dscMbModu descr, dscMbLocation' = loc,
dscMbComment' = comm, dscTypeHint' = MethodDescr descr, dscExported' = exp})
- methods)
+ methods
NewtypeDescr (SimpleDescr fn ty loc comm exp) mbField ->
- descr : (Real $ RealDescr{dscName' = fn, dscMbTypeStr' = ty,
+ descr : Real RealDescr{dscName' = fn, dscMbTypeStr' = ty,
dscMbModu' = dscMbModu descr, dscMbLocation' = loc,
- dscMbComment' = comm, dscTypeHint' = ConstructorDescr descr, dscExported' = exp})
+ dscMbComment' = comm, dscTypeHint' = ConstructorDescr descr, dscExported' = exp}
: case mbField of
Just (SimpleDescr fn ty loc comm exp) ->
- [Real $ RealDescr{dscName' = fn, dscMbTypeStr' = ty,
+ [Real RealDescr{dscName' = fn, dscMbTypeStr' = ty,
dscMbModu' = dscMbModu descr, dscMbLocation' = loc,
dscMbComment' = comm, dscTypeHint' = FieldDescr descr, dscExported' = exp}]
Nothing -> []
@@ -776,7 +770,7 @@
then do
liftIO $ infoM "leksah" "callCollectorWorkspace: Nothing to do"
cont True
- else do
+ else
doServerCommand command $ \ res ->
case res of
ServerOK -> do
@@ -860,7 +854,7 @@
True) (pdModules pd)
addOtherToScope :: SymbolTable alpha => PackScope alpha -> Bool -> PackScope alpha
-addOtherToScope (PackScope packageMap symbolTable) addAll = (PackScope packageMap newSymbolTable)
+addOtherToScope (PackScope packageMap symbolTable) addAll = PackScope packageMap newSymbolTable
where newSymbolTable = foldl' (\ map descr -> symInsert (dscName descr) [descr] map)
symbolTable (if addAll
then keywordDescrs ++ extensionDescrs ++ modNameDescrs
diff --git a/src/IDE/Pane/Grep.hs b/src/IDE/Pane/Grep.hs
--- a/src/IDE/Pane/Grep.hs
+++ b/src/IDE/Pane/Grep.hs
@@ -1,337 +1,334 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE OverloadedStrings #-}
------------------------------------------------------------------------------
---
--- Module : IDE.Pane.Grep
--- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie
--- License : GNU-GPL
---
--- Maintainer :
--- Stability : provisional
--- Portability : portable
---
--- | The pane of ide where grep results are displayed
---
--------------------------------------------------------------------------------
-
-module IDE.Pane.Grep (
- IDEGrep(..)
-, grepWorkspace
-, GrepState(..)
-, getGrep
-) where
-
-import Graphics.UI.Gtk hiding (get)
-import qualified Graphics.UI.Gtk.Gdk.Events as Gdk
-import Text.ParserCombinators.Parsec.Language
-import Text.ParserCombinators.Parsec hiding(Parser)
-import qualified Text.ParserCombinators.Parsec.Token as P
-import Data.Maybe
-import Data.Typeable
-import Data.List (isPrefixOf)
-import IDE.Core.State
-import IDE.BufferMode
-import IDE.Utils.Tool (runTool, ToolOutput(..), getProcessExitCode, interruptProcessGroupOf)
-import Control.Concurrent
- (forkOS, newEmptyMVar, isEmptyMVar, takeMVar, putMVar, MVar,
- forkIO)
-import IDE.LogRef (logOutput, defaultLineLogger)
-import IDE.Pane.SourceBuffer
- (goToSourceDefinition, maybeActiveBuf, IDEBuffer(..))
-import IDE.TextEditor (grabFocus)
-import Control.Applicative ((<$>))
-import System.FilePath ((), dropFileName)
-import System.Exit (ExitCode(..))
-import IDE.Pane.Log (getLog, getDefaultLogLaunch)
-import Control.DeepSeq
-import qualified Data.Conduit as C
- (Sink)
-import qualified Data.Conduit.List as CL
- (foldM, head, isolate, sinkNull)
-import Data.Conduit (($$), (=$))
-import Control.Monad (foldM, when)
-import Control.Monad.Trans.Reader (ask)
-import Control.Monad.Trans.Class (MonadTrans(..))
-import Control.Monad.IO.Class (MonadIO(..))
-import IDE.Utils.GUIUtils (__)
-import System.Directory (getDirectoryContents)
-import qualified Data.Text as T (pack, take, unpack)
-import System.Log.Logger (debugM)
-import Control.Exception (SomeException, catch)
-import Data.Text (Text)
-
-data GrepRecord = GrepRecord {
- file :: FilePath
- , line :: Int
- , context :: Text
- , parDir :: Maybe FilePath
- }
-
-isDir GrepRecord{parDir = Nothing} = True
-isDir otherwies = False
-
--- | A grep pane description
---
-
-data IDEGrep = IDEGrep {
- scrolledView :: ScrolledWindow
-, treeView :: TreeView
-, grepStore :: TreeStore GrepRecord
-, waitingGrep :: MVar Bool
-, activeGrep :: MVar Bool
-} deriving Typeable
-
-data GrepState = GrepState
- deriving(Eq,Ord,Read,Show,Typeable)
-
-instance Pane IDEGrep IDEM
- where
- primPaneName _ = (__ "Grep")
- getAddedIndex _ = 0
- getTopWidget = castToWidget . scrolledView
- paneId b = "*Grep"
-
-instance RecoverablePane IDEGrep GrepState IDEM where
- saveState p = do
- return (Just GrepState)
- recoverState pp GrepState = do
- nb <- getNotebook pp
- buildPane pp nb builder
- builder pp nb windows = reifyIDE $ \ ideR -> do
- grepStore <- treeStoreNew []
- treeView <- treeViewNew
- treeViewSetModel treeView grepStore
-
- renderer1 <- cellRendererTextNew
- col1 <- treeViewColumnNew
- treeViewColumnSetTitle col1 (__ "File")
- treeViewColumnSetSizing col1 TreeViewColumnAutosize
- treeViewColumnSetResizable col1 True
- treeViewColumnSetReorderable col1 True
- treeViewAppendColumn treeView col1
- cellLayoutPackStart col1 renderer1 True
- cellLayoutSetAttributes col1 renderer1 grepStore
- $ \row -> [ cellText := T.pack $ file row]
-
- renderer2 <- cellRendererTextNew
- col2 <- treeViewColumnNew
- treeViewColumnSetTitle col2 (__ "Line")
- treeViewColumnSetSizing col2 TreeViewColumnAutosize
- treeViewColumnSetResizable col2 True
- treeViewColumnSetReorderable col2 True
- treeViewAppendColumn treeView col2
- cellLayoutPackStart col2 renderer2 True
- cellLayoutSetAttributes col2 renderer2 grepStore
- $ \row -> [ cellText := T.pack $ show $ line row]
-
- renderer3 <- cellRendererTextNew
- col3 <- treeViewColumnNew
- treeViewColumnSetTitle col3 (__ "Context")
- treeViewColumnSetSizing col3 TreeViewColumnAutosize
- treeViewColumnSetResizable col3 True
- treeViewColumnSetReorderable col3 True
- treeViewAppendColumn treeView col3
- cellLayoutPackStart col3 renderer3 True
- cellLayoutSetAttributes col3 renderer3 grepStore
- $ \row -> [ cellText := T.take 2048 $ context row]
-
-
- treeViewSetHeadersVisible treeView True
- sel <- treeViewGetSelection treeView
- treeSelectionSetMode sel SelectionSingle
-
- scrolledView <- scrolledWindowNew Nothing Nothing
- scrolledWindowSetShadowType scrolledView ShadowIn
- containerAdd scrolledView treeView
- scrolledWindowSetPolicy scrolledView PolicyAutomatic PolicyAutomatic
-
- waitingGrep <- newEmptyMVar
- activeGrep <- newEmptyMVar
- let grep = IDEGrep {..}
- let
- gotoSource :: Bool -> IO Bool
- gotoSource focus = do
- sel <- getSelectionGrepRecord treeView grepStore
- case sel of
- Just record -> reflectIDE (do
- case record of
- GrepRecord {file=f, line=l, parDir=Just pp} ->
- (goToSourceDefinition pp $ Location f l 0 l 0)
- ?>>= (\(IDEBuffer {sourceView = sv}) -> when focus $ grabFocus sv)
- _ -> return ()) ideR
- Nothing -> return ()
- return True
- cid1 <- after treeView focusInEvent $ do
- liftIO $ reflectIDE (makeActive grep) ideR
- return True
- cid2 <- on treeView keyPressEvent $ do
- name <- eventKeyName
- liftIO $ case name of
- "Return" -> gotoSource True
- "Escape" -> do
- reflectIDE (do
- lastActiveBufferPane ?>>= \paneName -> do
- (PaneC pane) <- paneFromName paneName
- makeActive pane
- return ()
- triggerEventIDE StartFindInitial) ideR
- return True
- -- gotoSource True
- _ -> return False
- on sel treeSelectionSelectionChanged (gotoSource False >> return ())
-
-
- return (Just grep,[ConnectC cid1])
-
-getGrep :: Maybe PanePath -> IDEM IDEGrep
-getGrep Nothing = forceGetPane (Right "*Grep")
-getGrep (Just pp) = forceGetPane (Left pp)
-
-grepLineParser :: CharParser () GrepRecord
-grepLineParser = try (do
- file <- many (noneOf ":")
- char ':'
- line <- int
- char ':'
- context <- T.pack <$> many anyChar
- let parDir = Nothing
- return $ GrepRecord {..}
- "grepLineParser")
-
-lexer = P.makeTokenParser emptyDef
-lexeme = P.lexeme lexer
-whiteSpace = P.whiteSpace lexer
-hexadecimal = P.hexadecimal lexer
-symbol = P.symbol lexer
-identifier = P.identifier lexer
-colon = P.colon lexer
-int = fmap fromInteger $ P.integer lexer
-
-getSelectionGrepRecord :: TreeView
- -> TreeStore GrepRecord
- -> IO (Maybe GrepRecord)
-getSelectionGrepRecord treeView grepStore = do
- treeSelection <- treeViewGetSelection treeView
- paths <- treeSelectionGetSelectedRows treeSelection
- case paths of
- p:_ -> Just <$> treeStoreGetValue grepStore p
- _ -> return Nothing
-
---TODO srp use default loglaunch probably
-grepWorkspace :: Text -> Bool -> WorkspaceAction
-grepWorkspace "" caseSensitive = return ()
-grepWorkspace regexString caseSensitive = do
- ws <- ask
- maybeActive <- lift $ readIDE activePack
- let packages = case maybeActive of
- Just active -> active : (filter (/= active) $ wsAllPackages ws)
- Nothing -> wsAllPackages ws
- lift $ grepDirectories regexString caseSensitive $
- map (\p -> (dropFileName $ ipdCabalFile p)) $ packages
-
-grepDirectories :: Text -> Bool -> [FilePath] -> IDEAction
-grepDirectories regexString caseSensitive dirs = do
- grep <- getGrep Nothing
- let store = grepStore grep
- ideRef <- ask
- liftIO $ do
- bringPaneToFront grep
- forkIO $ do
- putMVar (waitingGrep grep) True
- putMVar (activeGrep grep) True
- takeMVar (waitingGrep grep)
-
- postGUISync $ treeStoreClear store
-
- totalFound <- foldM (\a dir -> do
- subDirs <- filter (\f ->
- (not ("." `isPrefixOf` f))
- && (not (f `elem` ["_darcs", "dist", "vendor"]))) <$> getDirectoryContents dir
- nooneWaiting <- isEmptyMVar (waitingGrep grep)
- found <- if nooneWaiting
- then do
- (output, pid) <- runTool "grep" ((if caseSensitive then [] else ["-i"])
- ++ ["-r", "-E", "-n", "-I", "--exclude=*~",
-#if !defined(darwin_HOST_OS)
- "--exclude-dir=.svn",
- "--exclude-dir=_darcs",
- "--exclude-dir=.git",
-#endif
- regexString] ++ map T.pack subDirs) (Just dir)
- reflectIDE (do
- output $$ do
- let max = 1000
- CL.isolate max =$ do
- n <- setGrepResults dir
- when (n >= max) . liftIO $ do
- debugM "leksah" $ "interrupting grep process"
- interruptProcessGroupOf pid
- `catch` \(_::SomeException) -> return ()
- postGUISync $ do
- nDir <- treeModelIterNChildren store Nothing
- treeStoreChange store [nDir-1] (\r -> r{ context = (__ "(Stoped Searching)") })
- return ()
- CL.sinkNull
- return n) ideRef
- else return 0
- return $ a + found) 0 dirs
-
- nooneWaiting <- isEmptyMVar (waitingGrep grep)
- when nooneWaiting $ postGUISync $ do
- nDir <- treeModelIterNChildren store Nothing
- treeStoreInsert store [] nDir $ GrepRecord (T.unpack $ __ "Search Complete") totalFound "" Nothing
-
- takeMVar (activeGrep grep) >> return ()
- return ()
-
-setGrepResults :: FilePath -> C.Sink ToolOutput IDEM Int
-setGrepResults dir = do
- ideRef <- lift ask
- grep <- lift $ getGrep Nothing
- log <- lift $ getLog
- defaultLogLaunch <- lift $ getDefaultLogLaunch
- let store = grepStore grep
- view = treeView grep
- nDir <- liftIO $ postGUISync $ do
- nDir <- treeModelIterNChildren store Nothing
- treeStoreInsert store [] nDir $ GrepRecord dir 0 "" Nothing
- when (nDir == 0) (widgetGrabFocus view >> return())
- return nDir
- CL.foldM (\count line -> do
- if isError line
- then do
- liftIO $ postGUISync $ reflectIDE (defaultLineLogger log defaultLogLaunch line >> return ()) ideRef
- return count
- else do
- case process dir line of
- Nothing -> return count
- Just record -> liftIO $ do
- nooneWaiting <- isEmptyMVar (waitingGrep grep)
- when nooneWaiting $ postGUISync $ do
- parent <- treeModelGetIter store [nDir]
- n <- treeModelIterNChildren store parent
- treeStoreInsert store [nDir] n record
- treeStoreChange store [nDir] (\r -> r{ line = n+1 })
- when (nDir == 0 && n == 0) $
- treeViewExpandAll view
- return (count+1)) 0
- where
- process pp (ToolOutput line) =
- case parse grepLineParser "" $ T.unpack line of
- Right record -> Just record{parDir = Just pp}
- _ -> Nothing
- process _ _ = Nothing
-
- isError (ToolExit ExitSuccess) = False
- isError (ToolExit (ExitFailure 1)) = False
- isError o = isNothing (process "" o)
-
-
-
-
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
+-----------------------------------------------------------------------------
+--
+-- Module : IDE.Pane.Grep
+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie
+-- License : GNU-GPL
+--
+-- Maintainer :
+-- Stability : provisional
+-- Portability : portable
+--
+-- | The pane of ide where grep results are displayed
+--
+-------------------------------------------------------------------------------
+
+module IDE.Pane.Grep (
+ IDEGrep(..)
+, grepWorkspace
+, GrepState(..)
+, getGrep
+) where
+
+import Graphics.UI.Gtk hiding (get)
+import qualified Graphics.UI.Gtk.Gdk.Events as Gdk
+import Text.ParserCombinators.Parsec.Language
+import Text.ParserCombinators.Parsec hiding(Parser)
+import qualified Text.ParserCombinators.Parsec.Token as P
+import Data.Maybe
+import Data.Typeable
+import Data.List (isPrefixOf)
+import IDE.Core.State
+import IDE.BufferMode
+import IDE.Utils.Tool (runTool, ToolOutput(..), getProcessExitCode, interruptProcessGroupOf)
+import Control.Concurrent
+ (forkOS, newEmptyMVar, isEmptyMVar, takeMVar, putMVar, MVar,
+ forkIO)
+import IDE.LogRef (logOutput, defaultLineLogger)
+import IDE.Pane.SourceBuffer
+ (goToSourceDefinition, maybeActiveBuf, IDEBuffer(..))
+import IDE.TextEditor (grabFocus)
+import Control.Applicative ((<$>))
+import System.FilePath ((), dropFileName)
+import System.Exit (ExitCode(..))
+import IDE.Pane.Log (getLog, getDefaultLogLaunch)
+import Control.DeepSeq
+import qualified Data.Conduit as C
+ (Sink)
+import qualified Data.Conduit.List as CL
+ (foldM, head, isolate, sinkNull)
+import Data.Conduit (($$), (=$))
+import Control.Monad (void, foldM, when)
+import Control.Monad.Trans.Reader (ask)
+import Control.Monad.Trans.Class (MonadTrans(..))
+import Control.Monad.IO.Class (MonadIO(..))
+import IDE.Utils.GUIUtils (__)
+import System.Directory (getDirectoryContents)
+import qualified Data.Text as T (pack, take, unpack)
+import System.Log.Logger (debugM)
+import Control.Exception (SomeException, catch)
+import Data.Text (Text)
+
+data GrepRecord = GrepRecord {
+ file :: FilePath
+ , line :: Int
+ , context :: Text
+ , parDir :: Maybe FilePath
+ }
+
+isDir GrepRecord{parDir = Nothing} = True
+isDir otherwies = False
+
+-- | A grep pane description
+--
+
+data IDEGrep = IDEGrep {
+ scrolledView :: ScrolledWindow
+, treeView :: TreeView
+, grepStore :: TreeStore GrepRecord
+, waitingGrep :: MVar Bool
+, activeGrep :: MVar Bool
+} deriving Typeable
+
+data GrepState = GrepState
+ deriving(Eq,Ord,Read,Show,Typeable)
+
+instance Pane IDEGrep IDEM
+ where
+ primPaneName _ = __ "Grep"
+ getAddedIndex _ = 0
+ getTopWidget = castToWidget . scrolledView
+ paneId b = "*Grep"
+
+instance RecoverablePane IDEGrep GrepState IDEM where
+ saveState p = return (Just GrepState)
+ recoverState pp GrepState = do
+ nb <- getNotebook pp
+ buildPane pp nb builder
+ builder pp nb windows = reifyIDE $ \ ideR -> do
+ grepStore <- treeStoreNew []
+ treeView <- treeViewNew
+ treeViewSetModel treeView grepStore
+
+ renderer1 <- cellRendererTextNew
+ col1 <- treeViewColumnNew
+ treeViewColumnSetTitle col1 (__ "File")
+ treeViewColumnSetSizing col1 TreeViewColumnAutosize
+ treeViewColumnSetResizable col1 True
+ treeViewColumnSetReorderable col1 True
+ treeViewAppendColumn treeView col1
+ cellLayoutPackStart col1 renderer1 True
+ cellLayoutSetAttributes col1 renderer1 grepStore
+ $ \row -> [ cellText := T.pack $ file row]
+
+ renderer2 <- cellRendererTextNew
+ col2 <- treeViewColumnNew
+ treeViewColumnSetTitle col2 (__ "Line")
+ treeViewColumnSetSizing col2 TreeViewColumnAutosize
+ treeViewColumnSetResizable col2 True
+ treeViewColumnSetReorderable col2 True
+ treeViewAppendColumn treeView col2
+ cellLayoutPackStart col2 renderer2 True
+ cellLayoutSetAttributes col2 renderer2 grepStore
+ $ \row -> [ cellText := T.pack $ show $ line row]
+
+ renderer3 <- cellRendererTextNew
+ col3 <- treeViewColumnNew
+ treeViewColumnSetTitle col3 (__ "Context")
+ treeViewColumnSetSizing col3 TreeViewColumnAutosize
+ treeViewColumnSetResizable col3 True
+ treeViewColumnSetReorderable col3 True
+ treeViewAppendColumn treeView col3
+ cellLayoutPackStart col3 renderer3 True
+ cellLayoutSetAttributes col3 renderer3 grepStore
+ $ \row -> [ cellText := T.take 2048 $ context row]
+
+
+ treeViewSetHeadersVisible treeView True
+ sel <- treeViewGetSelection treeView
+ treeSelectionSetMode sel SelectionSingle
+
+ scrolledView <- scrolledWindowNew Nothing Nothing
+ scrolledWindowSetShadowType scrolledView ShadowIn
+ containerAdd scrolledView treeView
+ scrolledWindowSetPolicy scrolledView PolicyAutomatic PolicyAutomatic
+
+ waitingGrep <- newEmptyMVar
+ activeGrep <- newEmptyMVar
+ let grep = IDEGrep {..}
+ let
+ gotoSource :: Bool -> IO Bool
+ gotoSource focus = do
+ sel <- getSelectionGrepRecord treeView grepStore
+ case sel of
+ Just record -> reflectIDE (
+ case record of
+ GrepRecord {file=f, line=l, parDir=Just pp} ->
+ goToSourceDefinition pp (Location f l 0 l 0) ?>>=
+ (\ (IDEBuffer{sourceView = sv}) -> when focus $ grabFocus sv)
+ _ -> return ()) ideR
+ Nothing -> return ()
+ return True
+ cid1 <- after treeView focusInEvent $ do
+ liftIO $ reflectIDE (makeActive grep) ideR
+ return True
+ cid2 <- on treeView keyPressEvent $ do
+ name <- eventKeyName
+ liftIO $ case name of
+ "Return" -> gotoSource True
+ "Escape" -> do
+ reflectIDE (do
+ lastActiveBufferPane ?>>= \paneName -> do
+ (PaneC pane) <- paneFromName paneName
+ makeActive pane
+ return ()
+ triggerEventIDE StartFindInitial) ideR
+ return True
+ -- gotoSource True
+ _ -> return False
+ on sel treeSelectionSelectionChanged (void (gotoSource False))
+
+
+ return (Just grep,[ConnectC cid1])
+
+getGrep :: Maybe PanePath -> IDEM IDEGrep
+getGrep Nothing = forceGetPane (Right "*Grep")
+getGrep (Just pp) = forceGetPane (Left pp)
+
+grepLineParser :: CharParser () GrepRecord
+grepLineParser = try (do
+ file <- many (noneOf ":")
+ char ':'
+ line <- int
+ char ':'
+ context <- T.pack <$> many anyChar
+ let parDir = Nothing
+ return GrepRecord {..}
+ "grepLineParser")
+
+lexer = P.makeTokenParser emptyDef
+lexeme = P.lexeme lexer
+whiteSpace = P.whiteSpace lexer
+hexadecimal = P.hexadecimal lexer
+symbol = P.symbol lexer
+identifier = P.identifier lexer
+colon = P.colon lexer
+int = fromInteger <$> P.integer lexer
+
+getSelectionGrepRecord :: TreeView
+ -> TreeStore GrepRecord
+ -> IO (Maybe GrepRecord)
+getSelectionGrepRecord treeView grepStore = do
+ treeSelection <- treeViewGetSelection treeView
+ paths <- treeSelectionGetSelectedRows treeSelection
+ case paths of
+ p:_ -> Just <$> treeStoreGetValue grepStore p
+ _ -> return Nothing
+
+--TODO srp use default loglaunch probably
+grepWorkspace :: Text -> Bool -> WorkspaceAction
+grepWorkspace "" caseSensitive = return ()
+grepWorkspace regexString caseSensitive = do
+ ws <- ask
+ maybeActive <- lift $ readIDE activePack
+ let packages = case maybeActive of
+ Just active -> active : filter (/= active) (wsAllPackages ws)
+ Nothing -> wsAllPackages ws
+ lift $ grepDirectories regexString caseSensitive $
+ map (dropFileName . ipdCabalFile) packages
+
+grepDirectories :: Text -> Bool -> [FilePath] -> IDEAction
+grepDirectories regexString caseSensitive dirs = do
+ grep <- getGrep Nothing
+ let store = grepStore grep
+ ideRef <- ask
+ liftIO $ do
+ bringPaneToFront grep
+ forkIO $ do
+ putMVar (waitingGrep grep) True
+ putMVar (activeGrep grep) True
+ takeMVar (waitingGrep grep)
+
+ postGUISync $ treeStoreClear store
+
+ totalFound <- foldM (\a dir -> do
+ subDirs <- filter (\f ->
+ not ("." `isPrefixOf` f)
+ && f `notElem` ["_darcs", "dist", "vendor"]) <$> getDirectoryContents dir
+ nooneWaiting <- isEmptyMVar (waitingGrep grep)
+ found <- if nooneWaiting
+ then do
+ (output, pid) <- runTool "grep" ((if caseSensitive then [] else ["-i"])
+ ++ ["-R", "-E", "-n", "-I",
+ "--exclude=*~",
+ "--exclude-dir=.svn",
+ "--exclude-dir=_darcs",
+ "--exclude-dir=.git",
+ regexString] ++ map T.pack subDirs) (Just dir)
+ reflectIDE (
+ output $$ do
+ let max = 1000
+ CL.isolate max =$ do
+ n <- setGrepResults dir
+ when (n >= max) . liftIO $ do
+ debugM "leksah" "interrupting grep process"
+ interruptProcessGroupOf pid
+ `catch` \(_::SomeException) -> return ()
+ postGUISync $ do
+ nDir <- treeModelIterNChildren store Nothing
+ treeStoreChange store [nDir-1] (\r -> r{ context = __ "(Stoped Searching)" })
+ return ()
+ CL.sinkNull
+ return n) ideRef
+ else return 0
+ return $ a + found) 0 dirs
+
+ nooneWaiting <- isEmptyMVar (waitingGrep grep)
+ when nooneWaiting $ postGUISync $ do
+ nDir <- treeModelIterNChildren store Nothing
+ treeStoreInsert store [] nDir $ GrepRecord (T.unpack $ __ "Search Complete") totalFound "" Nothing
+
+ void $ takeMVar (activeGrep grep)
+ return ()
+
+setGrepResults :: FilePath -> C.Sink ToolOutput IDEM Int
+setGrepResults dir = do
+ ideRef <- lift ask
+ grep <- lift $ getGrep Nothing
+ log <- lift getLog
+ defaultLogLaunch <- lift getDefaultLogLaunch
+ let store = grepStore grep
+ view = treeView grep
+ nDir <- liftIO $ postGUISync $ do
+ nDir <- treeModelIterNChildren store Nothing
+ treeStoreInsert store [] nDir $ GrepRecord dir 0 "" Nothing
+ when (nDir == 0) (void $ widgetGrabFocus view)
+ return nDir
+ CL.foldM (\count line ->
+ if isError line
+ then do
+ liftIO $ postGUISync $ reflectIDE (void $ defaultLineLogger log defaultLogLaunch line) ideRef
+ return count
+ else
+ case process dir line of
+ Nothing -> return count
+ Just record -> liftIO $ do
+ nooneWaiting <- isEmptyMVar (waitingGrep grep)
+ when nooneWaiting $ postGUISync $ do
+ parent <- treeModelGetIter store [nDir]
+ n <- treeModelIterNChildren store parent
+ treeStoreInsert store [nDir] n record
+ treeStoreChange store [nDir] (\r -> r{ line = n+1 })
+ when (nDir == 0 && n == 0) $
+ treeViewExpandAll view
+ return (count+1)) 0
+ where
+ process pp (ToolOutput line) =
+ case parse grepLineParser "" $ T.unpack line of
+ Right record -> Just record{parDir = Just pp}
+ _ -> Nothing
+ process _ _ = Nothing
+
+ isError (ToolExit ExitSuccess) = False
+ isError (ToolExit (ExitFailure 1)) = False
+ isError o = isNothing (process "" o)
+
+
+
+
diff --git a/src/IDE/Pane/HLint.hs b/src/IDE/Pane/HLint.hs
--- a/src/IDE/Pane/HLint.hs
+++ b/src/IDE/Pane/HLint.hs
@@ -1,341 +1,349 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE OverloadedStrings #-}
------------------------------------------------------------------------------
---
--- Module : IDE.Pane.HLint
--- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie
--- License : GNU-GPL
---
--- Maintainer :
--- Stability : provisional
--- Portability : portable
---
--- | The pane of ide where HLint results are displayed
---
------------------------------------------------------------------------------
-
-module IDE.Pane.HLint (
- IDEHLint(..)
-, refreshHLint
-, HLintState(..)
-, getHLint
-) where
-
-
-import Graphics.UI.Gtk hiding (get)
-import qualified Graphics.UI.Gtk.Gdk.Events as Gdk
-import Text.ParserCombinators.Parsec.Language
-import Text.ParserCombinators.Parsec hiding(Parser)
-import qualified Text.ParserCombinators.Parsec.Token as P
-import Data.Maybe
-import Data.Typeable
-import IDE.Core.State hiding (SrcSpan(..))
-import IDE.BufferMode
-import IDE.LogRef (logOutput, defaultLineLogger)
-import IDE.Pane.SourceBuffer
- (goToSourceDefinition', maybeActiveBuf, IDEBuffer(..), replaceHLintSource)
-import IDE.TextEditor (grabFocus)
-import Control.Applicative ((<$>))
-import System.FilePath ((), dropFileName)
-import System.Exit (ExitCode(..))
-import IDE.Pane.Log (getLog)
-import Control.Monad (void, forM_, foldM, when)
-import Control.Monad.Trans.Reader (ask)
-import Control.Monad.Trans.Class (MonadTrans(..))
-import Control.Monad.IO.Class (MonadIO(..))
-import Language.Haskell.HLint (Suggestion(..), suggestionLocation)
-import Language.Haskell.Exts (SrcLoc(..))
-import Language.Haskell.Exts.SrcLoc (SrcSpan(..))
-
-import qualified Language.Haskell.HLint2 as H
-import IDE.Utils.GUIUtils (__, treeViewContextMenu)
-import Data.List (isPrefixOf, findIndex)
-import Debug.Trace (trace)
-import Control.Exception (SomeException, catch)
-import Distribution.ModuleName (ModuleName)
-import IDE.Metainfo.Provider (getWorkspaceInfo)
-import qualified Data.Map as Map (keys, lookup)
-import Distribution.Package (PackageIdentifier(..))
-import Data.Text (Text)
-import qualified Data.Text as T
- (replicate, unlines, init, lines, pack, unpack)
-import Data.Monoid ((<>))
-
-data HLintRecord = HLintRecord {
- condPackage :: Maybe IDEPackage
- , context :: Text
- , condIdea :: Maybe H.Idea
- , parDir :: Maybe FilePath
- } deriving (Eq)
-
-isDir HLintRecord{parDir = Nothing} = True
-isDir otherwies = False
-
--- | A HLint pane description
---
-
-data IDEHLint = IDEHLint {
- scrolledView :: ScrolledWindow
-, treeView :: TreeView
-, hlintStore :: TreeStore HLintRecord
-} deriving Typeable
-
-data HLintState = HLintState
- deriving(Eq,Ord,Read,Show,Typeable)
-
-instance Pane IDEHLint IDEM
- where
- primPaneName _ = "HLint"
- getAddedIndex _ = 0
- getTopWidget = castToWidget . scrolledView
- paneId b = "*HLint"
-
-instance RecoverablePane IDEHLint HLintState IDEM where
- saveState p = return (Just HLintState)
- recoverState pp HLintState = do
- nb <- getNotebook pp
- buildPane pp nb builder
- builder pp nb windows = reifyIDE $ \ ideR -> do
- hlintStore <- treeStoreNew []
- treeView <- treeViewNew
- treeViewSetModel treeView hlintStore
-
- renderer1 <- cellRendererTextNew
- renderer10 <- cellRendererPixbufNew
- col1 <- treeViewColumnNew
- treeViewColumnSetTitle col1 (__ "Context")
- treeViewColumnSetSizing col1 TreeViewColumnAutosize
- treeViewColumnSetResizable col1 True
- treeViewColumnSetReorderable col1 True
- treeViewAppendColumn treeView col1
- cellLayoutPackStart col1 renderer10 False
- cellLayoutPackStart col1 renderer1 True
- cellLayoutSetAttributes col1 renderer1 hlintStore
- $ \row -> [ cellText := context row ]
-
- treeViewSetHeadersVisible treeView False
- sel <- treeViewGetSelection treeView
- treeSelectionSetMode sel SelectionSingle
-
- scrolledView <- scrolledWindowNew Nothing Nothing
- scrolledWindowSetShadowType scrolledView ShadowIn
- containerAdd scrolledView treeView
- scrolledWindowSetPolicy scrolledView PolicyAutomatic PolicyAutomatic
-
- let hlint = IDEHLint {..}
- cid1 <- after treeView focusInEvent $ do
- liftIO $ reflectIDE (makeActive hlint) ideR
- return True
- cid2 <- on treeView rowExpanded $ \ iter path -> do
- record <- treeStoreGetValue hlintStore path
- case record of
- HLintRecord { condPackage = Just p, parDir = Nothing } ->
- reflectIDE (refreshDir hlintStore iter p) ideR
- _ -> reflectIDE (ideMessage Normal (__ "Unexpected Expansion in HLint Pane")) ideR
- cid3 <- on treeView rowActivated $ \ path col -> do
- record <- treeStoreGetValue hlintStore path
- mbIter <- treeModelGetIter hlintStore path
- case (mbIter, record) of
- (Just iter, HLintRecord { condPackage = Just p, parDir = Nothing }) ->
- reflectIDE (refreshDir hlintStore iter p) ideR
- _ -> return ()
- cid4 <- on treeView keyPressEvent $ do
- name <- eventKeyName
- liftIO $ case name of
- "Return" -> reflectIDE (gotoSource True treeView hlintStore) ideR
- "Escape" -> do
- reflectIDE (do
- lastActiveBufferPane ?>>= \paneName -> do
- (PaneC pane) <- paneFromName paneName
- makeActive pane
- return ()
- triggerEventIDE StartFindInitial) ideR
- return True
- -- gotoSource True
- _ -> return False
- treeViewContextMenu treeView
- $ hlintContextMenu ideR hlintStore treeView
- on sel treeSelectionSelectionChanged (reflectIDE (void $ gotoSource False treeView hlintStore) ideR)
-
- return (Just hlint,map ConnectC [cid1])
-
-getHLint :: Maybe PanePath -> IDEM IDEHLint
-getHLint Nothing = forceGetPane (Right "*HLint")
-getHLint (Just pp) = forceGetPane (Left pp)
-
-data FindResult = WhereExpected TreeIter | Found TreeIter | NotFound
-
-find :: Eq a => a -> TreeStore a -> Maybe TreeIter -> IO FindResult
-find _ _ Nothing = return NotFound
-find a store (Just iter) = do
- row <- treeModelGetRow store iter
- if row == a
- then return $ WhereExpected iter
- else treeModelIterNext store iter >>= find'
- where
- find' :: Maybe TreeIter -> IO FindResult
- find' Nothing = return NotFound
- find' (Just iter) = do
- row <- treeModelGetRow store iter
- if row == a
- then return $ Found iter
- else treeModelIterNext store iter >>= find'
-
-removeUntil :: Eq a => a -> TreeStore a -> TreePath -> IO ()
-removeUntil a store path = do
- row <- treeStoreGetValue store path
- when (row /= a) $ do
- found <- treeStoreRemove store path
- when found $ removeUntil a store path
-
-removeRemaining :: TreeStore a -> TreePath -> IO ()
-removeRemaining store path = do
- found <- treeStoreRemove store path
- when found $ removeRemaining store path
-
-
-getSelectionHLintRecord :: TreeView
- -> TreeStore HLintRecord
- -> IO (Maybe HLintRecord)
-getSelectionHLintRecord treeView hlintStore = do
- treeSelection <- treeViewGetSelection treeView
- paths <- treeSelectionGetSelectedRows treeSelection
- case paths of
- p:_ -> Just <$> treeStoreGetValue hlintStore p
- _ -> return Nothing
-
-refreshHLint :: WorkspaceAction
-refreshHLint = do
- ws <- ask
- maybeActive <- lift $ readIDE activePack
- let packages = case maybeActive of
- Just active -> active : filter (/= active) (wsAllPackages ws)
- Nothing -> wsAllPackages ws
- lift $ hlintDirectories2 packages
-
-
---gotoSource :: Bool -> IDEM Bool
-gotoSource focus treeView hlintStore = do
- sel <- liftIO $ getSelectionHLintRecord treeView hlintStore
- case sel of
- Just record ->
- case record of
- HLintRecord {condIdea = Just idea} ->
- goToSourceDefinition' (srcSpanFilename (H.ideaSpan idea))
- (Location "" (srcSpanStartLine (H.ideaSpan idea))
- (srcSpanStartColumn (H.ideaSpan idea))
- (srcSpanEndLine (H.ideaSpan idea))
- (srcSpanEndColumn (H.ideaSpan idea)))
- ?>>= (\(IDEBuffer {sourceView = sv}) -> when focus $ grabFocus sv)
- _ -> return ()
- Nothing -> return ()
- return True
-
-
-hlintDirectories2 :: [IDEPackage] -> IDEAction
-hlintDirectories2 packages = do
- hlint <- getHLint Nothing
- let store = hlintStore hlint
- liftIO $ do
- treeStoreClear store
- forM_ packages $ \ p -> do
- nDir <- treeModelIterNChildren store Nothing
- treeStoreInsert store [] nDir $ HLintRecord (Just p) (packageIdentifierToString (ipdPackageId p)) Nothing Nothing
- treeStoreInsert store [nDir] 0 $ HLintRecord (Just p) (packageIdentifierToString (ipdPackageId p)) Nothing Nothing
-
-refreshDir :: TreeStore HLintRecord -> TreeIter -> IDEPackage -> IDEM ()
-refreshDir store iter package = do
- mbHlintDir <- liftIO $ leksahSubDir "hlint"
- let datadirOpt = case mbHlintDir of
- Just d -> "--datadir":[d]
- Nothing -> []
- (flags, classify, hint) <- liftIO H.autoSettings
- let modules = Map.keys (ipdModules package)
- pathes <- getSourcePathes (ipdPackageId package) modules
- resL <- liftIO $ mapM (\dir -> H.parseModuleEx flags dir Nothing) pathes
- let resOk = mapMaybe (\ pr -> case pr of
- Left e -> trace ("can't parse: " ++ H.parseErrorContents e ++
- " location " ++ show H.parseErrorLocation) Nothing
- Right r -> Just r) resL
- let ideas = H.applyHints classify hint resOk
- liftIO $ setHLint2Results store iter (T.unpack $ packageIdentifierToString (ipdPackageId package)) ideas
- return ()
-
-
-getSourcePathes :: PackageIdentifier -> [ModuleName] -> IDEM [FilePath]
-getSourcePathes packId names = do
- mbWorkspaceInfo <- getWorkspaceInfo
- case mbWorkspaceInfo of
- Nothing -> return []
- Just (sc, _) -> return (mapMaybe (sourcePathFromScope sc) names)
- where
- sourcePathFromScope :: GenScope -> ModuleName -> Maybe FilePath
- sourcePathFromScope (GenScopeC (PackScope l _)) mn =
- case packId `Map.lookup` l of
- Just pack ->
- case filter (\md -> modu (mdModuleId md) == mn)
- (pdModules pack) of
- (mod : tl) -> mdMbSourcePath mod
- [] -> Nothing
- Nothing -> Nothing
-
-
-hlint2Record dir idea = HLintRecord {
- condPackage = Nothing,
- context = T.pack $ show idea,
- condIdea = Just idea,
- parDir = Just dir}
-
-setHLint2Results :: TreeStore HLintRecord -> TreeIter -> FilePath -> [H.Idea] -> IO Int
-setHLint2Results store parent dir ideas = do
- parentPath <- treeModelGetPath store parent
- forM_ (zip [0..] records) $ \(n, record) -> do
- mbChild <- treeModelIterNthChild store (Just parent) n
- findResult <- find record store mbChild
- case (mbChild, findResult) of
- (_, WhereExpected _) -> return ()
- (Just iter, Found _) -> do
- path <- treeModelGetPath store iter
- removeUntil record store path
- _ -> treeStoreInsert store parentPath n record
- removeRemaining store (parentPath++[nRecords])
- return nRecords
- where
- records = map (hlint2Record dir) ideas
- nRecords = length records
-
-hlintContextMenu :: IDERef
- -> TreeStore HLintRecord
- -> TreeView
- -> Menu
- -> IO ()
-hlintContextMenu ideR store treeView theMenu = do
- mbSel <- getSelectionHLintRecord treeView store
- item0 <- menuItemNewWithLabel (__ "Replace")
- item0 `on` menuItemActivate $ reflectIDE (replaceHlint store treeView mbSel) ideR
- menuShellAppend theMenu item0
- where
- replaceableSelection Nothing = False
- replaceableSelection (Just s) | isNothing (parDir s) = True
- | otherwise = False
-
-replaceHlint store treeView (Just sel) =
- case condIdea sel of
- Just idea | isJust (H.ideaTo idea) ->
- let lined = T.lines (T.pack $ fromJust (H.ideaTo idea))
- startColumn = srcSpanStartColumn (H.ideaSpan idea)
- source = T.init $ T.unlines (head lined :
- map (\ s -> T.replicate startColumn " " <> s) (tail lined))
- in
- replaceHLintSource (srcSpanFilename (H.ideaSpan idea))
- (srcSpanStartLine (H.ideaSpan idea))
- startColumn
- (srcSpanEndLine (H.ideaSpan idea))
- (srcSpanEndColumn (H.ideaSpan idea))
- source
- otherwise -> return ()
-replaceHlint _ _ Nothing = return ()
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
+-----------------------------------------------------------------------------
+--
+-- Module : IDE.Pane.HLint
+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie
+-- License : GNU-GPL
+--
+-- Maintainer :
+-- Stability : provisional
+-- Portability : portable
+--
+-- | The pane of ide where HLint results are displayed
+--
+-----------------------------------------------------------------------------
+
+module IDE.Pane.HLint (
+ IDEHLint(..)
+, refreshHLint
+, HLintState(..)
+, getHLint
+) where
+
+
+import Graphics.UI.Gtk hiding (get)
+import qualified Graphics.UI.Gtk.Gdk.Events as Gdk
+import Text.ParserCombinators.Parsec.Language
+import Text.ParserCombinators.Parsec hiding(Parser)
+import qualified Text.ParserCombinators.Parsec.Token as P
+import Data.Maybe
+import Data.Typeable
+import IDE.Core.State hiding (SrcSpan(..))
+import IDE.BufferMode
+import IDE.LogRef (logOutput, defaultLineLogger)
+import IDE.Pane.SourceBuffer
+ (goToSourceDefinition', maybeActiveBuf, IDEBuffer(..), replaceHLintSource)
+import IDE.TextEditor (grabFocus)
+import Control.Applicative ((<$>))
+import System.FilePath ((), dropFileName)
+import System.Exit (ExitCode(..))
+import IDE.Pane.Log (getLog)
+import Control.Monad (void, forM_, foldM, when)
+import Control.Monad.Trans.Reader (ask)
+import Control.Monad.Trans.Class (MonadTrans(..))
+import Control.Monad.IO.Class (MonadIO(..))
+import Language.Haskell.HLint (Suggestion(..), suggestionLocation)
+import Language.Haskell.Exts (SrcLoc(..))
+import Language.Haskell.Exts.SrcLoc (SrcSpan(..))
+
+import qualified Language.Haskell.HLint2 as H
+import IDE.Utils.GUIUtils (__, treeViewContextMenu)
+import Data.List (isPrefixOf, findIndex)
+import Debug.Trace (trace)
+import Control.Exception (SomeException, catch)
+import Distribution.ModuleName (ModuleName)
+import IDE.Metainfo.Provider (getWorkspaceInfo)
+import qualified Data.Map as Map (keys, lookup)
+import Distribution.Package (PackageIdentifier(..))
+import Data.Text (Text)
+import qualified Data.Text as T
+ (replicate, unlines, init, lines, pack, unpack)
+import Data.Monoid ((<>))
+import qualified System.IO.Strict as S (readFile)
+
+data HLintRecord = HLintRecord {
+ condPackage :: Maybe IDEPackage
+ , context :: Text
+ , condIdea :: Maybe H.Idea
+ , parDir :: Maybe FilePath
+ } deriving (Eq)
+
+isDir HLintRecord{parDir = Nothing} = True
+isDir otherwies = False
+
+-- | A HLint pane description
+--
+
+data IDEHLint = IDEHLint {
+ scrolledView :: ScrolledWindow
+, treeView :: TreeView
+, hlintStore :: TreeStore HLintRecord
+} deriving Typeable
+
+data HLintState = HLintState
+ deriving(Eq,Ord,Read,Show,Typeable)
+
+instance Pane IDEHLint IDEM
+ where
+ primPaneName _ = "HLint"
+ getAddedIndex _ = 0
+ getTopWidget = castToWidget . scrolledView
+ paneId b = "*HLint"
+
+instance RecoverablePane IDEHLint HLintState IDEM where
+ saveState p = return (Just HLintState)
+ recoverState pp HLintState = do
+ nb <- getNotebook pp
+ buildPane pp nb builder
+ builder pp nb windows = reifyIDE $ \ ideR -> do
+ hlintStore <- treeStoreNew []
+ treeView <- treeViewNew
+ treeViewSetModel treeView hlintStore
+
+ renderer1 <- cellRendererTextNew
+ renderer10 <- cellRendererPixbufNew
+ col1 <- treeViewColumnNew
+ treeViewColumnSetTitle col1 (__ "Context")
+ treeViewColumnSetSizing col1 TreeViewColumnAutosize
+ treeViewColumnSetResizable col1 True
+ treeViewColumnSetReorderable col1 True
+ treeViewAppendColumn treeView col1
+ cellLayoutPackStart col1 renderer10 False
+ cellLayoutPackStart col1 renderer1 True
+ cellLayoutSetAttributes col1 renderer1 hlintStore
+ $ \row -> [ cellText := context row ]
+
+ treeViewSetHeadersVisible treeView False
+ sel <- treeViewGetSelection treeView
+ treeSelectionSetMode sel SelectionSingle
+
+ scrolledView <- scrolledWindowNew Nothing Nothing
+ scrolledWindowSetShadowType scrolledView ShadowIn
+ containerAdd scrolledView treeView
+ scrolledWindowSetPolicy scrolledView PolicyAutomatic PolicyAutomatic
+
+ let hlint = IDEHLint {..}
+ cid1 <- after treeView focusInEvent $ do
+ liftIO $ reflectIDE (makeActive hlint) ideR
+ return True
+ cid2 <- on treeView rowExpanded $ \ iter path -> do
+ record <- treeStoreGetValue hlintStore path
+ case record of
+ HLintRecord { condPackage = Just p, parDir = Nothing } ->
+ reflectIDE (refreshDir hlintStore iter p) ideR
+ _ -> reflectIDE (ideMessage Normal (__ "Unexpected Expansion in HLint Pane")) ideR
+ cid3 <- on treeView rowActivated $ \ path col -> do
+ record <- treeStoreGetValue hlintStore path
+ mbIter <- treeModelGetIter hlintStore path
+ case (mbIter, record) of
+ (Just iter, HLintRecord { condPackage = Just p, parDir = Nothing }) ->
+ reflectIDE (refreshDir hlintStore iter p) ideR
+ _ -> return ()
+ cid4 <- on treeView keyPressEvent $ do
+ name <- eventKeyName
+ liftIO $ case name of
+ "Return" -> reflectIDE (gotoSource True treeView hlintStore) ideR
+ "Escape" -> do
+ reflectIDE (do
+ lastActiveBufferPane ?>>= \paneName -> do
+ (PaneC pane) <- paneFromName paneName
+ makeActive pane
+ return ()
+ triggerEventIDE StartFindInitial) ideR
+ return True
+ -- gotoSource True
+ _ -> return False
+ treeViewContextMenu treeView
+ $ hlintContextMenu ideR hlintStore treeView
+ on sel treeSelectionSelectionChanged (reflectIDE (void $ gotoSource False treeView hlintStore) ideR)
+
+ return (Just hlint,map ConnectC [cid1])
+
+getHLint :: Maybe PanePath -> IDEM IDEHLint
+getHLint Nothing = forceGetPane (Right "*HLint")
+getHLint (Just pp) = forceGetPane (Left pp)
+
+data FindResult = WhereExpected TreeIter | Found TreeIter | NotFound
+
+find :: Eq a => a -> TreeStore a -> Maybe TreeIter -> IO FindResult
+find _ _ Nothing = return NotFound
+find a store (Just iter) = do
+ row <- treeModelGetRow store iter
+ if row == a
+ then return $ WhereExpected iter
+ else treeModelIterNext store iter >>= find'
+ where
+ find' :: Maybe TreeIter -> IO FindResult
+ find' Nothing = return NotFound
+ find' (Just iter) = do
+ row <- treeModelGetRow store iter
+ if row == a
+ then return $ Found iter
+ else treeModelIterNext store iter >>= find'
+
+removeUntil :: Eq a => a -> TreeStore a -> TreePath -> IO ()
+removeUntil a store path = do
+ row <- treeStoreGetValue store path
+ when (row /= a) $ do
+ found <- treeStoreRemove store path
+ when found $ removeUntil a store path
+
+removeRemaining :: TreeStore a -> TreePath -> IO ()
+removeRemaining store path = do
+ found <- treeStoreRemove store path
+ when found $ removeRemaining store path
+
+
+getSelectionHLintRecord :: TreeView
+ -> TreeStore HLintRecord
+ -> IO (Maybe HLintRecord)
+getSelectionHLintRecord treeView hlintStore = do
+ treeSelection <- treeViewGetSelection treeView
+ paths <- treeSelectionGetSelectedRows treeSelection
+ case paths of
+ p:_ -> Just <$> treeStoreGetValue hlintStore p
+ _ -> return Nothing
+
+refreshHLint :: WorkspaceAction
+refreshHLint = do
+ ws <- ask
+ maybeActive <- lift $ readIDE activePack
+ let packages = case maybeActive of
+ Just active -> active : filter (/= active) (wsAllPackages ws)
+ Nothing -> wsAllPackages ws
+ lift $ hlintDirectories2 packages
+
+
+--gotoSource :: Bool -> IDEM Bool
+gotoSource focus treeView hlintStore = do
+ sel <- liftIO $ getSelectionHLintRecord treeView hlintStore
+ case sel of
+ Just record ->
+ case record of
+ HLintRecord {condIdea = Just idea} ->
+ goToSourceDefinition' (srcSpanFilename (H.ideaSpan idea))
+ (Location "" (srcSpanStartLine (H.ideaSpan idea))
+ (srcSpanStartColumn (H.ideaSpan idea))
+ (srcSpanEndLine (H.ideaSpan idea))
+ (srcSpanEndColumn (H.ideaSpan idea)))
+ ?>>= (\(IDEBuffer {sourceView = sv}) -> when focus $ grabFocus sv)
+ _ -> return ()
+ Nothing -> return ()
+ return True
+
+
+hlintDirectories2 :: [IDEPackage] -> IDEAction
+hlintDirectories2 packages = do
+ hlint <- getHLint Nothing
+ let store = hlintStore hlint
+ liftIO $ do
+ treeStoreClear store
+ forM_ packages $ \ p -> do
+ nDir <- treeModelIterNChildren store Nothing
+ treeStoreInsert store [] nDir $ HLintRecord (Just p) (packageIdentifierToString (ipdPackageId p)) Nothing Nothing
+ treeStoreInsert store [nDir] 0 $ HLintRecord (Just p) (packageIdentifierToString (ipdPackageId p)) Nothing Nothing
+
+refreshDir :: TreeStore HLintRecord -> TreeIter -> IDEPackage -> IDEM ()
+refreshDir store iter package = do
+ mbHlintDir <- liftIO $ leksahSubDir "hlint"
+ (flags, classify, hint) <- liftIO $ case mbHlintDir of
+ Just d ->
+#if MIN_VERSION_hlint(1, 9, 13)
+ H.autoSettings' d
+#else
+ H.autoSettings
+#endif
+ Nothing -> H.autoSettings
+ let modules = Map.keys (ipdModules package)
+ paths <- getSourcePaths (ipdPackageId package) modules
+ resL <- liftIO $ mapM (\ file -> do
+ str <- S.readFile file
+ H.parseModuleEx flags file (Just str)) paths
+ let resOk = mapMaybe (\ pr -> case pr of
+ Left e -> trace ("can't parse: " ++ H.parseErrorContents e ++
+ " location " ++ show H.parseErrorLocation) Nothing
+ Right r -> Just r) resL
+ let ideas = H.applyHints classify hint resOk
+ liftIO $ setHLint2Results store iter (T.unpack $ packageIdentifierToString (ipdPackageId package)) ideas
+ return ()
+
+
+getSourcePaths :: PackageIdentifier -> [ModuleName] -> IDEM [FilePath]
+getSourcePaths packId names = do
+ mbWorkspaceInfo <- getWorkspaceInfo
+ case mbWorkspaceInfo of
+ Nothing -> return []
+ Just (sc, _) -> return (mapMaybe (sourcePathFromScope sc) names)
+ where
+ sourcePathFromScope :: GenScope -> ModuleName -> Maybe FilePath
+ sourcePathFromScope (GenScopeC (PackScope l _)) mn =
+ case packId `Map.lookup` l of
+ Just pack ->
+ case filter (\md -> modu (mdModuleId md) == mn)
+ (pdModules pack) of
+ (mod : tl) -> mdMbSourcePath mod
+ [] -> Nothing
+ Nothing -> Nothing
+
+
+hlint2Record dir idea = HLintRecord {
+ condPackage = Nothing,
+ context = T.pack $ show idea,
+ condIdea = Just idea,
+ parDir = Just dir}
+
+setHLint2Results :: TreeStore HLintRecord -> TreeIter -> FilePath -> [H.Idea] -> IO Int
+setHLint2Results store parent dir ideas = do
+ parentPath <- treeModelGetPath store parent
+ forM_ (zip [0..] records) $ \(n, record) -> do
+ mbChild <- treeModelIterNthChild store (Just parent) n
+ findResult <- find record store mbChild
+ case (mbChild, findResult) of
+ (_, WhereExpected _) -> return ()
+ (Just iter, Found _) -> do
+ path <- treeModelGetPath store iter
+ removeUntil record store path
+ _ -> treeStoreInsert store parentPath n record
+ removeRemaining store (parentPath++[nRecords])
+ return nRecords
+ where
+ records = map (hlint2Record dir) ideas
+ nRecords = length records
+
+hlintContextMenu :: IDERef
+ -> TreeStore HLintRecord
+ -> TreeView
+ -> Menu
+ -> IO ()
+hlintContextMenu ideR store treeView theMenu = do
+ mbSel <- getSelectionHLintRecord treeView store
+ item0 <- menuItemNewWithLabel (__ "Replace")
+ item0 `on` menuItemActivate $ reflectIDE (replaceHlint store treeView mbSel) ideR
+ menuShellAppend theMenu item0
+ where
+ replaceableSelection Nothing = False
+ replaceableSelection (Just s) | isNothing (parDir s) = True
+ | otherwise = False
+
+replaceHlint store treeView (Just sel) =
+ case condIdea sel of
+ Just idea | isJust (H.ideaTo idea) ->
+ let lined = T.lines (T.pack $ fromJust (H.ideaTo idea))
+ startColumn = srcSpanStartColumn (H.ideaSpan idea)
+ source = T.init $ T.unlines (head lined :
+ map (\ s -> T.replicate startColumn " " <> s) (tail lined))
+ in
+ replaceHLintSource (srcSpanFilename (H.ideaSpan idea))
+ (srcSpanStartLine (H.ideaSpan idea))
+ startColumn
+ (srcSpanEndLine (H.ideaSpan idea))
+ (srcSpanEndColumn (H.ideaSpan idea))
+ source
+ otherwise -> return ()
+replaceHlint _ _ Nothing = return ()
diff --git a/src/IDE/Pane/Info.hs b/src/IDE/Pane/Info.hs
--- a/src/IDE/Pane/Info.hs
+++ b/src/IDE/Pane/Info.hs
@@ -48,7 +48,7 @@
scrolledWindowSetPolicy, castToWidget, ScrolledWindow)
import Graphics.UI.Gtk.General.Enums (PolicyType(..))
import System.Glib.Signals (on)
-import Control.Monad (void, when)
+import Control.Monad (unless, void, when)
import Data.Foldable (forM_)
import qualified Data.Text as T (unpack, pack, null)
import Data.Monoid ((<>))
@@ -95,7 +95,7 @@
createHyperLinkSupport descriptionView sw (\_ _ iter -> do
(beg, en) <- getIdentifierUnderCursorFromIter (iter, iter)
return (beg, en)) (\_ shift' slice ->
- when (not $ T.null slice) $ do
+ unless (T.null slice) $ do
-- liftIO$ print ("slice",slice)
triggerEventIDE (SelectInfo slice shift')
return ()
diff --git a/src/IDE/Pane/Trace.hs b/src/IDE/Pane/Trace.hs
--- a/src/IDE/Pane/Trace.hs
+++ b/src/IDE/Pane/Trace.hs
@@ -260,7 +260,7 @@
eof
return []
- (T.unpack $ __ "traces parser")
+ T.unpack (__ "traces parser")
traceParser :: CharParser () TraceHist
traceParser = do
@@ -274,7 +274,7 @@
span <- srcSpanParser
symbol ")"
return (TraceHist False index function span)
- (T.unpack $ __ "trace parser")
+ T.unpack (__ "trace parser")
lexer = P.makeTokenParser emptyDef
colon = P.colon lexer
diff --git a/src/IDE/TextEditor/Yi.hs b/src/IDE/TextEditor/Yi.hs
--- a/src/IDE/TextEditor/Yi.hs
+++ b/src/IDE/TextEditor/Yi.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
--
-- Module : IDE.TextEditor.Yi
@@ -55,8 +56,9 @@
Point(..), MarkValue(..), lineOf, pointOfLineColB,
askMarks, insMark, sizeB, getRawestSelectRegionB, mkRegion,
deleteRegionB, newMarkB, Mark, pointB, moveTo, savingPointB, Point,
- withGivenBuffer0, liftEditor, BufferM, BufferRef, Mode(..),
- IndentSettings(..))
+ withGivenBuffer, withEditor, BufferM, BufferRef, Mode(..),
+ IndentSettings(..), BufferId(..))
+import qualified Yi.Rope as Yi (length, fromText)
import Control.Applicative ((<$>))
import Yi.Keymap.Cua (paste, cut, copy)
import Yi.Buffer.Basic (Direction(..))
@@ -92,14 +94,14 @@
newYiBuffer mbFilename contents = do
liftYiControl $ do
let (filename, id) = case mbFilename of
- Just fn -> (fn, Right fn)
- Nothing -> ("Unknown.hs", Left "*leksah*")
- buffer <- Yi.newBuffer id (T.unpack contents)
+ Just fn -> (fn, FileBuffer fn)
+ Nothing -> ("Unknown.hs", MemBuffer "*leksah*")
+ buffer <- Yi.newBuffer id $ Yi.fromText contents
setBufferMode filename buffer
return $ YiBuffer buffer
withYiBuffer' :: BufferRef -> BufferM a -> IDEM a
-withYiBuffer' b f = liftYi $ liftEditor $ withGivenBuffer0 b f
+withYiBuffer' b f = liftYi $ withEditor $ withGivenBuffer b f
withYiBuffer :: Buffer -> BufferM a -> IDEM a
withYiBuffer b f = withYiBuffer' (fBufRef b) f
@@ -152,10 +154,10 @@
beginUserAction (YiBuffer fb) = return () -- TODO
canRedo (YiBuffer fb) = return True -- TODO
canUndo (YiBuffer fb) = return True -- TODO
- copyClipboard (YiBuffer fb) _ = liftYi $ liftEditor $ copy
+ copyClipboard (YiBuffer fb) _ = liftYi $ withEditor $ copy
createMark (YiBuffer b) (YiIter (Iter _ p)) leftGravity = withYiBuffer b $
YiMark <$> newMarkB (MarkValue p (if leftGravity then Backward else Forward))
- cutClipboard (YiBuffer fb) clipboard defaultEditable = liftYi $ liftEditor $ cut
+ cutClipboard (YiBuffer fb) clipboard defaultEditable = liftYi $ withEditor $ cut
delete (YiBuffer b) (YiIter (Iter _ first)) (YiIter (Iter _ last)) =
withYiBuffer b $ deleteRegionB $ mkRegion first last
deleteSelection (YiBuffer b) = withYiBuffer b $ do
@@ -178,20 +180,20 @@
getInsertIter (YiBuffer b) = withYiBuffer b $ do
insertMark <- insMark <$> askMarks
mkYiIter b <$> (use . markPointA) insertMark
- getSlice (YiBuffer b) (YiIter first) (YiIter last) includeHidenChars = liftYiControl $ T.pack <$>
+ getSlice (YiBuffer b) (YiIter first) (YiIter last) includeHidenChars = liftYiControl $
Yi.getText b first last
getStartIter (YiBuffer b) = return $ mkYiIter b $ Point 0
getTagTable (YiBuffer b) = return YiTagTable -- TODO
- getText (YiBuffer b) (YiIter first) (YiIter last) includeHidenChars = liftYiControl $ T.pack <$>
+ getText (YiBuffer b) (YiIter first) (YiIter last) includeHidenChars = liftYiControl $
Yi.getText b first last
hasSelection (YiBuffer b) = withYiBuffer b $ do
region <- getRawestSelectRegionB
return $ not $ regionIsEmpty region
- insert (YiBuffer b) (YiIter (Iter _ p)) text = withYiBuffer b $ insertNAt (T.unpack text) p
+ insert (YiBuffer b) (YiIter (Iter _ p)) text = withYiBuffer b $ insertNAt (Yi.fromText text) p
newView (YiBuffer b) mbFontString = do
fd <- fontDescription mbFontString
liftYiControl $ fmap YiView $ Yi.newView b fd
- pasteClipboard (YiBuffer b) clipboard (YiIter (Iter _ p)) defaultEditable = liftYi $ liftEditor $ paste
+ pasteClipboard (YiBuffer b) clipboard (YiIter (Iter _ p)) defaultEditable = liftYi $ withEditor $ paste
placeCursor (YiBuffer b) (YiIter (Iter _ p)) = withYiBuffer b $ moveTo p
redo (YiBuffer b) = withYiBuffer b redoB
removeTagByName (YiBuffer b) name = return () -- TODO
@@ -201,7 +203,7 @@
now <- liftIO $ getCurrentTime
withYiBuffer b $ markSavedB now
setStyle preferDark (YiBuffer b) mbStyle = return () -- TODO
- setText (YiBuffer b) text = liftYiControl $ Yi.setText b (T.unpack text)
+ setText (YiBuffer b) text = liftYiControl $ Yi.setText b (Yi.fromText text)
undo (YiBuffer b) = withYiBuffer b undoB
bufferToWindowCoords (YiView v) point = return point -- TODO
drawTabs (YiView _) = return () -- TODO
@@ -259,7 +261,7 @@
then return Nothing
else return . Just $ mkYiIter' b newPoint
getChar (YiIter i) = withYiIter i readCharB
- getCharsInLine (YiIter i) = withYiIter i $ length <$> readLnB
+ getCharsInLine (YiIter i) = withYiIter i $ Yi.length <$> readLnB
getLine (YiIter i) = withYiIter i curLn
getLineOffset (YiIter i) = withYiIter i curCol
getOffset (YiIter (Iter _ (Point o))) = return o
diff --git a/src/IDE/YiConfig.hs b/src/IDE/YiConfig.hs
--- a/src/IDE/YiConfig.hs
+++ b/src/IDE/YiConfig.hs
@@ -1,10 +1,6 @@
{-# LANGUAGE CPP #-}
-{- Based on example config Yi/Users/Corey.hs that uses the Vim keymap with these additions:
- - Always uses the VTY UI by default.
- - The color style is darkBlueTheme
- - The insert mode of the Vim keymap has been extended with a few additions
- I find useful.
- -}
+{-# LANGUAGE OverloadedStrings #-}
+{- Based on example config yi example-configs/yi-vim.hs -}
module IDE.YiConfig (
defaultYiConfig
@@ -33,6 +29,9 @@
import Control.Monad (replicateM_)
import Control.Applicative (Alternative(..))
+import qualified Data.Text as T (singleton)
+import Data.Monoid ((<>))
+import qualified Yi.Rope as R (toText)
start yiConfig f =
startControl yiConfig $ do
@@ -49,10 +48,6 @@
tabSize = 4
}}
-noHaskellAnnots m
- | modeName m == "haskell" = m { modeGetAnnotations = modeGetAnnotations emptyMode }
- | otherwise = m
-
defaultYiConfig = defaultVimConfig {
modeTable = myModes ++ modeTable defaultVimConfig,
defaultKm = myKeymapSet,
@@ -62,7 +57,7 @@
defaultSearchKeymap :: Keymap
defaultSearchKeymap = do
Event (KASCII c) [] <- anyEvent
- write (isearchAddE [c])
+ write (isearchAddE $ T.singleton c)
myKeymapSet :: KeymapSet
myKeymapSet = V2.mkKeymapSet $ V2.defVimConfig `override` \super this ->
@@ -76,10 +71,10 @@
-- whose prereq function returns WholeMatch,
-- the first such binding is used.
-- So it's important to have custom bindings first.
- V2.vimBindings = myBindings eval ++ V2.vimBindings super
+ V2.vimBindings = myBindings eval <> V2.vimBindings super
}
-myBindings :: (String -> EditorM ()) -> [V2.VimBinding]
+myBindings :: (V2.EventString -> EditorM ()) -> [V2.VimBinding]
myBindings eval =
let nmap x y = V2.mkStringBindingE V2.Normal V2.Drop (x, y, id)
imap x y = V2.VimBindingE (\evs state -> case V2.vsMode state of
@@ -87,9 +82,7 @@
fmap (const (y >> return V2.Continue))
(evs `V2.matchesString` x)
_ -> V2.NoMatch)
- in [
- -- Tab traversal
- nmap "" previousTabE
+ in [ nmap "" previousTabE
, nmap "" nextTabE
, nmap "" nextTabE
@@ -99,19 +92,18 @@
-- for times when you don't press shift hard enough
, nmap ";" (eval ":")
- , nmap "" (withBuffer0 deleteTrailingSpaceB)
- , nmap "" (withBuffer0 moveToSol)
- , nmap "" (withBuffer0 readCurrentWordB >>= printMsg)
-
- , imap "" (withBuffer0 moveToSol)
- , imap "" (withBuffer0 moveToEol)
+ , nmap "" (withCurrentBuffer deleteTrailingSpaceB)
+ , nmap "" (withCurrentBuffer moveToSol)
+ , nmap "" (withCurrentBuffer readCurrentWordB >>= printMsg . R.toText)
+ , imap "" (withCurrentBuffer moveToSol)
+ , imap "" (withCurrentBuffer moveToEol)
]
+myModes :: [AnyMode]
myModes = [
AnyMode Haskell.fastMode {
-- Disable beautification
modePrettify = const $ return ()
- , modeGetAnnotations = (const . const) []
}
]
diff --git a/win32/makeinstaller.sh b/win32/makeinstaller.sh
--- a/win32/makeinstaller.sh
+++ b/win32/makeinstaller.sh
@@ -1,120 +1,122 @@
-#!/bin/sh
-
-. scripts/stage.sh || exit
-
-export CABAL_USER_BIN=$HOME/AppData/Roaming/cabal/bin
-export GHC_USER_PREFIX=$HOME/AppData/Roaming/cabal/x86_64-windows-ghc-`ghc$GHCVERSION --numeric-version`
-export LEKSAH_PREFIX=$GHC_USER_PREFIX
-export LEKSAH_SERVER_PREFIX=$GHC_USER_PREFIX
-export HLINT_X_X_X_X=`ghc-pkg$GHCVERSION list |grep '^ *hlint-' | tail -n1 | tr -d ' \n'`
-export PRETTY_SHOW_X_X=`ghc-pkg$GHCVERSION list |grep '^ *pretty-show-' | tail -n1 | tr -d ' \n'`
-export GHCJS_CODEMIRROR_X_X_X_X=`ghc-pkg$GHCVERSION list |grep '^ *ghcjs-codemirror-' | tail -n1 | tr -d ' \n'`
-
-sed 's|\q|\F4|' "$LEKSAH_PREFIX/$LEKSAH_X_X_X_X/data/keymap.lkshk" || exit
-
-cd win32 || exit
-
-export CURL_PREFIX=`pkg-config --libs-only-L libcurl | sed 's|^-L||' | sed 's|/lib *$||'`
-export MINGW_BIN=`cmd //C echo \`dirname \\\`which gcc\\\`\``
-export PATH=$PATH:/c/Program\ Files\ \(x86\)/NSIS:/c/Program\ Files/NSIS
-#makensis leksah.nsi
-
-export PATH=$PATH:/c/Program\ Files\ \(x86\)/WiX\ Toolset\ v3.8/bin:/c/Program\ Files/WiX\ Toolset\ v3.8/bin
-mkdir -p SourceDir
-cp -ru leksah.bat SourceDir
-cp -ru leksah-server.bat SourceDir
-cp -ru leksah-rebuild-metadata.bat SourceDir
-cp -ru "$GTK_PREFIX"/etc SourceDir
-mkdir -p SourceDir/leksah
-cp -ru "$LEKSAH_PREFIX/$LEKSAH_X_X_X_X"/data SourceDir/leksah
-cp -ru "$LEKSAH_PREFIX/$LEKSAH_X_X_X_X"/language-specs SourceDir/leksah
-cp -ru "$LEKSAH_PREFIX/$LEKSAH_X_X_X_X"/pics SourceDir/leksah
-cp -u "$LEKSAH_PREFIX/$LEKSAH_X_X_X_X"/LICENSE SourceDir/leksah
-cp -u "$LEKSAH_PREFIX/$LEKSAH_X_X_X_X"/Readme.md SourceDir/leksah
-mkdir -p SourceDir/hlint
-cp -ru "$LEKSAH_PREFIX/$HLINT_X_X_X_X"/* SourceDir/hlint
-mkdir -p SourceDir/pretty-show
-cp -ru "$LEKSAH_PREFIX/$PRETTY_SHOW_X_X"/style SourceDir/pretty-show
-mkdir -p SourceDir/ghcjs-codemirror
-cp -ru "$LEKSAH_PREFIX/$GHCJS_CODEMIRROR_X_X_X_X"/mode SourceDir/ghcjs-codemirror
-cp -ru "$LEKSAH_PREFIX/$GHCJS_CODEMIRROR_X_X_X_X"/lib SourceDir/ghcjs-codemirror
-cp -ru "$LEKSAH_PREFIX/$GHCJS_CODEMIRROR_X_X_X_X"/keymap SourceDir/ghcjs-codemirror
-cp -ru "$LEKSAH_PREFIX/$GHCJS_CODEMIRROR_X_X_X_X"/theme SourceDir/ghcjs-codemirror
-mkdir -p SourceDir/bin
-cp -u "$CABAL_USER_BIN"/leksah.exe SourceDir/bin
-cp -u "$CABAL_USER_BIN"/vcswrapper.exe SourceDir/bin
-cp -u "$CABAL_USER_BIN"/vcsgui.exe SourceDir/bin
-cp -u "$CABAL_USER_BIN"/vcsgui-askpass.exe SourceDir/bin
-cp -u "$CABAL_USER_BIN"/leksah-server.exe SourceDir/bin
-cp -u "$CABAL_USER_BIN"/leksahecho.exe SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/iconv.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/icudata50.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/icui18n50.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/icule50.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/icuuc50.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libatk-1.0-0.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libbz2-1.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libcairo-2.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libcairo-gobject-2.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libcrypto-10.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libcurl-4.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libenchant.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libexpat-1.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libffi-6.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libfontconfig-1.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libfreetype-6.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libgailutil-3-0.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libgcc_s_seh-1.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libgcc_s_sjlj-1.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libgdk-3-0.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libgdk_pixbuf-2.0-0.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libgio-2.0-0.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libglib-2.0-0.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libgmodule-2.0-0.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libgobject-2.0-0.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libgst*-1.0-0.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libgthread-2.0-0.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libgtk-3-0.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libgtksourceview-3.0-1.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libharfbuzz-0.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libharfbuzz-icu-0.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libidn-11.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libintl-8.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libjavascriptcoregtk-3.0-0.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libjpeg-62.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libpango-1.0-0.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libpangocairo-1.0-0.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libpangoft2-1.0-0.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libpangowin32-1.0-0.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libpixman-1-0.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libpng16-16.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libsoup-2.4-1.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libsqlite3-0.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libssh2-1.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libssl-10.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libstdc++-6.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libxml2-2.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libxslt-1.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libwebkitgtk-3.0-0.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libwebp-4.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/libwinpthread-1.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/zlib1.dll SourceDir/bin
-cp -u "$GTK_PREFIX"/bin/pkg-config.exe SourceDir/bin
-mkdir -p SourceDir/share
-cp -ru "$GTK_PREFIX"/share/themes SourceDir/share
-cp -ru "$GTK_PREFIX"/share/glib-2.0 SourceDir/share
-cp -ru "$GTK_PREFIX"/share/gtksourceview-3.0 SourceDir/share
-mkdir -p SourceDir/libexec
-cp -ru "$GTK_PREFIX"/libexec/gstreamer-1.0 SourceDir/libexec
-
-cp -ru "$GTK_PREFIX"/include SourceDir
-cp -ru "$GTK_PREFIX"/lib SourceDir
-
-# mkdir -p SourceDir/fonts
-# cp -ru /c/Windows/Fonts/DejaVuS*.ttf SourceDir
-
-heat dir SourceDir -srd -gg -sfrag -template fragment -out heat.wxs -cg Leksah -dr INSTALLDIR -sreg suppress registry harvesting || exit
-candle heat.wxs || exit
-candle leksah.wxs || exit
-light -ext WixUIExtension heat.wixobj leksah.wixobj -out $LEKSAH_X_X_X_X.msi || exit
-
+#!/bin/sh
+
+. scripts/stage.sh || exit
+
+export CABAL_USER_BIN=$HOME/AppData/Roaming/cabal/bin
+export GHC_USER_PREFIX=$HOME/AppData/Roaming/cabal/x86_64-windows-ghc-`ghc$GHCVERSION --numeric-version`
+export LEKSAH_PREFIX=$GHC_USER_PREFIX
+export LEKSAH_SERVER_PREFIX=$GHC_USER_PREFIX
+export HLINT_X_X_X_X=`ghc-pkg$GHCVERSION list |grep '^ *hlint-' | tail -n1 | tr -d ' \n'`
+export PRETTY_SHOW_X_X=`ghc-pkg$GHCVERSION list |grep '^ *pretty-show-' | tail -n1 | tr -d ' \n'`
+export GHCJS_CODEMIRROR_X_X_X_X=`ghc-pkg$GHCVERSION list |grep '^ *ghcjs-codemirror-' | tail -n1 | tr -d ' \n'`
+
+sed 's|\q|\F4|' "$LEKSAH_PREFIX/$LEKSAH_X_X_X_X/data/keymap.lkshk" || exit
+
+cd win32 || exit
+
+export CURL_PREFIX=`pkg-config --libs-only-L libcurl | sed 's|^-L||' | sed 's|/lib *$||'`
+export MINGW_BIN=`cmd //C echo \`dirname \\\`which gcc\\\`\``
+export PATH=$PATH:/c/Program\ Files\ \(x86\)/NSIS:/c/Program\ Files/NSIS
+#makensis leksah.nsi
+
+export PATH=$PATH:/c/Program\ Files\ \(x86\)/WiX\ Toolset\ v3.8/bin:/c/Program\ Files/WiX\ Toolset\ v3.8/bin
+mkdir -p SourceDir
+cp -ru leksah.bat SourceDir
+cp -ru leksah-server.bat SourceDir
+cp -ru leksah-rebuild-metadata.bat SourceDir
+cp -ru "$GTK_PREFIX"/etc SourceDir
+mkdir -p SourceDir/leksah
+cp -ru "$LEKSAH_PREFIX/$LEKSAH_X_X_X_X"/data SourceDir/leksah
+cp -ru "$LEKSAH_PREFIX/$LEKSAH_X_X_X_X"/language-specs SourceDir/leksah
+cp -ru "$LEKSAH_PREFIX/$LEKSAH_X_X_X_X"/pics SourceDir/leksah
+cp -u "$LEKSAH_PREFIX/$LEKSAH_X_X_X_X"/LICENSE SourceDir/leksah
+cp -u "$LEKSAH_PREFIX/$LEKSAH_X_X_X_X"/Readme.md SourceDir/leksah
+mkdir -p SourceDir/hlint
+cp -ru "$LEKSAH_PREFIX/$HLINT_X_X_X_X"/* SourceDir/hlint
+mkdir -p SourceDir/pretty-show
+cp -ru "$LEKSAH_PREFIX/$PRETTY_SHOW_X_X"/style SourceDir/pretty-show
+mkdir -p SourceDir/ghcjs-codemirror
+cp -ru "$LEKSAH_PREFIX/$GHCJS_CODEMIRROR_X_X_X_X"/mode SourceDir/ghcjs-codemirror
+cp -ru "$LEKSAH_PREFIX/$GHCJS_CODEMIRROR_X_X_X_X"/lib SourceDir/ghcjs-codemirror
+cp -ru "$LEKSAH_PREFIX/$GHCJS_CODEMIRROR_X_X_X_X"/keymap SourceDir/ghcjs-codemirror
+cp -ru "$LEKSAH_PREFIX/$GHCJS_CODEMIRROR_X_X_X_X"/theme SourceDir/ghcjs-codemirror
+mkdir -p SourceDir/bin
+cp -u "$CABAL_USER_BIN"/leksah.exe SourceDir/bin
+cp -u "$CABAL_USER_BIN"/vcswrapper.exe SourceDir/bin
+cp -u "$CABAL_USER_BIN"/vcsgui.exe SourceDir/bin
+cp -u "$CABAL_USER_BIN"/vcsgui-askpass.exe SourceDir/bin
+cp -u "$CABAL_USER_BIN"/leksah-server.exe SourceDir/bin
+cp -u "$CABAL_USER_BIN"/leksahecho.exe SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/iconv.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/icudata50.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/icui18n50.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/icule50.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/icuuc50.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libatk-1.0-0.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libbz2-1.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libcairo-2.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libcairo-gobject-2.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libcrypto-10.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libcurl-4.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libenchant.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libexpat-1.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libffi-6.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libfontconfig-1.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libfreetype-6.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libgailutil-3-0.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libgcc_s_seh-1.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libgcc_s_sjlj-1.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libgdk-3-0.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libgdk_pixbuf-2.0-0.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libgio-2.0-0.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libglib-2.0-0.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libgmodule-2.0-0.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libgobject-2.0-0.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libgst*-1.0-0.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libgthread-2.0-0.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libgtk-3-0.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libgtksourceview-3.0-1.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libharfbuzz-0.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libharfbuzz-icu-0.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libidn-11.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libintl-8.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libjavascriptcoregtk-3.0-0.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libjpeg-62.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libpango-1.0-0.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libpangocairo-1.0-0.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libpangoft2-1.0-0.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libpangowin32-1.0-0.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libpixman-1-0.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libpng16-16.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libsoup-2.4-1.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libsqlite3-0.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libssh2-1.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libssl-10.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libstdc++-6.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libxml2-2.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libxslt-1.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libwebkitgtk-3.0-0.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libwebp-5.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/libwinpthread-1.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/zlib1.dll SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/pkg-config.exe SourceDir/bin
+cp -u "$GTK_PREFIX"/bin/grep.exe SourceDir/bin
+mkdir -p SourceDir/share
+cp -ru "$GTK_PREFIX"/share/themes SourceDir/share
+cp -ru "$GTK_PREFIX"/share/icons SourceDir/share
+cp -ru "$GTK_PREFIX"/share/glib-2.0 SourceDir/share
+cp -ru "$GTK_PREFIX"/share/gtksourceview-3.0 SourceDir/share
+mkdir -p SourceDir/libexec
+cp -ru "$GTK_PREFIX"/libexec/gstreamer-1.0 SourceDir/libexec
+
+cp -ru "$GTK_PREFIX"/include SourceDir
+cp -ru "$GTK_PREFIX"/lib SourceDir
+
+# mkdir -p SourceDir/fonts
+# cp -ru /c/Windows/Fonts/DejaVuS*.ttf SourceDir
+
+heat dir SourceDir -srd -gg -sfrag -template fragment -out heat.wxs -cg Leksah -dr INSTALLDIR -sreg suppress registry harvesting || exit
+candle heat.wxs || exit
+candle leksah.wxs || exit
+light -ext WixUIExtension heat.wixobj leksah.wixobj -out $LEKSAH_X_X_X_X.msi || exit
+