leksah 0.14.1.1 → 0.14.2.0
raw patch · 13 files changed
+962/−978 lines, 13 filesdep +yi-languagedep +yi-ropedep ~leksahdep ~yi
Dependencies added: yi-language, yi-rope
Dependency ranges changed: leksah, yi
Files
- leksah.cabal +22/−28
- osx/leksah.bundle +2/−8
- scripts/stage.sh +1/−1
- src/IDE/Build.hs +1/−1
- src/IDE/Command.hs +6/−5
- src/IDE/Metainfo/Provider.hs +90/−96
- src/IDE/Pane/Grep.hs +334/−337
- src/IDE/Pane/HLint.hs +349/−341
- src/IDE/Pane/Info.hs +2/−2
- src/IDE/Pane/Trace.hs +2/−2
- src/IDE/TextEditor/Yi.hs +16/−14
- src/IDE/YiConfig.hs +15/−23
- win32/makeinstaller.sh +122/−120
leksah.cabal view
@@ -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
osx/leksah.bundle view
@@ -71,12 +71,6 @@ ${prefix}/lib/${gtkdir}/${pkg:${gtk}:gtk_binary_version}/immodules/*.so </binary> - <!-- Copy in GTK+ theme engines. -->- <binary>- ${prefix}/lib/${gtkdir}/${pkg:${gtk}:gtk_binary_version}/theming-engines/*.so- </binary>-- <!-- And the print backends --> <binary> ${prefix}/lib/${gtkdir}/${pkg:${gtk}:gtk_binary_version}/printbackends/*.so@@ -139,7 +133,7 @@ </data> <data dest="${bundle}/Contents/Resources/share/hlint">- ${prefix:hlint}+ ${prefix:hlint}/share </data> <!-- Copy in the themes data. You may want to trim this to save space@@ -186,7 +180,7 @@ needed for the "hicolor" base theme. --> <icon-theme icons="all">- hicolor+ Adwaita </icon-theme> <!-- Custom prefs for the Mac -->
scripts/stage.sh view
@@ -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
src/IDE/Build.hs view
@@ -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)
src/IDE/Command.hs view
@@ -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"
src/IDE/Metainfo/Provider.hs view
@@ -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
src/IDE/Pane/Grep.hs view
@@ -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 : <maintainer at leksah.org>--- 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 : <maintainer at leksah.org> +-- 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) + + + +
src/IDE/Pane/HLint.hs view
@@ -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 : <maintainer at leksah.org>--- 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 : <maintainer at leksah.org> +-- 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 ()
src/IDE/Pane/Info.hs view
@@ -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 ()
src/IDE/Pane/Trace.hs view
@@ -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
src/IDE/TextEditor/Yi.hs view
@@ -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
src/IDE/YiConfig.hs view
@@ -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 "<C-h>" previousTabE+ in [ nmap "<C-h>" previousTabE , nmap "<C-l>" nextTabE , nmap "<C-l>" nextTabE @@ -99,19 +92,18 @@ -- for times when you don't press shift hard enough , nmap ";" (eval ":") - , nmap "<F3>" (withBuffer0 deleteTrailingSpaceB)- , nmap "<F4>" (withBuffer0 moveToSol)- , nmap "<F1>" (withBuffer0 readCurrentWordB >>= printMsg)-- , imap "<Home>" (withBuffer0 moveToSol)- , imap "<End>" (withBuffer0 moveToEol)+ , nmap "<F3>" (withCurrentBuffer deleteTrailingSpaceB)+ , nmap "<F4>" (withCurrentBuffer moveToSol)+ , nmap "<F1>" (withCurrentBuffer readCurrentWordB >>= printMsg . R.toText)+ , imap "<Home>" (withCurrentBuffer moveToSol)+ , imap "<End>" (withCurrentBuffer moveToEol) ] +myModes :: [AnyMode] myModes = [ AnyMode Haskell.fastMode { -- Disable beautification modePrettify = const $ return ()- , modeGetAnnotations = (const . const) [] } ]
win32/makeinstaller.sh view
@@ -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|\<ctrl\>q|\<alt\>F4|' <data/keymap.lkshk >"$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|\<ctrl\>q|\<alt\>F4|' <data/keymap.lkshk >"$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 +