INblobs-0.1.1: src/INChecksUI.hs

module INChecksUI
    ( checksList
    , iNCheck
    , singleCheckOverIN
    , checkValidINOnSave
    , multipleChecksOverIN_UI
    , multipleChecksOverINs_UI
    ) where

import INChecks
import State
import qualified PersistentDocument as PD
import Common
import Constants
import Document
import SafetyNet
import DocumentFile
import CommonIO
import InfoKind
import CommonUI

import Text.XML.HaXml.XmlContent (XmlContent)

import Graphics.UI.WXCore hiding (Document)
import Graphics.UI.WX

import Data.Map (Map)
import qualified Data.Map as Map
import Data.List
import Control.Monad


------------------------------------------------------------------------------------------
showINErrorList :: (Show g, Show n, Show e) => [INError g n e] -> String
showINErrorList = unlines' . map show

showError :: (Show g, Show n, Show e) => Map ErrorLoc [INError g n e] -> String
showError = Map.foldWithKey aux ""
     where -- aux :: ErrorLoc -> [INError g n e] -> String -> String
           aux loc err str = '\t':show loc ++ '\n': indent 2 (showINErrorList err) ++ '\n':str

showError2 :: (Show g, Show n, Show e) => Map ErrorLoc (Map String (String, [INError g n e])) -> String
showError2 = Map.foldWithKey aux2 "" . Map.map (Map.foldWithKey aux "")
     where -- aux :: String -> (String, [INError g n e]) -> String -> String
           aux checkName (badMsg, err) str = checkName ++ " :\n"
						++ indent 1 (showINErrorList err) ++ '\n':str

	   aux2 :: ErrorLoc -> String -> String -> String
	   aux2 loc err str = '\t':show loc ++ '\n': indent 2 err ++ '\n':str


-- | Run the check operation over current IN system.
singleCheckOverIN :: (Show g, Show n, Show e) => Check g n e -> State g n e -> IO ()
singleCheckOverIN (checkName, _, okMsg, badMsg, func) state =
     do w <- getNetworkFrame state
        pDoc <- getDocument state
        doc <- PD.getDocument pDoc
	wxcBeginBusyCursor
        let l = func doc
	wxcEndBusyCursor
        if Map.null l
           then infoDialog w (checkName ++ ": Passed") okMsg
           else do logMessage $ badMsg ++ ": \n" ++ showError l
                   errorDialog w (checkName ++ ": Failed") (badMsg ++ ".\nSee report in the bottom area.")

-- | Run the \"valid IN\" check operation over current IN system on Save.
checkValidINOnSave :: (Show g, Show n, Show e) => State g n e -> IO a -> IO ()
checkValidINOnSave state action =
     do w <- getNetworkFrame state
        pDoc <- getDocument state
        doc <- PD.getDocument pDoc
	wxcBeginBusyCursor
        let l = func doc
	wxcEndBusyCursor
        if Map.null l
           then ignoreResult action
           else do logMessage $ badMsg ++ ": \n" ++ showError l
                   go <- proceedDialog w (checkName ++ ": Failed") (badMsg ++ ".\nSee report in the bottom area.\n\nDo you really want to proceed?")
		   if go then ignoreResult action else return ()
    where (checkName, _, okMsg, badMsg, func) = iNCheck

-- | Run multiple check operations over current IN system.
multipleChecksOverIN :: (Show g, Show n, Show e) => [Check g n e] -> State g n e -> IO ()
multipleChecksOverIN listChecks state =
     do w <- getNetworkFrame state
        pDoc <- getDocument state
        doc <- PD.getDocument pDoc
	wxcBeginBusyCursor

	case runChecksOver doc listChecks of
	   (goodsStr, Nothing) ->
	     do
		wxcEndBusyCursor
		infoDialog w "All checks passed" goodsStr
	   (goodsStr, Just (badsStr,badsStrLong)) ->
		do
		   wxcEndBusyCursor
                   logMessage $ goodsStr ++ badsStrLong
                   errorDialog w "Checks Failed"
                           $ goodsStr ++ badsStr
                             ++ "See report in the bottom area."

-- | Runs multiple checks over a document.
runChecksOver :: (Show g, Show n, Show e) =>
		Document g n e -> [Check g n e] -> (String -- good checks
						    , Maybe (String -- bad checks
							    ,String -- long bag checks report
						    ))
runChecksOver doc listChecks =
	if null bads
	then (goodsStr, Nothing)
	else (goodsStr, Just (badsStr, badsStrLong))
	where
		(goods, bads) = partition passed $ map (calc doc) listChecks
		goodsStr = unlines $ map showOK goods
		badsStr = unlines $ map showBAD bads
		badsStrLong = showError2 $ transf bads

		calc doc (a,_,b,c,func) = (a,b,c, func doc)
		passed (_,_,_, r) = Map.null r
            	showOK  (name,okMsg,_,_)  = name ++ ": Passed\n\t" ++ okMsg
            	showBAD (name,_,badMsg,_) = name ++ ": Failed\n\t" ++ badMsg


-- | Change from errors by Check inner sorted by 'ErrorLoc' to errors by 'ErrorLoc', inner sorted by Check.
transf :: [(String, String, String, Map ErrorLoc [INError g n e])] -> Map ErrorLoc (Map String (String, [INError g n e]))
transf = Map.unionsWith Map.union . map aux1
      where aux1 :: (String, String, String, Map ErrorLoc [INError g n e]) -> Map ErrorLoc (Map String (String, [INError g n e]))
            aux1 (name,_, badMsg, mapp) = Map.map (\v -> Map.singleton name (badMsg,v)) mapp


multipleChecksOverIN_UI :: (Show g, Show n, Show e) => Frame () -> State g n e -> IO ()
multipleChecksOverIN_UI theFrame state =
     do
	mChecks <- chooseChecksDialog theFrame
	case mChecks of
	   Nothing -> return ()
	   Just [] -> infoDialog theFrame "Zero checks" "Zero checks chosen, so nothing to do"
	   Just ks -> multipleChecksOverIN ks state

chooseChecksDialog :: Frame () -> IO (Maybe [Check g n e])
chooseChecksDialog theFrame =
     do
	dialog <- dialog theFrame
                    [ text := "Choose Checks"
                    ]
	p  <- panel dialog []

	lChks <- mapM (\(name, desc,_,_,_) -> checkBox p [ text := name
							 , checked := False
							 , tooltip := desc
							 ]
		      ) checksList

	ok <- button p [ text := "Check" ]
	set dialog [ layout := container p $
				margin 10 $
				  column 5 [ label "Apply the following checks:"
					   , margin 10 . column 5 $ map widget lChks
					   , hfloatCentre $ widget ok
					   ]
		   ]

	showModal dialog $ \stop ->
                do set ok [ on command :=
				     do
					sels <- filterM isSelected $ zip lChks checksList
					stop (Just $ map snd sels)
			  ]

isSelected = checkBoxGetValue . fst
fst5 (a,_,_,_,_) = a

multipleChecksOverINs_UI :: (InfoKind n g, InfoKind e g, XmlContent g, Show g)
	=> State g n e -> IO ()
multipleChecksOverINs_UI state =
     do
	newFrame <- frame [ text := "Multiple Checks Over Multiple INs"
			  , size := sz 900 600
			  ]
	p <- panel newFrame []
	txt <- textCtrlRich p []
	textCtrlSetEditable txt False
	okB <- button p [ text := "Exit"
		        , on command := close newFrame
		        ]
	saveB <- button p [ text := "Save to file"
			  , on command := safetyNet newFrame $
					     do
						mFile <- fileSaveDialog newFrame rememberCurrentDir False "File to save report to:" [("Any file", ["*","*.txt","*.log"])] directory filename
						case mFile of
						  Nothing -> errorDialog newFrame "No File" "No file to write to.\n Report not saved."
						  Just file -> do str <- textCtrlGetValue txt
								  writeFile file str

			  ]
	set newFrame [ layout := container p $
				   margin 10 $
				     column 5 [ fill $ widget txt
					      , hfloatRight $ row 5 [widget saveB, widget okB]
					      ]
		     ]

	files <- filesOpenDialog newFrame rememberCurrentDir allowReadOnly message extensions directory filename
	mlChecks <- chooseChecksDialog newFrame

	case (files, mlChecks) of
	   (fs, Just cs) | not (null fs) && not (null cs) -> -- useful case
	     do
		textCtrlAppendText txt "Checking ...\n"
		wxcBeginBusyCursor
		mapM_ (reportPerFile state txt cs) fs
		wxcEndBusyCursor
	   x -> textCtrlAppendText txt "No files and/or no checks chosen, so nothing to do"

     where
	rememberCurrentDir = True
	allowReadOnly = True
	message = "Open " ++ toolName ++ " files"
	directory = "examples"
	filename = ""

-- | For each INblobs file add some info to the report.
reportPerFile :: (InfoKind n g, InfoKind e g, XmlContent g, Show g) =>
	State g n e -> TextCtrl () -> [Check g n e] -> FilePath -> IO ()
reportPerFile _ txt chks fname =
     do
	contents <- strictReadFile fname
	let errorOrDocument = DocumentFile.fromString contents
	textCtrlAppendText txt $ fname ++ "\n"
	case errorOrDocument of
	   Left err -> addError2TextCtrl txt $ err ++ "\nChecks not performed.\n"
	   Right (doc, [], False) ->
		case runChecksOver doc chks of
	  	   (goodsStr, Nothing) -> addGood2TextCtrl txt "All checks passed"
	           (goodsStr, Just (badsStr,badsStrLong)) ->
		     do
			addGood2TextCtrl txt goodsStr
			addTxtOfColor2TextCtrl (wxcolor orange) txt badsStrLong

	   Right (doc, warnings, True) ->
		addError2TextCtrl txt $
			"File read warning\n"
			++ "The file you opened has the old " ++ toolName
			++ " file format which will become obsolete in newer versions of "
			++ toolName ++ ".\nChecks not performed.\n"

	   Right (doc, warnings, False) ->
		addError2TextCtrl txt $
		    "Warnings while reading file:\n\n"
                    ++ unlines (  map ("* " ++) (take 10 warnings)
                               ++ if length warnings > 10 then ["..."] else []
                               )
                    ++ "\n Most likely you are reading a file that is created by a newer version of "
                    ++ toolName ++ ".\nChecks not performed.\n"
	textCtrlAppendText txt $ '\n': replicate 20 '#' ++ "\n\n"