UI.hs

{-|
    Module      :  Functional.UI
    Copyright   :  (c) Miguel Vilaça and Daniel Mendes 2007

    Maintainer  :  jmvilaca@di.uminho.pt and danielgomesmendes@gmail.com
    Stability   :  experimental
    Portability :  portable


    Small Functional Language: Graphical stuff for integration in INblobs.

-}
module Functional.UI
	( compileUI
	) where

import State
import StateUtil
import qualified PersistentDocument as PD
import Common
import CommonIO
import CommonUI
import InfoKind
import Text.XML.HaXml.XmlContent (XmlContent)

import Graphics.UI.WX
import Graphics.UI.WXCore

import Functional.Language
import Functional.Parser
import Functional.Compiler

import Data.List
import Data.Char
import qualified Control.Exception as E


-- | List of strategies for which compilation is available.
listCallBy :: [CallBy]
listCallBy = [ Name, Value ]

-- | GUI for compilation of BNL to INs.
compileUI :: (InfoKind n g, InfoKind e g, XmlContent g) => State g n e -> g -> n -> e -> IO ()
compileUI state g n e =
   closeDocAndThen state $
     do
	theFrame <- getNetworkFrame state

	res <- parseDialog theFrame
	case res of
	  Nothing -> return ()
	  Just (term, callBy)
	   |not . null $ freeVars term ->
		errorDialog theFrame "Free variables"
		 $ "Only closed terms are allowed and this one have the following free vars:\n" ++ commasAnd (freeVars term)
	  Just (term, callBy) ->
	     do
		let iterSymbs = listIteratorSymbols term
		names <- if null iterSymbs
			   then return (Just [])
			   else meaningfulNamesDialog iterSymbs theFrame
		case names of
		  Nothing -> return ()
		  Just names ->
		   flip E.catch (\exception ->
			     do
				logMessage "END COMPILATION BADLY"
				wxcEndBusyCursor
				errorDialog theFrame "Compilation failed..." (show exception)
				) $
		     do
			-- loadDocument
			let fname = "examples/New-Token-Passing/CallBy"
					++ show callBy ++
					"ForClosedTerms+BNL-Iterators.INblobs"
			openNetworkFile fname state (Just theFrame)
			pDoc <- getDocument state
			doc  <- PD.getDocument pDoc
			wxcBeginBusyCursor
			logMessage "COMPILING..."
			doc2 <- compile g n e callBy term names doc
			logMessage "END COMPILATION SUCCESSFULLY"
			wxcEndBusyCursor
			let fname2 = "examples/New-Token-Passing/GENERATED-CallBy"
					++ show callBy ++
					"ForClosedTerms+BNL-Iterators.INblobs"
			PD.resetDocument (Just fname2) doc2 pDoc

			-- Redraw
			applyCanvasSize state
			buildVisiblePalette state
			reAddRules2Tree state
			repaintAll state

-- | Deal with collecting a term from the user.
-- Graphical treatment of parsing errors is done here.
parseDialog :: Frame () -> IO (Maybe (FuncLang,CallBy))
parseDialog theFrame =
     do
	dial <- dialog theFrame [text := "Functional term to IN system", position := pt 200 20]
	p <- panel dial []
	termbox <- textCtrlRich p [text := ""]
	help <- button p
		[ text :=  "Help"
		, on command := infoDialog dial "Help" helpString
		]

	okB <- button p [ text := "Ok" ]
	canB <- button p [ text := "Cancel" ]

	-- one button per functional language constructor
	listBs <- mapM (\(name,term) -> button p
					[ text := name
					, on command := addTxtInPlace2TextCtrl termbox $ show term
					])
			listLangConstructors

	-- CallByX
	when (null listCallBy) (error "No strategies available.")
	callByUI <- radioBox p Vertical (map show listCallBy)
                      [ text := "Which evaluation strategy?"
                      , selection := 0
		      ]

	errorsUI <- textCtrl p [ visible := False ]

	set dial [ layout := container p $
	                         margin 10 $
	                            column 5 [ label "Input your term:"
	                                     , row 2 [ hfill $ widget termbox
						     , column 10 (map widget listBs)
						     ]
					     , widget callByUI
					     , minsize (sz 30 30) . fill $ widget errorsUI
					     , widget help
					     , hrule 350
	                                     , floatRight $ row 5 [widget okB, widget canB]
	                                     ]
	          ]

	showModal dial $ \stop ->
	   do
		set canB [on command := stop Nothing]
		set okB [on command :=
			     do
				set errorsUI [ visible := False, text := ""]
				txt <- get termbox text
				i <- get callByUI selection

				case parse txt of
				  Left term -> stop $ Just (term, listCallBy !! i)
				  Right errMsg ->
				     do
					set errorsUI [ visible := True
						     , text := "Parse error:\n" ++ errMsg
						     ]
					errorDialog theFrame "Parsing Error" "Parsing error.\nSee report."
			]

     where helpString = "Use the buttons on the right side to create a term or write it if already familiar with the syntax."

-- | Allow the user to supply more meaningful names for symbols that correspond to iterators with internalized arguments.
-- Checks if:
--   * given names don't contain blank or control characters
--   * given names are disjoint
meaningfulNamesDialog :: [FuncLang] -> Frame () -> IO (Maybe [(FuncLang, String)])
meaningfulNamesDialog terms theFrame =
     do
	dial <- dialog theFrame [text := "Meaningful names"
				, position := pt 200 20
				, resizeable := True
				]
	p <- panel dial []

	listG <- listCtrl p [ columns := [ ("Symbol name", AlignRight, -1)
					 , ("Term", AlignLeft, 200)
					 ]
                            , items := [[name, showAgent term] | (term, name) <- giveNames terms]
			    , style :~ (wxLC_EDIT_LABELS .+. wxLC_VRULES .+.)
			    ]

	okB <- button p [ text := "Ok" ]
	canB <- button p [ text := "Cancel" ]

	errorsUI <- textCtrl p [ visible := False ]

	set dial [ layout := container p $
	                         margin 10 $
	                            column 5 [ label "Edit the \"Symbol name\" column to give more meaningful names."
					     , fill $ widget listG
					     , fill $ widget errorsUI
					     , hrule 350
	                                     , floatRight $ row 5 [widget okB, widget canB]
	                                     ]
	          ]

	showModal dial $ \stop ->
	   do set okB  [ on command :=
			     do
				newNames <- get listG items
				let mapp = zip terms (map head newNames)
				    -- Check that given names are good names.
				    badNames = filter (badName . snd) mapp
				    -- Check that given names are disjoint.
				    equalNames = filter ((> 1) . length)
						   $ groupBy (\(_,a) (_,b) -> a == b) mapp
				case (null badNames, null equalNames) of
				  (True, True) -> stop $ Just mapp
				  (False, _) -> -- some bad names
					set errorsUI [ visible := True
						     , text := "The symbol's name(s) for the following term(s) contain invalid (control or blank) characters:\n"
								++ (indent 1 . unlines) (map (showAgent . fst) badNames)
						     ]
				  (True, False) ->  -- repeated names
					set errorsUI [ visible := True
						     , text := "The following terms have the same name(s):\n "
								++ beautify equalNames
						     ]
		       ]
	      set canB [on command := stop Nothing]
  where
	beautify :: [[(FuncLang,String)]] -> String
	beautify = unlines . map (\l -> snd (head l) ++ "\n"
				    ++ indent 1 (unlines $ map (showAgent.fst) l))
	badName = any (\c -> isSpace c || isControl c)