leksah-0.1: src/IDE/BuildInfoEditor.hs
{-# OPTIONS_GHC -fglasgow-exts #-}
--
-- | Module for editing of cabal build infos
--
module IDE.BuildInfoEditor (
editBuildInfo -- Maybe FilePath -> [String] -> BuildInfo -> String -> IO (Maybe BuildInfo)
, BuildEditorFactory(..)
, BuildEditorFactoryI(..)
) where
import Graphics.UI.Gtk
import qualified Graphics.UI.Gtk.ModelView as New(cellText)
import Control.Monad.Reader
import Distribution.PackageDescription
import Data.IORef
import Data.List
import IDE.Core.State
import IDE.SpecialEditors
import IDE.Framework.ViewFrame
import IDE.Framework.EditorBasics
import IDE.Framework.MakeEditor
import IDE.Framework.SimpleEditors
import IDE.Framework.CompositeEditors
import IDE.Framework.Parameters
class IDEEditor alpha => BuildEditorFactory alpha where
buildInfoEditor :: alpha -> Maybe FilePath -> [String] -> Editor BuildInfo
libraryEditor :: alpha -> Maybe FilePath -> [String] -> Editor Library
executableEditor :: alpha -> Maybe FilePath -> [String] -> Editor Executable
executablesEditor :: alpha -> Maybe FilePath -> [String] -> Editor [Executable]
data BuildEditorFactoryI = BuildEditorFactoryI
deriving (Eq,Ord,Show)
instance IDEObject BuildEditorFactoryI
instance IDEEditor BuildEditorFactoryI
instance BuildEditorFactory BuildEditorFactoryI where
buildInfoEditor factory mbFp list = buildInfoEditor' mbFp list
libraryEditor factory mbFp list = libraryEditor' mbFp list
executableEditor factory mbFp list = executableEditor' mbFp list
executablesEditor factory mbFp list = executablesEditor' mbFp list
-- ------------------------------------------------------------
-- * Build Infos
-- ------------------------------------------------------------
buildInfoEditor' :: Maybe FilePath -> [String] -> Editor BuildInfo
buildInfoEditor' fp modules p = do
(wid,inj,ext,notif) <- otherEditor (editBuildInfo fp modules) p
box <- vBoxNew False 1
textView <- textViewNew
widgetSetSizeRequest textView (-1) 300
containerAdd box wid
containerAdd box textView
buffer <- textViewGetBuffer textView
let binj bi = do
inj bi
textBufferSetText buffer $showHookedBuildInfo (Just bi,[])
notif FocusIn $Left (changedHandler buffer ext)
return (castToWidget box,binj,ext,notif)
where
changedHandler buffer ext _ = do
mbv <- ext
case mbv of
Just v -> textBufferSetText buffer $showHookedBuildInfo (Just v,[])
Nothing -> return ()
return True
libraryEditor' :: Maybe FilePath -> [String] -> Editor Library
libraryEditor' fp modules para = do
(wid,inj,ext,notif) <-
pairEditor
(modulesEditor modules, paraName <<<- ParaName "Exposed Modules" $para)
(buildInfoEditor' fp modules, paraName <<<- ParaName "Build Info" $ para)
(paraDirection <<<- ParaDirection Vertical $ emptyParams)
let pinj (Library em bi) = inj (em,bi)
let pext = do
mbp <- ext
case mbp of
Nothing -> return Nothing
Just (em,bi) -> return (Just $Library em bi)
return (wid,pinj,pext,notif)
modulesEditor :: [String] -> Editor [String]
modulesEditor modules = staticMultiselectionEditor modules
moduleEditor :: [String] -> Editor String
moduleEditor modules = staticSelectionEditor modules
executableEditor' :: Maybe FilePath -> [String] -> Editor Executable
executableEditor' fp modules para = do
(wid,inj,ext,notif) <- pairEditor
(pairEditor
(stringEditor, paraName <<<- ParaName "Executable Name" $ emptyParams)
(fileEditor fp FileChooserActionOpen "Select File",
paraName <<<- ParaName "Main Module" $ emptyParams),
(paraDirection <<<- ParaDirection Vertical $ emptyParams))
(buildInfoEditor' fp modules, paraName <<<- ParaName "Build Info" $ emptyParams)
(paraDirection <<<- ParaDirection Vertical $ para)
let pinj (Executable s f bi) = inj ((s,f),bi)
let pext = do
mbp <- ext
case mbp of
Nothing -> return Nothing
Just ((s,f),bi) -> return (Just $Executable s f bi)
return (wid,pinj,pext,notif)
executablesEditor' :: Maybe FilePath -> [String] -> Editor [Executable]
executablesEditor' fp modules p =
multisetEditor
(ColumnDescr False [("Executable Name",\(Executable exeName _ _) -> [New.cellText := exeName])
,("Module Path",\(Executable _ mp _) -> [New.cellText := mp])])
(executableEditor' fp modules ,emptyParams)
(paraShadow <<<- ParaShadow ShadowIn $ p)
buildInfoD :: Maybe FilePath -> [String] -> [(String,[FieldDescription BuildInfo])]
buildInfoD fp modules = [
("Description", [
mkField
(paraName <<<- ParaName "Component is buildable here" $ emptyParams)
buildable
(\ a b -> b{buildable = a})
boolEditor
, mkField
(paraName <<<- ParaName "Non-exposed or non-main modules"
$ paraSynopsis <<<- ParaSynopsis ("A list of modules used by the component but "
++ "not exposed to users.")
$ paraShadow <<<- ParaShadow ShadowIn
$ paraDirection <<<- ParaDirection Vertical
$ emptyParams)
otherModules
(\ a b -> b{otherModules = a})
(modulesEditor modules)
, mkField
(paraName <<<- ParaName
"Where to look for the haskell module hierarchy"
$ paraSynopsis <<<- ParaSynopsis
"Root directories for the module hierarchy."
$ paraShadow <<<- ParaShadow ShadowIn
$ paraDirection <<<- ParaDirection Vertical
$ emptyParams)
hsSourceDirs
(\ a b -> b{hsSourceDirs = a})
(filesEditor fp FileChooserActionSelectFolder "Select folder")
]),
("Extensions",[
mkField
(paraName <<<- ParaName "Extensions"
$ paraSynopsis <<<- ParaSynopsis
"A list of Haskell extensions used by every module."
$ emptyParams)
extensions
(\ a b -> b{extensions = a})
extensionsEditor
]),
("Options",[
mkField
(paraName <<<- ParaName "Options for haskell compilers"
$ paraDirection <<<- ParaDirection Vertical
$ emptyParams)
options
(\ a b -> b{options = a})
(multisetEditor
(ColumnDescr True [("Compiler Flavor",\(cv,_) -> [New.cellText := show cv])
,("Options",\(_,op) -> [New.cellText := show op])])
((pairEditor
(compilerFlavorEditor,emptyParams)
(stringsEditor,emptyParams)),
(paraDirection <<<- ParaDirection Vertical
$ paraShadow <<<- ParaShadow ShadowIn $ emptyParams)))
, mkField
(paraName <<<- ParaName "Additional options for GHC when built with profiling"
$ paraDirection <<<- ParaDirection Vertical
$ emptyParams)
ghcProfOptions
(\ a b -> b{ghcProfOptions = a})
stringsEditor
, mkField
(paraName <<<- ParaName "Options for C compiler"
$ paraDirection <<<- ParaDirection Vertical
$ emptyParams)
ccOptions
(\ a b -> b{ccOptions = a})
stringsEditor
, mkField
(paraName <<<- ParaName "Options for linker"
$ paraDirection <<<- ParaDirection Vertical
$ emptyParams)
ldOptions
(\ a b -> b{ldOptions = a})
stringsEditor
]),
("C",[
mkField
(paraName <<<- ParaName "A list of header files already installed on the system"
$ paraDirection <<<- ParaDirection Vertical $ emptyParams)
includes
(\ a b -> b{includes = a})
stringsEditor
, mkField
(paraName <<<- ParaName "A list of header files from this package"
$ paraDirection <<<- ParaDirection Vertical $ emptyParams)
installIncludes
(\ a b -> b{installIncludes = a})
(filesEditor fp FileChooserActionOpen "Select File")
, mkField
(paraName <<<- ParaName "A list of directories to search for header files"
$ paraDirection <<<- ParaDirection Vertical $ emptyParams)
includeDirs
(\ a b -> b{includeDirs = a})
(filesEditor fp FileChooserActionSelectFolder "Select Folder")
, mkField
(paraName <<<- ParaName
"A list of C source files to be compiled,linked with the Haskell files."
$ paraDirection <<<- ParaDirection Vertical $ emptyParams)
cSources
(\ a b -> b{cSources = a})
(filesEditor fp FileChooserActionOpen "Select file")
, mkField
(paraName <<<- ParaName "A list of extra libraries to link with"
$ paraDirection <<<- ParaDirection Vertical $ emptyParams)
extraLibs
(\ a b -> b{extraLibs = a})
stringsEditor
, mkField
(paraName <<<- ParaName "A list of directories to search for libraries."
$ paraDirection <<<- ParaDirection Vertical $ emptyParams)
extraLibDirs
(\ a b -> b{extraLibDirs = a})
(filesEditor fp FileChooserActionSelectFolder "Select Folder")
]),
("Mac OS X",[
mkField
(paraName <<<- ParaName "Support frameworks for Mac OS X"
$ paraDirection <<<- ParaDirection Vertical $ emptyParams)
cSources
(\ a b -> b{cSources = a})
stringsEditor
])]
editBuildInfo :: Maybe FilePath -> [String] -> BuildInfo -> String -> IO (Maybe BuildInfo)
editBuildInfo fp modules buildInfo contextStr = do
res <- editBuildInfo' buildInfo contextStr (buildInfoD fp modules)
return res
editBuildInfo' :: BuildInfo -> String -> [(String,[FieldDescription BuildInfo])] -> IO (Maybe BuildInfo)
editBuildInfo' buildInfo contextStr buildInfoD = do
resRef <- newIORef Nothing
dialog <- windowNew
windowSetModal dialog True
vb <- vBoxNew False 7
bb <- hButtonBoxNew
ok <- buttonNewFromStock "gtk-ok"
cancel <- buttonNewFromStock "gtk-cancel"
boxPackStart bb ok PackNatural 0
boxPackStart bb cancel PackNatural 0
nb <- newNotebook
notebookSetTabPos nb PosTop
res <- mapM
(\ (tabLabel, partBuildInfoD) -> do
resList <- mapM (\ (FD _ editorF) -> editorF buildInfo) partBuildInfoD
let (widgetsP, setInjsP, getExtsP,notifiersP) = unzip4 resList
nbbox <- vBoxNew False 0
mapM_ (\ w -> boxPackStart nbbox w PackNatural 0) widgetsP
sw <- scrolledWindowNew Nothing Nothing
scrolledWindowAddWithViewport sw nbbox
scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic
notebookAppendPage nb sw tabLabel
return (widgetsP, setInjsP, getExtsP, notifiersP))
buildInfoD
let (widgets, setInjs, getExts, notifiers) =
foldl (\ (w,i,e,n) (w2,i2,e2,n2) -> (w ++ w2, i ++ i2, e ++ e2, n ++ n2)) ([],[],[],[]) res
let fieldNames = map (\fd -> case getParameterPrim paraName (parameters fd) of
Just s -> s
Nothing -> "Unnamed")
$concatMap snd buildInfoD
ok `onClicked` (do
mbNewBuildInfo <- extractAndValidate buildInfo getExts fieldNames
case mbNewBuildInfo of
Nothing -> do
sysMessage Normal "Cant't validate build info"
return ()
Just newBuildInfo -> do
writeIORef resRef (Just newBuildInfo)
widgetDestroy dialog
mainQuit
return ())
cancel `onClicked` (do
widgetDestroy dialog
mainQuit
return ())
dialog `onDelete` (\e -> do
widgetDestroy dialog
mainQuit
return True)
boxPackStart vb nb PackGrow 7
boxPackEnd vb bb PackNatural 7
containerAdd dialog vb
widgetSetSizeRequest dialog 500 700
widgetShowAll dialog
mainGUI
res <- readIORef resRef
return (res)