diff --git a/Options.hs b/Options.hs new file mode 100644 --- /dev/null +++ b/Options.hs @@ -0,0 +1,92 @@ +module Options (Options(..), processArgs, showHelp) where + +-- ?? import Control.Monad (mapM_) + +-- | Options are the interpretation of sifflet command-line arguments. +-- If a function call is requested, the remaining arguments are unparsed, +-- and just saved as strings to be fed into the parser when the +-- function's argument types are known. + +data Options = Options { optionsShowFunPad :: Bool + , optionsHelp :: Bool + , optionsSourceFile :: Maybe FilePath + , optionsShowFunction :: Maybe String + , optionsCallFunction :: Maybe String + , optionsAdditionalArgs :: [String] + , optionsErrorMsg :: Maybe String + } + deriving (Eq, Show) + +defaultOptions :: Options +defaultOptions = Options { optionsShowFunPad = True + , optionsHelp = False + , optionsSourceFile = Nothing + , optionsShowFunction = Nothing + , optionsCallFunction = Nothing + , optionsAdditionalArgs = [] + , optionsErrorMsg = Nothing + } + +processArgs :: [String] -> Options +processArgs = processArgsLoop defaultOptions + +processArgsLoop :: Options -> [String] -> Options +processArgsLoop options args = + case args of + [] -> options + arg:args' -> + case arg of + "--help" -> options {optionsHelp = True, + optionsShowFunPad = False} + "--file" -> + case args' of + [] -> options {optionsErrorMsg = + Just "--file: missing file name"} + file:args'' -> + processArgsLoop (options {optionsSourceFile = Just file, + optionsShowFunPad = False}) + args'' + "--show" -> + case args' of + [] -> options {optionsErrorMsg = + Just "--show: missing function name"} + fname:args'' -> + processArgsLoop (options {optionsShowFunction = + Just fname, + optionsShowFunPad = False}) + args'' + "--call" -> + case args' of + [] -> options {optionsErrorMsg = + Just "--call: missing function name"} + fname:args'' -> + options {optionsCallFunction = Just fname, + optionsAdditionalArgs = args'', + optionsShowFunPad = False} + _ -> + options {optionsErrorMsg = Just ("unexpected argument: " ++ + arg)} + +helpText :: [String] +helpText = + ["Usage:", + "sifflet [--file SIFFLET-FILE] --show FUNCTION-NAME", + "sifflet [--file SIFFLET-FILE] --call FUNCTION-NAME [ARG ...]", + "sifflet --help", + "sifflet", + "where", + "1. If --file SIFFLET-FILE is given, then the function definition is", + "read from that file; otherwise, it should be one of the Sifflet", + "examples in the Function Pad.", + "2. If --show FUNCTION-NAME is used, the function is merely", + "displayed, ready to be called but not actually called.", + "3. If --call FUNCTION-NAME [ARG ...] is used, the function", + "is displayed and called (with the given arguments ARG ..., if any).", + "4. --help displays this message.", + "Any of these options suppresses the initial appearance of", + "the Function Pad, though (except with --help) it can still be", + "activated by the user."] + +showHelp :: IO () +showHelp = mapM_ putStrLn helpText + diff --git a/sifflet.cabal b/sifflet.cabal --- a/sifflet.cabal +++ b/sifflet.cabal @@ -1,5 +1,5 @@ name: sifflet -version: 1.0 +version: 1.1 cabal-version: >= 1.6 build-type: Simple license: BSD3 @@ -33,22 +33,21 @@ executable sifflet main-is: sifflet.hs + other-modules: Options build-depends: base >= 4.0 && < 4.3, - -- begin GTK stuff, should have same version numbers - cairo == 0.11.0, - glib == 0.11.0, - gtk == 0.11.0, + -- begin GTK stuff, no longer needing exactly the same version numbers + cairo == 0.11.*, + glib == 0.11.*, + gtk == 0.11.*, -- end containers >= 0.2 && < 0.4, fgl >= 5.4 && < 5.5, haskell98 >= 1.0.1 && < 1.0.2, - haskell-src >= 1.0.1 && < 1.0.2, hxt >= 8.3 && < 8.6, mtl >= 1.1 && < 1.2, process >= 1.0 && < 1.1, - -- and of course our very own ... - sifflet-lib == 1.0 + sifflet-lib >= 1.1 if !os(windows) build-depends: unix >= 2.3 && < 2.5 diff --git a/sifflet.hs b/sifflet.hs --- a/sifflet.hs +++ b/sifflet.hs @@ -1,13 +1,49 @@ module Main (main) where +import Control.Monad (when) import Data.IORef +import System.Exit +import Sifflet.Data.Functoid import Sifflet.Data.TreeLayout import Sifflet.Examples import Sifflet.Language.Expr +import Sifflet.Language.Parser import Sifflet.UI +import Sifflet.Util --- --------------------------------------------------------------------- +import Options + + +-- | Main function + +main :: IO () +main = do + { + -- scim-bridge causes many errors, so don't use it + suppressScimBridge + + -- Initialize GTK, returning args unused by Gtk itself + ; args <- initGUI + -- Process remaining command-line arguments + ; let commands = processArgs args + + -- create the user interface + ; vpui <- vpuiNew wstyle initialEnv + ; let vpui' = vpui {vpuiToolkits = defaultVPUIToolkitsWithExamples} + ; uiref <- newIORef vpui' + -- Create wome windows + ; let cbmgr = mkCBMgr uiref + ; vpui'' <- showWorkWin vpui' workspaceId cbmgr + ; writeIORef uiref vpui'' + + -- Obey command-line arguments, then let Gtk take over + ; mExitCode <- performCommands commands cbmgr uiref + ; case mExitCode of + Nothing -> mainGUI >> return () + Just code -> exitWith code + } + -- | Environment initialEnv :: Env @@ -25,29 +61,77 @@ VPToolkit "My Functions" 500 (functionToolsFromLists [[]])] in zip (map toolkitName toolkits) toolkits --- | Main function +-- | Perform the things requested in command-line arguments. +-- Return an exit code if processing should continue. -main :: IO () -main = do +performCommands :: Options -> CBMgr -> IORef VPUI -> IO (Maybe ExitCode) +performCommands options cbmgr uiref = + -- Error? + case optionsErrorMsg options of + Just msg -> + putStrLn ("sifflet: " ++ msg) >> return (Just (ExitFailure 1)) + Nothing -> + -- Help requested? + if optionsHelp options + then showHelp >> return (Just ExitSuccess) + else do + { + -- show function pad? + when (optionsShowFunPad options) + (modifyIORefIO uiref (showFunctionPadWindow cbmgr)) + + -- source a file? + -- What if no such file??? + ; case optionsSourceFile options of + Nothing -> return () + Just file -> + modifyIORefIO uiref (openFilePath cbmgr file) + + -- show or call a function? + ; case (optionsShowFunction options, + optionsCallFunction options) of + -- neither + (Nothing, Nothing) -> return Nothing + -- just show + (Just fname, Nothing) -> + showFunctionFrame fname Nothing uiref >> + return Nothing + -- call, overrides show if both are given + (_, Just fname) -> + showFunctionFrame fname + (Just (optionsAdditionalArgs options)) + uiref + } + +showFunctionFrame :: String -- ^ function name + -> Maybe [String] -- ^ Just args, to call with args + -> IORef VPUI + -> IO (Maybe ExitCode) +showFunctionFrame fname mArgStrs uiref = do { - -- scim-bridge causes many errors, so don't use it - suppressScimBridge + vpui <- readIORef uiref + ; let x = styleFramePad (vpuiStyle vpui) + y = 150 + env = vpuiGlobalEnv vpui - -- Initialize GTK - ; _ <- initGUI + showFun :: Function -> Maybe [Value] -> IO () + showFun f mArgValues = + vpuiAddFrame vpui workspaceId (FunctoidFunc f) + mArgValues CallFrame env x y 0 Nothing >>= + writeIORef uiref - -- create the user interface - ; vpui <- vpuiNew wstyle initialEnv - ; let vpui' = vpui {vpuiToolkits = defaultVPUIToolkitsWithExamples} - workId = "Sifflet Workspace" - ; uiref <- newIORef vpui' - -- Create wome windows - ; let cbmgr = mkCBMgr uiref - ; vpui'' <- showWorkWin vpui' workId cbmgr - ; writeIORef uiref vpui'' + ; case envLookup env fname of + Just (VFun f@(Function _fname argTypes _retType (Compound _ _))) -> + case mArgStrs of + Nothing -> showFun f Nothing >> return Nothing + Just argStrs -> + case parseTypedInputs2 argStrs argTypes of + Fail msg -> + putStrLn ("sifflet: " ++ msg) >> + return (Just (ExitFailure 1)) + Succ argValues -> + showFun f (Just argValues) >> return Nothing - ; showFunctionPadWindow cbmgr vpui'' >>= writeIORef uiref - -- run GTK - ; mainGUI - ; return () -} + _ -> putStrLn ("sifflet: function not found or not compound") >> + return (Just (ExitFailure 2)) + }