sifflet-1.1: sifflet.hs

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
initialEnv = exampleEnv

-- | Default toolkit

defaultVPUIToolkitsWithExamples :: [(String, VPToolkit)]
defaultVPUIToolkitsWithExamples =
    let toolkits =
            -- each item has name, width, list of rows tools
            [VPToolkit "Base" 500 (functionToolsFromLists baseFunctionsRows),
             VPToolkit "Examples" 500 
                           (functionToolsFromLists [exampleFunctionNames]),
             VPToolkit "My Functions" 500 (functionToolsFromLists [[]])]
    in zip (map toolkitName toolkits) toolkits

-- | Perform the things requested in command-line arguments.
-- Return an exit code if processing should continue.

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
  {
    vpui <- readIORef uiref
  ; let x = styleFramePad (vpuiStyle vpui)
        y = 150
        env = vpuiGlobalEnv vpui

        showFun :: Function -> Maybe [Value] -> IO ()
        showFun f mArgValues = 
            vpuiAddFrame vpui workspaceId (FunctoidFunc f)
                         mArgValues CallFrame env x y 0 Nothing >>=
            writeIORef uiref

  ; 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

      _ -> putStrLn ("sifflet: function not found or not compound") >>
           return (Just (ExitFailure 2))
  }