module IDE.Pane.PackageFlags (
readFlags
, writeFlags
, IDEFlags(..)
, FlagsState
, getFlags
) where
import Graphics.UI.Gtk
import qualified Text.PrettyPrint.HughesPJ as PP
import Data.Typeable
import System.FilePath.Posix
import IDE.Core.State
import Graphics.UI.Editor.Basics
import Graphics.UI.Editor.MakeEditor
import Graphics.UI.Editor.Simple
import Graphics.UI.Editor.Parameters
import Text.PrinterParser hiding (fieldParser,parameters)
import Control.Event (registerEvent)
import Graphics.UI.Editor.DescriptionPP
(flattenFieldDescriptionPPToS,
extractFieldDescription,
FieldDescriptionPP(..),
mkFieldPP)
import Text.ParserCombinators.Parsec hiding(Parser)
import IDE.Utils.GUIUtils (__)
import Control.Monad (void)
import Data.Text (Text)
import Data.Monoid ((<>))
import qualified Data.Text as T (unwords, unpack, pack)
import Control.Applicative ((<$>))
data IDEFlags = IDEFlags {
flagsBox :: VBox
} deriving Typeable
data FlagsState = FlagsState
deriving(Eq,Ord,Read,Show,Typeable)
instance Pane IDEFlags IDEM
where
primPaneName _ = __ "Package Flags"
getAddedIndex _ = 0
getTopWidget = castToWidget . flagsBox
paneId b = "*Flags"
instance RecoverablePane IDEFlags FlagsState IDEM where
saveState p = do
mbFlags :: Maybe IDEFlags <- getPane
case mbFlags of
Nothing -> return Nothing
Just p -> return (Just FlagsState)
recoverState pp st = do
mbPack <- readIDE activePack
case mbPack of
Just pack -> do
pp <- getBestPathForId "*Flags"
nb <- getNotebook pp
case mbPack of
Nothing -> return Nothing
Just pack -> buildThisPane pp nb builder
Nothing -> return Nothing
builder pp nb w =
let flagsDesc = extractFieldDescription flagsDescription
flatflagsDesc = flattenFieldDescription flagsDesc
in do
mbPack <- readIDE activePack
case mbPack of
Nothing -> return (Nothing,[])
Just p -> reifyIDE $ \ideR -> builder' p flagsDesc flatflagsDesc pp nb window ideR
builder' idePackage flagsDesc flatflagsDesc pp nb window ideR = do
vb <- vBoxNew False 0
let flagsPane = IDEFlags vb
bb <- hButtonBoxNew
boxSetSpacing bb 6
buttonBoxSetLayout bb ButtonboxSpread
saveB <- buttonNewFromStock "gtk-save"
widgetSetSensitive saveB False
cancelB <- buttonNewFromStock "gtk-cancel"
boxPackStart bb cancelB PackNatural 0
boxPackStart bb saveB PackNatural 0
(widget,injb,ext,notifier)
<- buildEditor flagsDesc idePackage
sw <- scrolledWindowNew Nothing Nothing
scrolledWindowSetShadowType sw ShadowIn
scrolledWindowAddWithViewport sw widget
scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic
on saveB buttonActivated (do
mbPackWithNewFlags <- extract idePackage [ext]
case mbPackWithNewFlags of
Nothing -> return ()
Just packWithNewFlags -> do
reflectIDE (do
changePackage packWithNewFlags
closePane flagsPane) ideR
writeFields (dropExtension (ipdCabalFile packWithNewFlags) ++
leksahFlagFileExtension)
packWithNewFlags flatFlagsDescription)
on cancelB buttonActivated (reflectIDE (void (closePane flagsPane)) ideR)
registerEvent notifier FocusIn (\e -> do
reflectIDE (makeActive flagsPane) ideR
return (e{gtkReturn=False}))
registerEvent notifier MayHaveChanged (\e -> do
mbP <- extract idePackage [ext]
let hasChanged = case mbP of
Nothing -> False
Just p -> p /= idePackage
markLabel nb (getTopWidget flagsPane) hasChanged
widgetSetSensitive saveB hasChanged
return (e{gtkReturn=False}))
boxPackStart vb sw PackGrow 0
boxPackEnd vb bb PackNatural 6
return (Just flagsPane,[])
getFlags :: Maybe PanePath -> IDEM IDEFlags
getFlags Nothing = forceGetPane (Right "*Flags")
getFlags (Just pp) = forceGetPane (Left pp)
quoteArg :: String -> String
quoteArg s | ' ' `elem` s = "\"" <> escapeQuotes s <> "\""
quoteArg s = s
escapeQuotes = foldr (\c s -> if c == '"' then '\\':c:s else c:s) ""
quotedArgCharParser :: CharParser () Char
quotedArgCharParser = try (do
char '\\'
anyChar)
<|> try (
noneOf "\"")
<?> "argsParser"
argParser :: CharParser () Text
argParser = try (do
char '"'
s <- many quotedArgCharParser
char '"'
return $ T.pack s)
<|> try (
T.pack <$> many1 (noneOf " "))
<?> "argParser"
argsParser :: CharParser () [Text]
argsParser = try (
many (do
many (char ' ')
argParser))
<?> "argsParser"
unargs :: [Text] -> Text
unargs = T.unwords . map (T.pack . quoteArg . T.unpack)
args :: Text -> [Text]
args s = case parse argsParser "" $ T.unpack s of
Right result -> result
_ -> [s]
flatFlagsDescription :: [FieldDescriptionS IDEPackage]
flatFlagsDescription = flattenFieldDescriptionPPToS flagsDescription
flagsDescription :: FieldDescriptionPP IDEPackage IDEM
flagsDescription = VFDPP emptyParams [
mkFieldPP
(paraName <<<- ParaName (__ "Config flags") $ emptyParams)
(PP.text . show)
readParser
(unargs . ipdConfigFlags)
(\ b a -> a{ipdConfigFlags = args b})
(textEditor (const True) True)
(\ _ -> return ())
, mkFieldPP
(paraName <<<- ParaName (__ "Build flags") $ emptyParams)
(PP.text . show)
readParser
(unargs . ipdBuildFlags)
(\ b a -> a{ipdBuildFlags = args b})
(textEditor (const True) True)
(\ _ -> return ())
, mkFieldPP
(paraName <<<- ParaName (__ "Test flags") $ emptyParams)
(PP.text . show)
readParser
(unargs . ipdTestFlags)
(\ b a -> a{ipdTestFlags = args b})
(textEditor (const True) True)
(\ _ -> return ())
, mkFieldPP
(paraName <<<- ParaName (__ "Haddock flags") $ emptyParams)
(PP.text . show)
readParser
(unargs . ipdHaddockFlags)
(\ b a -> a{ipdHaddockFlags = args b})
(textEditor (const True) True)
(\ _ -> return ())
, mkFieldPP
(paraName <<<- ParaName (__ "Executable flags") $ emptyParams)
(PP.text . show)
readParser
(unargs . ipdExeFlags)
(\ b a -> a{ipdExeFlags = args b})
(textEditor (const True) True)
(\ _ -> return ())
, mkFieldPP
(paraName <<<- ParaName (__ "Install flags") $ emptyParams)
(PP.text . show)
readParser
(unargs . ipdInstallFlags)
(\ b a -> a{ipdInstallFlags = args b})
(textEditor (const True) True)
(\ _ -> return ())
, mkFieldPP
(paraName <<<- ParaName (__ "Register flags") $ emptyParams)
(PP.text . show)
readParser
(unargs . ipdRegisterFlags)
(\ b a -> a{ipdRegisterFlags = args b})
(textEditor (const True) True)
(\ _ -> return ())
, mkFieldPP
(paraName <<<- ParaName (__ "Unregister flags") $ emptyParams)
(PP.text . show)
readParser
(unargs . ipdUnregisterFlags)
(\ b a -> a{ipdUnregisterFlags = args b})
(textEditor (const True) True)
(\ _ -> return ())
, mkFieldPP
(paraName <<<- ParaName (__ "Source Distribution flags") $ emptyParams)
(PP.text . show)
readParser
(unargs . ipdSdistFlags)
(\ b a -> a{ipdSdistFlags = args b})
(textEditor (const True) True)
(\ _ -> return ())]
readFlags :: FilePath -> IDEPackage -> IO IDEPackage
readFlags fn = readFields fn flatFlagsDescription
writeFlags :: FilePath -> IDEPackage -> IO ()
writeFlags fpath flags = writeFields fpath flags flatFlagsDescription