leksah-0.16.2.2: src/IDE/Package.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE LambdaCase #-}
-----------------------------------------------------------------------------
--
-- Module : IDE.Package
-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie
-- License : GNU-GPL
--
-- Maintainer : <maintainer at leksah.org>
-- Stability : provisional
-- Portability : portable
--
--
-- | The packages methods of ide.
--
---------------------------------------------------------------------------------
module IDE.Package (
packageConfig
, packageConfig'
, buildPackage
, packageDoc
, packageDoc'
, packageClean
, packageClean'
, packageCopy
, packageInstall
, packageInstall'
, packageRun
, packageRunJavaScript
, activatePackage
, deactivatePackage
, packageTest
, packageTest'
, packageBench
, packageBench'
, packageSdist
, packageOpenDoc
, getPackageDescriptionAndPath
, getEmptyModuleTemplate
, getModuleTemplate
, ModuleLocation(..)
, addModuleToPackageDescr
, delModuleFromPackageDescr
, backgroundBuildToggled
, makeDocsToggled
, runUnitTestsToggled
, runBenchmarksToggled
, makeModeToggled
, debugStart
, printBindResultFlag
, breakOnErrorFlag
, breakOnExceptionFlag
, printEvldWithShowFlag
, tryDebug
, tryDebugQuiet
, executeDebugCommand
, choosePackageFile
, idePackageFromPath'
, ideProjectFromPath
, writeGenericPackageDescription'
) where
import Distribution.Package hiding (depends,packageId)
import Distribution.PackageDescription
import Distribution.PackageDescription.Parse
import Distribution.PackageDescription.Configuration
import Distribution.Verbosity
import System.FilePath
import Control.Concurrent
import System.Directory
(removeDirectoryRecursive, canonicalizePath, setCurrentDirectory,
doesFileExist, getDirectoryContents, doesDirectoryExist)
import Prelude hiding (catch)
import Data.Char (isSpace)
import Data.Maybe
(maybeToList, mapMaybe, listToMaybe, fromMaybe, isNothing, isJust,
fromJust, catMaybes)
import Data.Function (on)
import Control.Exception (SomeException(..), catch)
import IDE.Core.State
import IDE.Utils.GUIUtils
import IDE.Utils.CabalUtils (writeGenericPackageDescription')
import IDE.Pane.Log
import IDE.Pane.PackageEditor
import IDE.Pane.SourceBuffer
import IDE.Pane.PackageFlags (writeFlags, readFlags)
import Distribution.Text (display)
import IDE.Utils.FileUtils
(cabalProjectBuildDir, getConfigFilePathForLoad, getPackageDBs')
import IDE.LogRef
import Distribution.ModuleName (ModuleName(..))
import Data.List
(intercalate, isInfixOf, nub, foldl', delete, find)
import IDE.Utils.Tool (ToolOutput(..), runTool, newGhci, ToolState(..), toolline, ProcessHandle, executeGhciCommand)
import qualified Data.Set as Set (fromList)
import qualified Data.Map as Map (empty, fromList)
import System.Exit (ExitCode(..))
import Control.Applicative ((<$>), (<*>))
import qualified Data.Conduit as C (Sink, ZipSink(..), getZipSink)
import qualified Data.Conduit.List as CL (foldM, fold, consume)
import Data.Conduit (($$))
import Control.Monad.Trans.Reader (ask)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Class (lift)
import Control.Monad (void, when, unless, liftM, forM, forM_)
import Distribution.PackageDescription.PrettyPrint
(showGenericPackageDescription)
import Debug.Trace (trace)
import IDE.Pane.WebKit.Documentation
(getDocumentation, loadDoc, reloadDoc)
import IDE.Pane.WebKit.Output (loadOutputUri, getOutputPane)
import System.Log.Logger (debugM)
import System.Process.Vado (getMountPoint, vado, readSettings)
import qualified Data.Text as T
(reverse, all, null, dropWhile, lines, isPrefixOf, stripPrefix,
replace, unwords, takeWhile, pack, unpack, isInfixOf)
import IDE.Utils.ExternalTool (runExternalTool', runExternalTool, isRunning, interruptBuild)
import Text.PrinterParser (writeFields)
import Data.Text (Text)
import Data.Monoid ((<>))
import qualified Data.Text.IO as T (readFile)
import qualified Text.Printf as S (printf)
import Text.Printf (PrintfType)
import IDE.Metainfo.Provider (updateSystemInfo)
import GI.GLib.Functions (timeoutAdd)
import GI.GLib.Constants (pattern PRIORITY_DEFAULT, pattern PRIORITY_LOW)
import GI.Gtk.Objects.MessageDialog
(setMessageDialogText, constructMessageDialogButtons, setMessageDialogMessageType,
MessageDialog(..))
import GI.Gtk.Objects.Dialog (constructDialogUseHeaderBar)
import GI.Gtk.Enums
(WindowPosition(..), ResponseType(..), ButtonsType(..),
MessageType(..))
import GI.Gtk.Objects.Window
(setWindowWindowPosition, windowSetTransientFor)
import Graphics.UI.Editor.Parameters
(dialogRun', dialogSetDefaultResponse', dialogAddButton')
import Data.GI.Base (set, new')
import GI.Gtk.Objects.Widget (widgetDestroy)
import IDE.Utils.VersionUtils (getDefaultGhcVersion)
import IDE.Utils.CabalProject (getCabalProjectPackages)
import System.Environment (getEnvironment)
import Distribution.Simple.LocalBuildInfo
(Component(..), Component)
import Distribution.Simple.Utils (writeUTF8File)
#if MIN_VERSION_Cabal(2,0,0)
import Distribution.Types.ForeignLib (foreignLibName)
import Distribution.Types.UnqualComponentName
(UnqualComponentName(..), mkUnqualComponentName,
unUnqualComponentName)
#endif
#if !MIN_VERSION_Cabal(2,0,0)
type UnqualComponentName = String
mkUnqualComponentName :: String -> UnqualComponentName
mkUnqualComponentName = id
unUnqualComponentName :: UnqualComponentName -> String
unUnqualComponentName = id
#endif
printf :: PrintfType r => Text -> r
printf = S.printf . T.unpack
-- | Get the last item
sinkLast = CL.fold (\_ a -> Just a) Nothing
moduleInfo :: (a -> BuildInfo) -> (a -> [ModuleName]) -> a -> [(ModuleName, BuildInfo)]
moduleInfo bi mods a = map (\m -> (m, buildInfo)) $ mods a
where buildInfo = bi a
myLibModules pd = case library pd of
Nothing -> []
#if MIN_VERSION_Cabal(2,0,0)
Just l -> moduleInfo libBuildInfo explicitLibModules l
#else
Just l -> moduleInfo libBuildInfo libModules l
#endif
myExeModules pd = concatMap (moduleInfo buildInfo exeModules) (executables pd)
myTestModules pd = concatMap (moduleInfo testBuildInfo (otherModules . testBuildInfo)) (testSuites pd)
myBenchmarkModules pd = concatMap (moduleInfo benchmarkBuildInfo (otherModules . benchmarkBuildInfo)) (benchmarks pd)
activatePackage :: MonadIDE m => Maybe FilePath -> Maybe Project -> Maybe IDEPackage -> Maybe Text -> m ()
activatePackage mbPath mbProject mbPack mbComponent = do
liftIO $ debugM "leksah" $ "activatePackage " <> show (mbPath, pjFile <$> mbProject, ipdCabalFile <$> mbPack, mbComponent)
oldActivePack <- readIDE activePack
case mbPath of
Just p -> liftIO $ setCurrentDirectory (dropFileName p)
Nothing -> return ()
when (isJust mbPack || isJust oldActivePack) $ do
triggerEventIDE (Sensitivity [(SensitivityProjectActive,isJust mbPack)])
return ()
mbWs <- readIDE workspace
let wsStr = case mbWs of
Nothing -> ""
Just ws -> wsName ws
txt = case (mbPath, mbPack) of
(_, Just pack) -> wsStr <> " > " <> packageIdentifierToString (ipdPackageId pack)
(Just path, _) -> wsStr <> " > " <> T.pack (takeFileName path)
_ -> wsStr <> ":"
triggerEventIDE (StatusbarChanged [CompartmentPackage txt])
return ()
deactivatePackage :: IDEAction
deactivatePackage = activatePackage Nothing Nothing Nothing Nothing
interruptSaveAndRun :: MonadIDE m => IDEAction -> m ()
interruptSaveAndRun action = do
ideR <- liftIDE ask
alreadyRunning <- isRunning
if alreadyRunning
then do
liftIO $ debugM "leksah" "interruptSaveAndRun"
interruptBuild
timeoutAdd PRIORITY_DEFAULT 200 (do
reflectIDE (do
interruptSaveAndRun action
return False) ideR
return False)
return ()
else liftIDE run
where
run = do
prefs <- readIDE prefs
when (saveAllBeforeBuild prefs) . liftIDE . void $ fileSaveAll belongsToWorkspace'
action
packageConfig :: PackageAction
packageConfig = do
project <- lift ask
package <- ask
interruptSaveAndRun $ packageConfig' (project, package) (\ _ -> return ())
packageConfig' :: (Project, IDEPackage) -> (Bool -> IDEAction) -> IDEAction
packageConfig' (project, package) continuation = do
prefs <- readIDE prefs
case pjTool project of
StackTool -> do
ideMessage Normal (__ "Stack projects do not require configuration.")
liftIDE $ continuation True
CabalTool -> do
logLaunch <- getDefaultLogLaunch
showDefaultLogLaunch'
let dir = ipdPackageDir package
runExternalTool' (__ "Configuring")
"cabal"
("new-configure" : ipdConfigFlags package)
dir Nothing $ do
mbLastOutput <- C.getZipSink $ const <$> C.ZipSink sinkLast <*> C.ZipSink (logOutput logLaunch)
lift $ continuation (mbLastOutput == Just (ToolExit ExitSuccess))
runCabalBuild :: Bool -> Bool -> Bool -> (Project, IDEPackage) -> (Bool -> IDEAction) -> IDEAction
runCabalBuild backgroundBuild jumpToWarnings withoutLinking (project, package) continuation = do
prefs <- readIDE prefs
pd <- liftIO $ fmap flattenPackageDescription
(readPackageDescription normal (ipdCabalFile package))
let dir = ipdPackageDir package
pkgName = ipdPackageName package
isActiveProject <- maybe False (on (==) pjFile project) <$> readIDE activeProject
isActivePackage <- (isActiveProject &&) . maybe False (on (==) ipdCabalFile package) <$> readIDE activePack
mbActiveComponent <- readIDE activeComponent
let flagsForTests =
if "--enable-tests" `elem` ipdConfigFlags package
then case pjTool project of
StackTool -> ["--test", "--no-run-tests"] -- if we use stack, with tests enabled, we build the tests without running them
CabalTool -> map (\t -> pkgName <> ":test:" <> T.pack (unUnqualComponentName $ testName t)) $ testSuites pd
else []
let flagsForBenchmarks =
if "--enable-benchmarks" `elem` ipdConfigFlags package
then case pjTool project of
StackTool -> ["--bench", "--no-run-benchmarks"] -- if we use stack, with benchmarks enabled, we build the benchmarks without running them
CabalTool -> map (\t -> pkgName <> ":benchmark:" <> T.pack (unUnqualComponentName $ benchmarkName t)) $ benchmarks pd
else []
let args = -- stack needs the package name to actually print the output info
(case pjTool project of
StackTool -> ["build", "--stack-yaml", T.pack (makeRelative dir $ pjFile project), ipdPackageName package]
CabalTool -> ["new-build", "--project-file", T.pack (makeRelative dir $ pjFile project)])
++ ["--with-ld=false" | pjTool project == CabalTool && backgroundBuild && withoutLinking]
++ (if isActivePackage then maybeToList mbActiveComponent else [])
++ flagsForTests
++ flagsForBenchmarks
++ ipdBuildFlags package
runExternalTool' (__ "Building") (pjToolCommand project) args dir Nothing $ do
(mbLastOutput, _) <- C.getZipSink $ (,)
<$> C.ZipSink sinkLast
<*> (C.ZipSink $ logOutputForBuild project package backgroundBuild jumpToWarnings)
lift $ do
errs <- readIDE errorRefs
continuation (mbLastOutput == Just (ToolExit ExitSuccess))
--isConfigError :: Monad m => C.Sink ToolOutput m Bool
--isConfigError = CL.foldM (\a b -> return $ a || isCErr b) False
-- where
-- isCErr (ToolError str) = str1 `T.isInfixOf` str || str2 `T.isInfixOf` str || str3 `T.isInfixOf` str
-- isCErr _ = False
-- str1 = __ "Run the 'configure' command first"
-- str2 = __ "please re-configure"
-- str3 = __ "cannot satisfy -package-id"
buildPackage :: Bool -> Bool -> Bool -> (Project, IDEPackage) -> (Bool -> IDEAction) -> IDEAction
buildPackage backgroundBuild jumpToWarnings withoutLinking (project, package) continuation = catchIDE (do
liftIO $ debugM "leksah" "buildPackage"
ideR <- ask
prefs <- readIDE prefs
maybeDebug <- readIDE debugState
case maybeDebug of
Nothing -> do
alreadyRunning <- isRunning
if alreadyRunning
then do
liftIO $ debugM "leksah" "buildPackage interruptBuild"
interruptBuild
timeoutAdd PRIORITY_DEFAULT 100 (do
reflectIDE (do
if backgroundBuild
then do
tb <- readIDE triggerBuild
void . liftIO $ tryPutMVar tb ()
else do
buildPackage backgroundBuild jumpToWarnings withoutLinking
(project, package) continuation
return False) ideR
return False)
return ()
else do
when (saveAllBeforeBuild prefs) . liftIDE . void $ fileSaveAll belongsToWorkspace'
runCabalBuild backgroundBuild jumpToWarnings withoutLinking (project, package) $ \f -> do
when f $ do
mbURI <- readIDE autoURI
case mbURI of
Just uri -> postSyncIDE . loadOutputUri $ T.unpack uri
Nothing -> return ()
continuation f
Just debug@(_, ghci) -> do
-- TODO check debug package matches active package
ready <- liftIO $ isEmptyMVar (currentToolCommand ghci)
if ready
then do
let dir = ipdPackageDir package
when (saveAllBeforeBuild prefs) (do fileSaveAll belongsToWorkspace'; return ())
(`runDebug` debug) . executeDebugCommand ":reload" $ do
errs <- logOutputForBuild project package backgroundBuild jumpToWarnings
unless (any isError errs) . lift $ do
cmd <- readIDE autoCommand
postSyncIDE cmd
continuation True
else do
timeoutAdd PRIORITY_LOW 500 (do
reflectIDE (do
tb <- readIDE triggerBuild
void . liftIO $ tryPutMVar tb ()
return False) ideR
return False)
return ()
)
(\(e :: SomeException) -> sysMessage Normal (T.pack $ show e))
packageDoc :: PackageAction
packageDoc = do
project <- lift ask
package <- ask
interruptSaveAndRun $ packageDoc' False True (project, package) (\ _ -> return ())
packageDoc' :: Bool -> Bool -> (Project, IDEPackage) -> (Bool -> IDEAction) -> IDEAction
packageDoc' backgroundBuild jumpToWarnings (project, package) continuation = do
prefs <- readIDE prefs
catchIDE (do
let dir = ipdPackageDir package
flags <- case pjTool project of
StackTool -> return ["haddock", "--no-haddock-deps"]
CabalTool -> do
(buildDir, _) <- liftIO $ cabalProjectBuildDir (pjDir project)
return
[ "act-as-setup"
, "--"
, "haddock"
, T.pack ("--builddir=" <> (buildDir </>
T.unpack (packageIdentifierToString $ ipdPackageId package)))]
runExternalTool' (__ "Documenting") (pjToolCommand project)
(flags <> ipdHaddockFlags package) dir Nothing $ do
mbLastOutput <- C.getZipSink $ const <$> C.ZipSink sinkLast <*> (C.ZipSink $
logOutputForBuild project package backgroundBuild jumpToWarnings)
lift $ postAsyncIDE reloadDoc
lift $ continuation (mbLastOutput == Just (ToolExit ExitSuccess)))
(\(e :: SomeException) -> print e)
packageClean :: PackageAction
packageClean = do
project <- lift ask
package <- ask
interruptSaveAndRun $ packageClean' (project, package) (\ _ -> return ())
packageClean' :: (Project, IDEPackage) -> (Bool -> IDEAction) -> IDEAction
packageClean' (project, package) continuation = do
logLaunch <- getDefaultLogLaunch
showDefaultLogLaunch'
let dir = ipdPackageDir package
projectRoot = pjDir project
case pjTool project of
CabalTool -> do
(buildDir, _) <- liftIO $ cabalProjectBuildDir (pjDir project)
let packageBuildDir = buildDir
</> T.unpack (packageIdentifierToString $ ipdPackageId package)
liftIO $ doesDirectoryExist packageBuildDir >>= \case
True -> removeDirectoryRecursive packageBuildDir
False -> return ()
StackTool ->
runExternalTool' (__ "Cleaning")
(pjToolCommand project)
["clean"]
dir Nothing $ do
mbLastOutput <- C.getZipSink $ const <$> C.ZipSink sinkLast <*> C.ZipSink (logOutput logLaunch)
lift $ continuation (mbLastOutput == Just (ToolExit ExitSuccess))
packageCopy :: PackageAction
packageCopy = do
package <- ask
interruptSaveAndRun $ do
logLaunch <- getDefaultLogLaunch
showDefaultLogLaunch'
catchIDE (do
prefs <- readIDE prefs
window <- getMainWindow
mbDir <- liftIO $ chooseDir window (__ "Select the target directory") Nothing
case mbDir of
Nothing -> return ()
Just fp -> do
let dir = ipdPackageDir package
runExternalTool' (__ "Copying")
"cabal"
["copy", "--destdir=" <> T.pack fp]
dir Nothing
(logOutput logLaunch))
(\(e :: SomeException) -> print e)
packageInstall :: PackageAction
packageInstall = do
project <- lift ask
package <- ask
interruptSaveAndRun $ packageInstall' (project, package) (\ _ -> return ())
packageInstall' :: (Project, IDEPackage) -> (Bool -> IDEAction) -> IDEAction
packageInstall' (project, package) continuation = do
prefs <- readIDE prefs
logLaunch <- getDefaultLogLaunch
showDefaultLogLaunch'
catchIDE (do
let dir = ipdPackageDir package
runExternalTool' (__ "Installing")
(case pjTool project of
StackTool -> "stack"
CabalTool -> "echo" {-cabalCommand prefs-})
((case pjTool project of
StackTool -> "install" : "--stack-yaml" : T.pack (makeRelative dir $ pjFile project) : ipdBuildFlags package
CabalTool -> ["TODO run cabal new-install"]) ++ ipdInstallFlags package)
dir Nothing $ do
mbLastOutput <- C.getZipSink $ (const <$> C.ZipSink sinkLast) <*> C.ZipSink (logOutput logLaunch)
lift $ continuation (mbLastOutput == Just (ToolExit ExitSuccess)))
(\(e :: SomeException) -> print e)
packageRun :: PackageAction
packageRun = do
project <- lift ask
package <- ask
interruptSaveAndRun $ packageRun' True (project, package)
packageEnv :: MonadIO m => IDEPackage -> m [(String, String)]
packageEnv package = do
env <- liftIO getEnvironment
return $ (T.unpack (ipdPackageName package) <> "_datadir", ipdPackageDir package) : env
packageRun' :: Bool -> (Project, IDEPackage) -> IDEAction
packageRun' removeGhcjsFlagIfPresent (project, package) =
if removeGhcjsFlagIfPresent && "--ghcjs" `elem` ipdConfigFlags package
then do
window <- liftIDE getMainWindow
md <- new' MessageDialog [
constructDialogUseHeaderBar 0,
constructMessageDialogButtons ButtonsTypeCancel]
setMessageDialogMessageType md MessageTypeQuestion
setMessageDialogText md $ __ "Package is configured to use GHCJS. Would you like to remove --ghcjs from the configure flags and rebuild?"
windowSetTransientFor md (Just window)
dialogAddButton' md (__ "Use _GHC") (AnotherResponseType 1)
dialogSetDefaultResponse' md (AnotherResponseType 1)
setWindowWindowPosition md WindowPositionCenterOnParent
resp <- dialogRun' md
widgetDestroy md
case resp of
AnotherResponseType 1 -> do
let packWithNewFlags = package { ipdConfigFlags = filter (/="--ghcjs") $ ipdConfigFlags package }
changePackage packWithNewFlags
liftIO $ writeFlags (dropExtension (ipdCabalFile packWithNewFlags) ++ leksahFlagFileExtension) packWithNewFlags
packageConfig' (project, packWithNewFlags) $ \ ok -> when ok $
packageRun' False (project, packWithNewFlags)
_ -> return ()
else liftIDE $ catchIDE (do
ideR <- ask
maybeDebug <- readIDE debugState
pd <- liftIO $ fmap flattenPackageDescription
(readPackageDescription normal (ipdCabalFile package))
mbComponent <- readIDE activeComponent
let exe = exeToRun mbComponent $ executables pd
let defaultLogName = ipdPackageName package
logName = fromMaybe defaultLogName . listToMaybe $ map (T.pack . unUnqualComponentName . exeName) exe
(logLaunch,logName) <- buildLogLaunchByName logName
showLog
case maybeDebug of
Nothing -> do
prefs <- readIDE prefs
let dir = ipdPackageDir package
case pjTool project of
StackTool -> IDE.Package.runPackage (addLogLaunchData logName logLaunch)
(T.pack $ printf (__ "Running %s") (T.unpack logName))
"stack"
(concat [["exec"]
, ipdBuildFlags package
, map (T.pack . unUnqualComponentName . exeName) exe
, ["--"]
, ipdExeFlags package])
dir
Nothing
(logOutput logLaunch)
CabalTool -> do
(buildDir, cDir) <- liftIO $ cabalProjectBuildDir (pjDir project)
env <- packageEnv package
case exe ++ executables pd of
[] -> return ()
(Executable {exeName = name} : _) -> do
let exePath = buildDir
</> T.unpack (packageIdentifierToString $ ipdPackageId package)
</> cDir (unUnqualComponentName name) </> unUnqualComponentName name </> unUnqualComponentName name
IDE.Package.runPackage (addLogLaunchData logName logLaunch)
(T.pack $ printf (__ "Running %s") (T.unpack logName))
exePath
(ipdExeFlags package)
dir
(Just env)
(logOutput logLaunch)
Just debug ->
-- TODO check debug package matches active package
runDebug (do
case exe of
[Executable {exeName = name, modulePath = mainFilePath}] ->
executeDebugCommand (":module *" <> T.pack (map (\c -> if c == '/' then '.' else c) (takeWhile (/= '.') mainFilePath)))
(logOutput logLaunch)
_ -> return ()
executeDebugCommand (":main " <> T.unwords (ipdExeFlags package)) (logOutput logLaunch))
debug)
(\(e :: SomeException) -> print e)
-- | Is the given executable the active one?
isActiveExe :: Text -> Executable -> Bool
isActiveExe selected Executable {exeName = name} = selected == "exe:" <> T.pack (unUnqualComponentName name)
-- | get executable to run
-- no exe activated, take first one
exeToRun :: Maybe Text -> [Executable] -> [Executable]
exeToRun Nothing (exe:_) = [exe]
exeToRun Nothing _ = []
exeToRun (Just selected) exes = take 1 $ filter (isActiveExe selected) exes
packageRunJavaScript :: PackageAction
packageRunJavaScript = do
project <- lift ask
package <- ask
interruptSaveAndRun $ packageRunJavaScript' True (project, package)
packageRunJavaScript' :: Bool -> (Project, IDEPackage) -> IDEAction
packageRunJavaScript' addFlagIfMissing (project, package) =
if addFlagIfMissing && ("--ghcjs" `notElem` ipdConfigFlags package)
then do
window <- liftIDE getMainWindow
md <- new' MessageDialog [
constructDialogUseHeaderBar 0,
constructMessageDialogButtons ButtonsTypeCancel]
setMessageDialogMessageType md MessageTypeQuestion
setMessageDialogText md $ __ "Package is not configured to use GHCJS. Would you like to add --ghcjs to the configure flags and rebuild?"
windowSetTransientFor md (Just window)
dialogAddButton' md (__ "Use _GHCJS") (AnotherResponseType 1)
dialogSetDefaultResponse' md (AnotherResponseType 1)
setWindowWindowPosition md WindowPositionCenterOnParent
resp <- dialogRun' md
widgetDestroy md
case resp of
AnotherResponseType 1 -> do
let packWithNewFlags = package { ipdConfigFlags = "--ghcjs" : ipdConfigFlags package }
changePackage packWithNewFlags
liftIO $ writeFlags (dropExtension (ipdCabalFile packWithNewFlags) ++ leksahFlagFileExtension) packWithNewFlags
packageConfig' (project, packWithNewFlags) $ \ ok -> when ok $
packageRunJavaScript' False (project, packWithNewFlags)
_ -> return ()
else liftIDE $ buildPackage False False True (project, package) $ \ ok -> when ok $ liftIDE $ catchIDE (do
ideR <- ask
maybeDebug <- readIDE debugState
pd <- liftIO $ fmap flattenPackageDescription
(readPackageDescription normal (ipdCabalFile package))
mbComponent <- readIDE activeComponent
let exe = exeToRun mbComponent $ executables pd
let defaultLogName = ipdPackageName package
logName = fromMaybe defaultLogName . listToMaybe $ map (T.pack . unUnqualComponentName . exeName) exe
(logLaunch,logName) <- buildLogLaunchByName logName
let dir = ipdPackageDir package
projectRoot = pjDir project
prefs <- readIDE prefs
case exe ++ executables pd of
(Executable {exeName = name} : _) -> liftIDE $ do
(buildDir, cDir) <- liftIO $ cabalProjectBuildDir (pjDir project)
let path = buildDir
</> T.unpack (packageIdentifierToString $ ipdPackageId package)
</> cDir (unUnqualComponentName name) </> unUnqualComponentName name </> unUnqualComponentName name <.> "jsexe" </> "index.html"
postAsyncIDE $ do
loadOutputUri ("file:///" ++ path)
getOutputPane Nothing >>= \ p -> displayPane p False
`catchIDE`
(\(e :: SomeException) -> print e)
_ -> return ())
(\(e :: SomeException) -> print e)
packageTest :: PackageAction
packageTest = do
project <- lift ask
package <- ask
interruptSaveAndRun $ packageTest' False True (project, package) (\ _ -> return ())
packageTest' :: Bool -> Bool -> (Project, IDEPackage) -> (Bool -> IDEAction) -> IDEAction
packageTest' backgroundBuild jumpToWarnings (project, package) continuation =
if "--enable-tests" `elem` ipdConfigFlags package
then do
removeTestLogRefs (ipdPackageDir package)
pd <- liftIO $ fmap flattenPackageDescription
(readPackageDescription normal (ipdCabalFile package))
runTests $ testSuites pd
else continuation True
where
runTests :: [TestSuite] -> IDEAction
runTests [] = continuation True
runTests (test:rest) =
packageRunComponent (CTest test) backgroundBuild jumpToWarnings (project, package) (\ok ->
when ok $ runTests rest)
packageRunComponent :: Component -> Bool -> Bool -> (Project, IDEPackage) -> (Bool -> IDEAction) -> IDEAction
packageRunComponent (CLib _) _ _ _ _ = error "packageRunComponent"
packageRunComponent component backgroundBuild jumpToWarnings (project, package) continuation = do
let name = case component of
CLib _ -> error "packageRunComponent"
CExe exe -> exeName exe
CTest test -> testName test
CBench bench -> benchmarkName bench
#if MIN_VERSION_Cabal(2,0,0)
CFLib flib -> foreignLibName flib
#endif
command = case component of
CLib _ -> error "packageRunComponent"
CExe exe -> "run"
CTest test -> "test"
CBench bench -> "bench"
#if MIN_VERSION_Cabal(2,0,0)
CFLib flib -> "flib"
#endif
dir = ipdPackageDir package
logLaunch <- getDefaultLogLaunch
showDefaultLogLaunch'
catchIDE (do
prefs <- readIDE prefs
let projectRoot = pjDir project
ghcVersion <- liftIO getDefaultGhcVersion
packageDBs <- liftIO $ getPackageDBs' ghcVersion dir
let pkgId = packageIdentifierToString $ ipdPackageId package
pkgName = ipdPackageName package
args = case pjTool project of
StackTool -> [command, pkgName <> ":" <> T.pack (unUnqualComponentName name)]
CabalTool -> []
(cmd, mbEnv) <- case pjTool project of
StackTool -> return ("stack", Nothing)
CabalTool -> do
(buildDir, cDir) <- liftIO $ cabalProjectBuildDir (pjDir project)
env <- packageEnv package
return
( buildDir </> T.unpack pkgId </> cDir (unUnqualComponentName name)
</> unUnqualComponentName name </> unUnqualComponentName name
, Just $ ("GHC_PACKAGE_PATH", intercalate [searchPathSeparator] packageDBs) : env
)
runExternalTool' (__ "Run " <> T.pack (unUnqualComponentName name)) cmd (args
++ ipdBuildFlags package ++ ipdTestFlags package) dir mbEnv $ do
(mbLastOutput, _) <- C.getZipSink $ (,)
<$> C.ZipSink sinkLast
<*> (C.ZipSink $ logOutputForBuild project package backgroundBuild jumpToWarnings)
lift $ do
errs <- readIDE errorRefs
when (mbLastOutput == Just (ToolExit ExitSuccess)) $ continuation True)
(\(e :: SomeException) -> print e)
-- | Run benchmarks as foreground action for current package
packageBench :: PackageAction
packageBench = do
project <- lift ask
package <- ask
interruptSaveAndRun $ packageBench' False True (project, package) (\ _ -> return ())
-- | Run benchmarks
packageBench' :: Bool -> Bool -> (Project, IDEPackage) -> (Bool -> IDEAction) -> IDEAction
packageBench' backgroundBuild jumpToWarnings (project, package) continuation =
if "--enable-benchmarks" `elem` ipdConfigFlags package
then do
pd <- liftIO $ fmap flattenPackageDescription
(readPackageDescription normal (ipdCabalFile package))
runBenchs $ benchmarks pd
else continuation True
where
runBenchs :: [Benchmark] -> IDEAction
runBenchs [] = continuation True
runBenchs (bench:rest) =
packageRunComponent (CBench bench) backgroundBuild jumpToWarnings (project, package) (\ok ->
when ok $ runBenchs rest)
packageSdist :: PackageAction
packageSdist = do
package <- ask
interruptSaveAndRun $ do
logLaunch <- getDefaultLogLaunch
showDefaultLogLaunch'
catchIDE (do
prefs <- readIDE prefs
let dir = ipdPackageDir package
runExternalTool' (__ "Source Dist") "cabal" ("sdist" : ipdSdistFlags package) dir Nothing (logOutput logLaunch))
(\(e :: SomeException) -> print e)
-- | Open generated documentation for package
packageOpenDoc :: PackageAction
packageOpenDoc = do
project <- lift ask
package <- ask
let dir = ipdPackageDir package
pkgId = packageIdentifierToString $ ipdPackageId package
projectRoot = pjDir project
distDir <- case pjTool project of
StackTool -> do
--ask stack where its dist directory is
mvar <- liftIO newEmptyMVar
runExternalTool' "" "stack" ["path"] dir Nothing $ do
output <- CL.consume
liftIO . putMVar mvar $ head $ mapMaybe getDistOutput output
liftIO $ takeMVar mvar
CabalTool -> do
(buildDir, _) <- liftIO $ cabalProjectBuildDir (pjDir project)
return $ buildDir </> T.unpack pkgId
liftIDE $ do
prefs <- readIDE prefs
let path = dir </> distDir
</> "doc/html"
</> T.unpack (ipdPackageName package)
</> "index.html"
loadDoc . T.pack $ "file://" ++ path
getDocumentation Nothing >>= \ p -> displayPane p False
`catchIDE`
(\(e :: SomeException) -> print e)
where
-- get dist directory from stack path output
getDistOutput (ToolOutput o) | Just t<-T.stripPrefix "dist-dir:" o = Just $ dropWhile isSpace $ T.unpack t
getDistOutput _ = Nothing
runPackage :: (ProcessHandle -> IDEAction)
-> Text
-> FilePath
-> [Text]
-> FilePath
-> Maybe [(String,String)]
-> C.Sink ToolOutput IDEM ()
-> IDEAction
runPackage = runExternalTool (return True) -- TODO here one could check if package to be run is building/configuring/etc atm
-- ---------------------------------------------------------------------
-- | * Utility functions/procedures, that have to do with packages
--
getPackageDescriptionAndPath :: IDEM (Maybe (PackageDescription,FilePath))
getPackageDescriptionAndPath = do
active <- readIDE activePack
case active of
Nothing -> do
ideMessage Normal (__ "No active package")
return Nothing
Just p -> do
ideR <- ask
reifyIDE (\ideR -> catch (do
pd <- readPackageDescription normal (ipdCabalFile p)
return (Just (flattenPackageDescription pd,ipdCabalFile p)))
(\(e :: SomeException) -> do
reflectIDE (ideMessage Normal (__ "Can't load package " <> T.pack (show e))) ideR
return Nothing))
getEmptyModuleTemplate :: PackageDescription -> Text -> IO Text
getEmptyModuleTemplate pd modName = getModuleTemplate "module" pd modName "" ""
getModuleTemplate :: FilePath -> PackageDescription -> Text -> Text -> Text -> IO Text
getModuleTemplate templateName pd modName exports body = catch (do
dataDir <- getDataDir
filePath <- getConfigFilePathForLoad (templateName <> leksahTemplateFileExtension) Nothing dataDir
template <- T.readFile filePath
return (foldl' (\ a (from, to) -> T.replace from to a) template
[ ("@License@" , (T.pack . display . license) pd)
, ("@Maintainer@" , T.pack $ maintainer pd)
, ("@Stability@" , T.pack $ stability pd)
, ("@Portability@" , "")
, ("@Copyright@" , T.pack $ copyright pd)
, ("@ModuleName@" , modName)
, ("@ModuleExports@", exports)
, ("@ModuleBody@" , body)]))
(\ (e :: SomeException) -> do
sysMessage Normal . T.pack $ printf (__ "Couldn't read template file: %s") (show e)
return "")
data ModuleLocation = LibExposedMod | LibOtherMod | ExeOrTestMod Text
addModuleToPackageDescr :: ModuleName -> [ModuleLocation] -> PackageAction
addModuleToPackageDescr moduleName locations = do
p <- ask
liftIDE $ reifyIDE (\ideR -> catch (do
gpd <- readPackageDescription normal (ipdCabalFile p)
let npd = trace (show gpd) foldr addModule gpd locations
writeGenericPackageDescription' (ipdCabalFile p) npd)
(\(e :: SomeException) -> do
reflectIDE (ideMessage Normal (__ "Can't update package " <> T.pack (show e))) ideR
return ()))
where
addModule LibExposedMod gpd@GenericPackageDescription{condLibrary = Just lib} =
gpd {condLibrary = Just (addModToLib moduleName lib)}
addModule LibOtherMod gpd@GenericPackageDescription{condLibrary = Just lib} =
gpd {condLibrary = Just (addModToBuildInfoLib moduleName lib)}
addModule (ExeOrTestMod name') gpd = let name = mkUnqualComponentName (T.unpack name') in gpd {
condExecutables = map (addModToBuildInfoExe name moduleName) (condExecutables gpd)
, condTestSuites = map (addModToBuildInfoTest name moduleName) (condTestSuites gpd)
}
addModule _ x = x
addModToLib :: ModuleName -> CondTree ConfVar [Dependency] Library ->
CondTree ConfVar [Dependency] Library
addModToLib modName ct@CondNode{condTreeData = lib} =
ct{condTreeData = lib{exposedModules = modName `inOrderAdd` exposedModules lib}}
addModToBuildInfoLib :: ModuleName -> CondTree ConfVar [Dependency] Library ->
CondTree ConfVar [Dependency] Library
addModToBuildInfoLib modName ct@CondNode{condTreeData = lib} =
ct{condTreeData = lib{libBuildInfo = (libBuildInfo lib){otherModules = modName
`inOrderAdd` otherModules (libBuildInfo lib)}}}
addModToBuildInfoExe :: UnqualComponentName -> ModuleName -> (UnqualComponentName, CondTree ConfVar [Dependency] Executable) ->
(UnqualComponentName, CondTree ConfVar [Dependency] Executable)
addModToBuildInfoExe name modName (str,ct@CondNode{condTreeData = exe}) | str == name =
(str, ct{condTreeData = exe{buildInfo = (buildInfo exe){otherModules = modName
`inOrderAdd` otherModules (buildInfo exe)}}})
addModToBuildInfoExe name _ x = x
addModToBuildInfoTest :: UnqualComponentName -> ModuleName -> (UnqualComponentName, CondTree ConfVar [Dependency] TestSuite) ->
(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)
addModToBuildInfoTest name modName (str,ct@CondNode{condTreeData = test}) | str == name =
(str, ct{condTreeData = test{testBuildInfo = (testBuildInfo test){otherModules = modName
`inOrderAdd` otherModules (testBuildInfo test)}}})
addModToBuildInfoTest _ _ x = x
inOrderAdd :: Ord a => a -> [a] -> [a]
inOrderAdd a list = let (before, after) = span (< a) list in before ++ [a] ++ after
--------------------------------------------------------------------------
delModuleFromPackageDescr :: ModuleName -> PackageAction
delModuleFromPackageDescr moduleName = do
p <- ask
liftIDE $ reifyIDE (\ideR -> catch (do
gpd <- readPackageDescription normal (ipdCabalFile p)
let isExposedAndJust = isExposedModule moduleName (condLibrary gpd)
let npd = if isExposedAndJust
then gpd{
condLibrary = Just (delModFromLib moduleName
(fromJust (condLibrary gpd))),
condExecutables = map (delModFromBuildInfoExe moduleName)
(condExecutables gpd)}
else gpd{
condLibrary = case condLibrary gpd of
Nothing -> Nothing
Just lib -> Just (delModFromBuildInfoLib moduleName
(fromJust (condLibrary gpd))),
condExecutables = map (delModFromBuildInfoExe moduleName)
(condExecutables gpd)}
writeGenericPackageDescription' (ipdCabalFile p) npd)
(\(e :: SomeException) -> do
reflectIDE (ideMessage Normal (__ "Can't update package " <> T.pack (show e))) ideR
return ()))
delModFromLib :: ModuleName -> CondTree ConfVar [Dependency] Library ->
CondTree ConfVar [Dependency] Library
delModFromLib modName ct@CondNode{condTreeData = lib} =
ct{condTreeData = lib{exposedModules = delete modName (exposedModules lib)}}
delModFromBuildInfoLib :: ModuleName -> CondTree ConfVar [Dependency] Library ->
CondTree ConfVar [Dependency] Library
delModFromBuildInfoLib modName ct@CondNode{condTreeData = lib} =
ct{condTreeData = lib{libBuildInfo = (libBuildInfo lib){otherModules =
delete modName (otherModules (libBuildInfo lib))}}}
delModFromBuildInfoExe :: ModuleName -> (UnqualComponentName, CondTree ConfVar [Dependency] Executable) ->
(UnqualComponentName, CondTree ConfVar [Dependency] Executable)
delModFromBuildInfoExe modName (str,ct@CondNode{condTreeData = exe}) =
(str, ct{condTreeData = exe{buildInfo = (buildInfo exe){otherModules =
delete modName (otherModules (buildInfo exe))}}})
isExposedModule :: ModuleName -> Maybe (CondTree ConfVar [Dependency] Library) -> Bool
isExposedModule mn Nothing = False
isExposedModule mn (Just CondNode{condTreeData = lib}) = mn `elem` exposedModules lib
backgroundBuildToggled :: IDEAction
backgroundBuildToggled = do
toggled <- getBackgroundBuildToggled
modifyIDE_ (\ide -> ide{prefs = (prefs ide){backgroundBuild = toggled}})
makeDocsToggled :: IDEAction
makeDocsToggled = do
toggled <- getMakeDocs
modifyIDE_ (\ide -> ide{prefs = (prefs ide){makeDocs = toggled}})
runUnitTestsToggled :: IDEAction
runUnitTestsToggled = do
toggled <- getRunUnitTests
modifyIDE_ (\ide -> ide{prefs = (prefs ide){runUnitTests = toggled}})
runBenchmarksToggled :: IDEAction
runBenchmarksToggled = do
toggled <- getRunBenchmarks
modifyIDE_ (\ide -> ide{prefs = (prefs ide){runBenchmarks = toggled}})
makeModeToggled :: IDEAction
makeModeToggled = do
toggled <- getMakeModeToggled
modifyIDE_ (\ide -> ide{prefs = (prefs ide){makeMode = toggled}})
-- ---------------------------------------------------------------------
-- | * Debug code that needs to use the package
--
interactiveFlag :: Text -> Bool -> Text
interactiveFlag name f = (if f then "-f" else "-fno-") <> name
printEvldWithShowFlag :: Bool -> Text
printEvldWithShowFlag = interactiveFlag "print-evld-with-show"
breakOnExceptionFlag :: Bool -> Text
breakOnExceptionFlag = interactiveFlag "break-on-exception"
breakOnErrorFlag :: Bool -> Text
breakOnErrorFlag = interactiveFlag "break-on-error"
printBindResultFlag :: Bool -> Text
printBindResultFlag = interactiveFlag "print-bind-result"
interactiveFlags :: Prefs -> [Text]
interactiveFlags prefs =
printEvldWithShowFlag (printEvldWithShow prefs)
: breakOnExceptionFlag (breakOnException prefs)
: breakOnErrorFlag (breakOnError prefs)
: [printBindResultFlag $ printBindResult prefs]
debugStart :: PackageAction
debugStart = do
project <- lift ask
package <- ask
liftIDE $ catchIDE (do
ideRef <- ask
prefs' <- readIDE prefs
maybeDebug <- readIDE debugState
case maybeDebug of
Nothing -> do
mbTarget <- readIDE activeComponent
let dir = ipdPackageDir package
name = ipdPackageName package
(tool, args) = case pjTool project of
CabalTool -> ("cabal", [ "new-repl"
, "--project-file"
, T.pack . makeRelative dir $ pjFile project
, name <> maybe (":lib:" <> name) (":" <>) mbTarget
])
StackTool -> ("stack", [ "repl"
, "--stack-yaml"
, T.pack . makeRelative dir $ pjFile project
, name <> maybe "" (":" <>) mbTarget
])
ghci <- reifyIDE $ \ideR -> newGhci tool args dir (interactiveFlags prefs')
$ reflectIDEI (void (logOutputForBuild project package True False)) ideR
modifyIDE_ (\ide -> ide {debugState = Just (package, ghci)})
triggerEventIDE (Sensitivity [(SensitivityInterpreting, True)])
setDebugToggled True
-- Fork a thread to wait for the output from the process to close
liftIO $ forkIO $ do
readMVar (outputClosed ghci)
(`reflectIDE` ideRef) . postSyncIDE $ do
setDebugToggled False
modifyIDE_ (\ide -> ide {debugState = Nothing, autoCommand = return ()})
triggerEventIDE (Sensitivity [(SensitivityInterpreting, False)])
-- Kick of a build if one is not already due
modifiedPacks <- fileCheckAll belongsToPackages'
let modified = not (null modifiedPacks)
prefs <- readIDE prefs
when (not modified && backgroundBuild prefs) $ do
-- So although none of the pakages are modified,
-- they may have been modified in ghci mode.
-- Lets build to make sure the binaries are up to date
mbPackage <- readIDE activePack
case mbPackage of
Just package -> runCabalBuild True False False (project, package) (\ _ -> return ())
Nothing -> return ()
return ()
_ -> do
sysMessage Normal (__ "Debugger already running")
return ())
(\(e :: SomeException) -> print e)
tryDebug :: DebugAction -> PackageAction
tryDebug f = do
maybeDebug <- liftIDE $ readIDE debugState
case maybeDebug of
Just debug ->
-- TODO check debug package matches active package
liftIDE $ runDebug f debug
_ -> do
window <- liftIDE getMainWindow
md <- new' MessageDialog [
constructDialogUseHeaderBar 0,
constructMessageDialogButtons ButtonsTypeCancel]
setMessageDialogMessageType md MessageTypeQuestion
setMessageDialogText md $ __ "GHCi debugger is not running."
windowSetTransientFor md (Just window)
dialogAddButton' md (__ "_Start GHCi") (AnotherResponseType 1)
dialogSetDefaultResponse' md (AnotherResponseType 1)
setWindowWindowPosition md WindowPositionCenterOnParent
resp <- dialogRun' md
widgetDestroy md
case resp of
AnotherResponseType 1 -> do
debugStart
maybeDebug <- liftIDE $ readIDE debugState
case maybeDebug of
Just debug -> liftIDE $ postAsyncIDE $ runDebug f debug
_ -> return ()
_ -> return ()
tryDebugQuiet :: DebugAction -> PackageAction
tryDebugQuiet f = do
maybeDebug <- liftIDE $ readIDE debugState
case maybeDebug of
Just debug ->
-- TODO check debug package matches active package
liftIDE $ runDebug f debug
_ ->
return ()
executeDebugCommand :: Text -> C.Sink ToolOutput IDEM () -> DebugAction
executeDebugCommand command handler = do
(_, ghci) <- ask
lift $ do
ideR <- ask
postAsyncIDE $ do
triggerEventIDE (StatusbarChanged [CompartmentState command, CompartmentBuild True])
return ()
liftIO . executeGhciCommand ghci command $
reflectIDEI (do
lift . postSyncIDE $ do
triggerEventIDE (StatusbarChanged [CompartmentState "", CompartmentBuild False])
return ()
handler) ideR
-- Includes non buildable
allBuildInfo' :: PackageDescription -> [BuildInfo]
allBuildInfo' pkg_descr = [ libBuildInfo lib | Just lib <- [library pkg_descr] ]
++ [ buildInfo exe | exe <- executables pkg_descr ]
++ [ testBuildInfo tst | tst <- testSuites pkg_descr ]
++ [ benchmarkBuildInfo tst | tst <- benchmarks pkg_descr ]
testMainPath (TestSuiteExeV10 _ f) = [f]
testMainPath _ = []
idePackageFromPath' :: FilePath -> IDEM (Maybe IDEPackage)
idePackageFromPath' ipdCabalFile = do
mbPackageD <- reifyIDE (\ideR -> catch (do
pd <- readPackageDescription normal ipdCabalFile
return (Just (flattenPackageDescription pd)))
(\ (e :: SomeException) -> do
reflectIDE (ideMessage Normal (__ "Can't activate package " <> T.pack (show e))) ideR
return Nothing))
case mbPackageD of
Nothing -> return Nothing
Just packageD -> do
let ipdModules = Map.fromList $ myLibModules packageD ++ myExeModules packageD
++ myTestModules packageD ++ myBenchmarkModules packageD
ipdMain = [ (modulePath exe, buildInfo exe, False) | exe <- executables packageD ]
++ [ (f, bi, True) | TestSuite {testInterface = TestSuiteExeV10 _ f, testBuildInfo = bi} <- testSuites packageD ]
++ [ (f, bi, True) | Benchmark {benchmarkInterface = BenchmarkExeV10 _ f, benchmarkBuildInfo = bi} <- benchmarks packageD ]
ipdExtraSrcs = Set.fromList $ extraSrcFiles packageD
ipdSrcDirs = case nub $ concatMap hsSourceDirs (allBuildInfo' packageD) of
[] -> [".","src"]
l -> l
ipdExes = [ T.pack . unUnqualComponentName $ exeName e | e <- executables packageD ]
ipdExtensions = nub $ concatMap oldExtensions (allBuildInfo' packageD)
ipdTests = [ T.pack . unUnqualComponentName $ testName t | t <- testSuites packageD ]
ipdBenchmarks = [ T.pack . unUnqualComponentName $ benchmarkName b | b <- benchmarks packageD ]
ipdPackageId = package packageD
ipdDepends = buildDepends packageD
ipdHasLibs = hasLibs packageD
ipdConfigFlags = ["--enable-tests"]
ipdBuildFlags = []
ipdTestFlags = []
ipdBenchmarkFlags = []
ipdHaddockFlags = []
ipdExeFlags = []
ipdInstallFlags = []
ipdRegisterFlags = []
ipdUnregisterFlags = []
ipdSdistFlags = []
ipdSandboxSources = []
packp = IDEPackage {..}
pfile = dropExtension ipdCabalFile
pack <- do
flagFileExists <- liftIO $ doesFileExist (pfile ++ leksahFlagFileExtension)
if flagFileExists
then liftIO $ readFlags (pfile ++ leksahFlagFileExtension) packp
else return packp
return (Just pack)
extractStackPackageList :: Text -> [String]
extractStackPackageList = (\x -> if null x then ["."] else x) .
map (stripQuotes . T.unpack . (\x -> fromMaybe x $ T.stripPrefix "location: " x)) .
filterSimple .
filter (not . T.null) .
map (T.reverse . T.dropWhile isSpace . T.reverse) .
drop 1 .
dropWhile (/= "packages:") .
map (T.pack . stripStackComments . T.unpack) .
T.lines
where
stripQuotes ('\'':rest) | take 1 (reverse rest) == "\'" = init rest
stripQuotes x = x
stripStackComments :: String -> String
stripStackComments "" = ""
stripStackComments ('#':_) = ""
stripStackComments (x:xs) = x:stripStackComments xs
filterSimple [] = []
filterSimple (x:xs) = let indent = T.takeWhile (==' ') x in
mapMaybe (T.stripPrefix (indent <> "- ")) $
takeWhile (\l -> (indent <> "- ") `T.isPrefixOf` l || (indent <> " ") `T.isPrefixOf` l) (x:xs)
extractCabalPackageList :: Text -> [String]
extractCabalPackageList = map (dirOnly .T.unpack . T.dropWhile (==' ')) .
takeWhile (" " `T.isPrefixOf`) .
drop 1 .
dropWhile (/= "packages:") .
filter (not . T.null) .
map (T.pack . stripCabalComments . T.unpack) .
T.lines
where
stripCabalComments :: String -> String
stripCabalComments "" = ""
stripCabalComments ('-':'-':_) = ""
stripCabalComments (x:xs) = x:stripCabalComments xs
dirOnly :: FilePath -> FilePath
dirOnly f = if takeExtension f == "cabal" then dropFileName f else f
ideProjectFromPath :: FilePath -> IDEM (Maybe Project)
ideProjectFromPath filePath = do
let toolInfo = case takeExtension filePath of
".project" -> Just (CabalTool, extractCabalPackageList)
".yaml" -> Just (StackTool, extractStackPackageList)
_ -> Nothing
case toolInfo of
Just (tool, extractPackageList) -> do
let dir = takeDirectory filePath
paths <- liftIO $ map (dir </>) . extractPackageList <$> T.readFile filePath
packages <- catMaybes <$> forM paths (\path -> do
exists <- liftIO (doesDirectoryExist path)
if exists
then do
cpath <- liftIO $ canonicalizePath path
contents <- liftIO $ getDirectoryContents cpath
let mbCabalFile = find ((== ".cabal") . takeExtension) contents
when (isNothing mbCabalFile) $
ideMessage Normal ("Could not find cabal file for " <> T.pack cpath)
return (fmap (cpath </>) mbCabalFile)
else do
ideMessage Normal ("Path does not exist: " <> T.pack path)
return Nothing)
packages <- fmap catMaybes . mapM idePackageFromPath' $ nub packages
return . Just $ Project { pjTool = tool, pjFile = filePath, pjPackageMap = mkPackageMap packages }
Nothing -> return Nothing
--refreshPackage :: C.Sink ToolOutput IDEM () -> PackageM (Maybe IDEPackage)
--refreshPackage log = do
-- package <- ask
-- liftIDE $ do
-- mbUpdatedPack <- idePackageFromPath log (ipdCabalFile package)
-- case mbUpdatedPack of
-- Just updatedPack -> do
-- changePackage updatedPack
-- triggerEventIDE $ WorkspaceChanged False True
-- return mbUpdatedPack
-- Nothing -> do
-- postAsyncIDE $ ideMessage Normal (__ "Can't read package file")
-- return Nothing