6 , multipleChecksOverIN_UI
7 , multipleChecksOverINs_UI
12 import qualified PersistentDocument as PD
22 import Text.XML.HaXml.XmlContent (XmlContent)
24 import Graphics.UI.WXCore hiding (Document)
28 import qualified Data.Map as Map
33 ------------------------------------------------------------------------------------------
34 showINErrorList :: (Show g, Show n, Show e) => [INError g n e] -> String
35 showINErrorList = unlines' . map show
37 showError :: (Show g, Show n, Show e) => Map ErrorLoc [INError g n e] -> String
38 showError = Map.foldWithKey aux ""
39 where -- aux :: ErrorLoc -> [INError g n e] -> String -> String
40 aux loc err str = '\t':show loc ++ '\n': indent 2 (showINErrorList err) ++ '\n':str
42 showError2 :: (Show g, Show n, Show e) => Map ErrorLoc (Map String (String, [INError g n e])) -> String
43 showError2 = Map.foldWithKey aux2 "" . Map.map (Map.foldWithKey aux "")
44 where -- aux :: String -> (String, [INError g n e]) -> String -> String
45 aux checkName (badMsg, err) str = checkName ++ " :\n"
46 ++ indent 1 (showINErrorList err) ++ '\n':str
48 aux2 :: ErrorLoc -> String -> String -> String
49 aux2 loc err str = '\t':show loc ++ '\n': indent 2 err ++ '\n':str
52 -- | Run the check operation over current IN system.
53 singleCheckOverIN :: (Show g, Show n, Show e) => Check g n e -> State g n e -> IO ()
54 singleCheckOverIN (checkName, _, okMsg, badMsg, func) state =
55 do w <- getNetworkFrame state
56 pDoc <- getDocument state
57 doc <- PD.getDocument pDoc
62 then infoDialog w (checkName ++ ": Passed") okMsg
63 else do logMessage $ badMsg ++ ": \n" ++ showError l
64 errorDialog w (checkName ++ ": Failed") (badMsg ++ ".\nSee report in the bottom area.")
66 -- | Run the \"valid IN\" check operation over current IN system on Save.
67 checkValidINOnSave :: (Show g, Show n, Show e) => State g n e -> IO a -> IO ()
68 checkValidINOnSave state action =
69 do w <- getNetworkFrame state
70 pDoc <- getDocument state
71 doc <- PD.getDocument pDoc
76 then ignoreResult action
77 else do logMessage $ badMsg ++ ": \n" ++ showError l
78 go <- proceedDialog w (checkName ++ ": Failed") (badMsg ++ ".\nSee report in the bottom area.\n\nDo you really want to proceed?")
79 if go then ignoreResult action else return ()
80 where (checkName, _, okMsg, badMsg, func) = iNCheck
82 -- | Run multiple check operations over current IN system.
83 multipleChecksOverIN :: (Show g, Show n, Show e) => [Check g n e] -> State g n e -> IO ()
84 multipleChecksOverIN listChecks state =
85 do w <- getNetworkFrame state
86 pDoc <- getDocument state
87 doc <- PD.getDocument pDoc
90 case runChecksOver doc listChecks of
91 (goodsStr, Nothing) ->
94 infoDialog w "All checks passed" goodsStr
95 (goodsStr, Just (badsStr,badsStrLong)) ->
98 logMessage $ goodsStr ++ badsStrLong
99 errorDialog w "Checks Failed"
100 $ goodsStr ++ badsStr
101 ++ "See report in the bottom area."
103 -- | Runs multiple checks over a document.
104 runChecksOver :: (Show g, Show n, Show e) =>
105 Document g n e -> [Check g n e] -> (String -- good checks
106 , Maybe (String -- bad checks
107 ,String -- long bag checks report
109 runChecksOver doc listChecks =
111 then (goodsStr, Nothing)
112 else (goodsStr, Just (badsStr, badsStrLong))
114 (goods, bads) = partition passed $ map (calc doc) listChecks
115 goodsStr = unlines $ map showOK goods
116 badsStr = unlines $ map showBAD bads
117 badsStrLong = showError2 $ transf bads
119 calc doc (a,_,b,c,func) = (a,b,c, func doc)
120 passed (_,_,_, r) = Map.null r
121 showOK (name,okMsg,_,_) = name ++ ": Passed\n\t" ++ okMsg
122 showBAD (name,_,badMsg,_) = name ++ ": Failed\n\t" ++ badMsg
125 -- | Change from errors by Check inner sorted by 'ErrorLoc' to errors by 'ErrorLoc', inner sorted by Check.
126 transf :: [(String, String, String, Map ErrorLoc [INError g n e])] -> Map ErrorLoc (Map String (String, [INError g n e]))
127 transf = Map.unionsWith Map.union . map aux1
128 where aux1 :: (String, String, String, Map ErrorLoc [INError g n e]) -> Map ErrorLoc (Map String (String, [INError g n e]))
129 aux1 (name,_, badMsg, mapp) = Map.map (\v -> Map.singleton name (badMsg,v)) mapp
132 multipleChecksOverIN_UI :: (Show g, Show n, Show e) => Frame () -> State g n e -> IO ()
133 multipleChecksOverIN_UI theFrame state =
135 mChecks <- chooseChecksDialog theFrame
138 Just [] -> infoDialog theFrame "Zero checks" "Zero checks chosen, so nothing to do"
139 Just ks -> multipleChecksOverIN ks state
141 chooseChecksDialog :: Frame () -> IO (Maybe [Check g n e])
142 chooseChecksDialog theFrame =
144 dialog <- dialog theFrame
145 [ text := "Choose Checks"
149 lChks <- mapM (\(name, desc,_,_,_) -> checkBox p [ text := name
155 ok <- button p [ text := "Check" ]
156 set dialog [ layout := container p $
158 column 5 [ label "Apply the following checks:"
159 , margin 10 . column 5 $ map widget lChks
160 , hfloatCentre $ widget ok
164 showModal dialog $ \stop ->
165 do set ok [ on command :=
167 sels <- filterM isSelected $ zip lChks checksList
168 stop (Just $ map snd sels)
171 isSelected = checkBoxGetValue . fst
174 multipleChecksOverINs_UI :: (InfoKind n g, InfoKind e g, XmlContent g, Show g)
175 => State g n e -> IO ()
176 multipleChecksOverINs_UI state =
178 newFrame <- frame [ text := "Multiple Checks Over Multiple INs"
181 p <- panel newFrame []
182 txt <- textCtrlRich p []
183 textCtrlSetEditable txt False
184 okB <- button p [ text := "Exit"
185 , on command := close newFrame
187 saveB <- button p [ text := "Save to file"
188 , on command := safetyNet newFrame $
190 mFile <- fileSaveDialog newFrame rememberCurrentDir False "File to save report to:" [("Any file", ["*","*.txt","*.log"])] directory filename
192 Nothing -> errorDialog newFrame "No File" "No file to write to.\n Report not saved."
193 Just file -> do str <- textCtrlGetValue txt
197 set newFrame [ layout := container p $
199 column 5 [ fill $ widget txt
200 , hfloatRight $ row 5 [widget saveB, widget okB]
204 files <- filesOpenDialog newFrame rememberCurrentDir allowReadOnly message extensions directory filename
205 mlChecks <- chooseChecksDialog newFrame
207 case (files, mlChecks) of
208 (fs, Just cs) | not (null fs) && not (null cs) -> -- useful case
210 textCtrlAppendText txt "Checking ...\n"
212 mapM_ (reportPerFile state txt cs) fs
214 x -> textCtrlAppendText txt "No files and/or no checks chosen, so nothing to do"
217 rememberCurrentDir = True
219 message = "Open " ++ toolName ++ " files"
220 directory = "examples"
223 -- | For each INblobs file add some info to the report.
224 reportPerFile :: (InfoKind n g, InfoKind e g, XmlContent g, Show g) =>
225 State g n e -> TextCtrl () -> [Check g n e] -> FilePath -> IO ()
226 reportPerFile _ txt chks fname =
228 contents <- strictReadFile fname
229 let errorOrDocument = DocumentFile.fromString contents
230 textCtrlAppendText txt $ fname ++ "\n"
231 case errorOrDocument of
232 Left err -> addError2TextCtrl txt $ err ++ "\nChecks not performed.\n"
233 Right (doc, [], False) ->
234 case runChecksOver doc chks of
235 (goodsStr, Nothing) -> addGood2TextCtrl txt "All checks passed"
236 (goodsStr, Just (badsStr,badsStrLong)) ->
238 addGood2TextCtrl txt goodsStr
239 addTxtOfColor2TextCtrl (wxcolor orange) txt badsStrLong
241 Right (doc, warnings, True) ->
242 addError2TextCtrl txt $
243 "File read warning\n"
244 ++ "The file you opened has the old " ++ toolName
245 ++ " file format which will become obsolete in newer versions of "
246 ++ toolName ++ ".\nChecks not performed.\n"
248 Right (doc, warnings, False) ->
249 addError2TextCtrl txt $
250 "Warnings while reading file:\n\n"
251 ++ unlines ( map ("* " ++) (take 10 warnings)
252 ++ if length warnings > 10 then ["..."] else []
254 ++ "\n Most likely you are reading a file that is created by a newer version of "
255 ++ toolName ++ ".\nChecks not performed.\n"
256 textCtrlAppendText txt $ '\n': replicate 20 '#' ++ "\n\n"