[exception handling, prettier printing, timing, some options(colWidth, dumpDir, dumpLog)
martin.hofmann@uni-bamberg.de**20090421101722] hunk ./src/UI/UIStarter.hs 4
-import Text.ParserCombinators.Parsec hiding (space)
+import Text.ParserCombinators.Parsec hiding (space, char)
hunk ./src/UI/UIStarter.hs 9
-import System.Directory (doesFileExist)
+import System.Directory (doesFileExist, doesDirectoryExist)
hunk ./src/UI/UIStarter.hs 15
+import System.Time
hunk ./src/UI/UIStarter.hs 25
-
+import Time 
hunk ./src/UI/UIStarter.hs 27
-version = "v0.5.2"
+version = "v0.5.3"
hunk ./src/UI/UIStarter.hs 32
+displayWidth = 80
hunk ./src/UI/UIStarter.hs 34
+displayStatic x = displayS (renderPretty 0.95 displayWidth x) ""
+render s x = renderPretty 0.95 (fromInteger.colWidth $ s) x
+display d = displayS d ""
+ 
hunk ./src/UI/UIStarter.hs 53
-    { verbose :: Bool
-    , debug :: Bool
+    { verbose  :: Bool
+    , debug    :: Bool
+    , dumpLog  :: Bool
+    , dumpDir  :: String
hunk ./src/UI/UIStarter.hs 58
-    , context :: !ModuleCtx
+    , colWidth :: Integer
+    , context  :: !ModuleCtx
hunk ./src/UI/UIStarter.hs 66
-    , debug     = True
+    , debug     = False
+    , dumpLog   = False
+    , dumpDir   = "log/"
hunk ./src/UI/UIStarter.hs 70
+    , colWidth  = 80
hunk ./src/UI/UIStarter.hs 115
-runCmd s Noop = return (False, s)
-runCmd s Quit = return (True, s)
-runCmd s (Help verbose) = do
-    putStrLn $ helpText ++ unlines (map getHelp commands)
-    when verbose $ putStr verboseHelp
-    return (False, s)
-runCmd s (Set f) = return (False, f s) 
-runCmd s Info = putStrLn (getSettings s) >> return (False,s)
-runCmd s (Batch path) = loadBatch s path
-runCmd s (Load path)  =  loadFile s path
+runCmd s Noop                   = return (False, s)
+runCmd s Quit                   = return (True, s)
+runCmd s (Help verbose)         = printHelp s verbose
+runCmd s (Set f)                = return (False, f s) 
+runCmd s Info                   = displayIO stdout ((render s) $ getSettings s) >> return (False,s)
+runCmd s (Batch path)           = loadBatch s path
+runCmd s (Load path)            =  loadFile s path
hunk ./src/UI/UIStarter.hs 123
-runCmd s Reset  = return (False, s{context=defaultContext})
-runCmd s (Yell st) = putStrLn st >> return (False,s)
+runCmd s Reset                  = return (False, s{context=defaultContext})
+runCmd s (Yell st)              = putStrLn st >> return (False,s)
hunk ./src/UI/UIStarter.hs 150
-helpText :: String
-helpText = "\
-\\n\
-\Commands (may be abbreviated):\n\
-\"
+printHelp :: EnvState -> Bool -> IO (Bool, EnvState)
+printHelp s verbose = do
+    displayIO stdout $ render s $ helpText 
+    when verbose $ putStr verboseHelp
+    return (False, s)
+    
+helpText :: Doc
+helpText = linebreak <> text "Commands (may be abbreviated):" <> 
+           linebreak <> vcat (map getHelp commands) <> linebreak
hunk ./src/UI/UIStarter.hs 168
-getSettings :: EnvState -> String
-getSettings s = show $ 
-    text  "Current settings" <$>
-    (indent 2 $ 
-                vcat [ fill 25 ((fill 15 (text name) <> text " = ") <> text (show (getter s))) <> text descr |
-                    (name,descr,getter,_setter) <- flags] <$>
---                vcat [ fill 25 (text $ (if getter s then "+" else "-") ++ name) <> text descr|
---                    (name, descr, getter, _setter) <- flags ] <$>
-                vcat [ fill 25 ((fill 15 (text name) <> text " = ") <> text (show (getter s))) <> text descr |
-                    (name,descr,getter,_setter) <- options] <$>
-                if verbose s then  pretty (context s) else text "" ) 
hunk ./src/UI/UIStarter.hs 175
-      else cancel s path
+      else cancel s path "File not found!"
+   
+-- strips comments '--' until the end of line '\n'
+stripComments :: String -> String
+stripComments "" = ""
+stripComments ('-':'-':cs) = skip cs
+  where skip "" = ""
+        skip s@('\n':_) = stripComments s
+        skip (_:s) = skip s
+stripComments (c:cs) = c : stripComments cs       
+    
+      
hunk ./src/UI/UIStarter.hs 196
-                 else cancel s path
-      else cancel s path
+                 else cancel s path "Failed to type check!"
+      else cancel s path "File not found!"
hunk ./src/UI/UIStarter.hs 199
-cancel s path = do putStrLn ("Failed to load file: " ++ path ++ 
-                             "! File not found!")
-                   return (False,s)       
+cancel s path str = do 
+    putStrLn ("\nFailed to load file: " ++ path ++ "!\n" ++ str)
+    return (False,s)       
hunk ./src/UI/UIStarter.hs 209
-           printResult $ startSynthesis ts bs
-           return (False, s)
-    
--- strips comments '--' until the end of line '\n'
-stripComments :: String -> String
-stripComments "" = ""
-stripComments ('-':'-':cs) = skip cs
-  where skip "" = ""
-        skip s@('\n':_) = stripComments s
-        skip (_:s) = skip s
-stripComments (c:cs) = c : stripComments cs       
-
-
+            start  <- getClockTime
+            res <- return $  startSynthesis ts bs
+            end    <- getClockTime
+            printResult s (diffClockTimes end start) res
+            return (False, s)
hunk ./src/UI/UIStarter.hs 225
-printResult :: (Either String [[Dec]],Log) -> IO()
-printResult (r,l) = do 
-    file    <- showDate >>= \d -> return ("log/" ++ d ++ ".log")
+printResult :: EnvState -> TimeDiff -> (Either String [[Dec]],Log) -> IO()
+printResult s t (r,l) = do 
+    let w = (fromInteger.colWidth $ s)
+    let doc = logToDoc w l
+    let elt = text "elapsed time: " <> pretty t <$$> linebreak
+    res <- resToDoc w r
+    when (debug s) $ hPutDoc stdout doc
+    hPutDoc stdout $ linebreak <> res <$> elt
+    printToFile s $ doc <$$> res <$$> elt
+
+printToFile :: EnvState -> Doc -> IO ()
+printToFile s d = do
+    exist <- doesDirectoryExist (dumpDir s)
+    when (not $ dumpLog s) $ return ()
+    when (not exist) $ putStrLn ("Log not dumped! Directory not found: " ++ (dumpDir s)) >> return()
+    date    <- showDate
+    file    <- return ((dumpDir s) ++ "/" ++ date ++ ".log")
hunk ./src/UI/UIStarter.hs 243
-    printLog l  [fhandle,stdout]
-    case r of
-        Left  e -> mapM_ ((flip hPutStr)  ("UNCAUGHT ERROR: " ++ e)) [fhandle,stdout]
-        Right r -> printDecs r [fhandle,stdout]
+    hPutDoc fhandle d
hunk ./src/UI/UIStarter.hs 245
-    
-                
-printLog :: Log -> [Handle] -> IO ()
-printLog logs handles =  mapM_ (flip hPutDoc content) handles
-    where    
-    content = frame "Log Log Log Log Log Log Log" <$> pretty logs
+              
+logToDoc :: Int -> Log -> Doc
+logToDoc w l = frame w "Log  Log  Log  Log  Log  Log" <$> pretty l
hunk ./src/UI/UIStarter.hs 249
-printDecs :: [[Dec]] -> [Handle] -> IO()
-printDecs decs handles = do
-    let hyponum = length decs
-    docs <- liftM vcat $ mapM (printInQ  hyponum) (zip decs [1..])
-    let content = frame "Results Results Results" <$$> docs
-    mapM_ ((flip hPutDoc) content) handles
+resToDoc :: Int -> Either String [[Dec]] -> IO Doc
+resToDoc w (Left msg) = return . text $ "UNCAUGHT ERROR: " ++ msg
+resToDoc w (Right ds) = do
+    let hyponum = length ds
+    docs <- liftM vcat $ mapM (printInQ  hyponum) (zip ds [1..])
+    return $ frame w "Results  Results  Results  Results" <$$> docs
hunk ./src/UI/UIStarter.hs 258
-                return $ indent 6 (text "- - - - - HYPOTHESE" <+> int i <+> 
+                return $ linebreak <> 
+                         indent 6 (text "- - - - - HYPOTHESE" <+> int i <+> 
hunk ./src/UI/UIStarter.hs 262
-                         vcat (map pretty p) <>
+                         vcat (map pretty p) <$$>
hunk ./src/UI/UIStarter.hs 265
-frame s = vsep [line,header s,line,softline]
+frame w s = vsep [line,header s,line,softline]
hunk ./src/UI/UIStarter.hs 267
-    line     = (text "*") <+>
-               hsep (replicate (colwidth -2) (text "-")) <+>
-               text  "*"
-    spaces   = ((colwidth) - (length s)) `div` 2 
-    colwidth =  72
-    header s = (text "|") <+> hsep (replicate spaces space) <+>
-               text s <+> hsep (replicate spaces space) <+> (text "|")    
-
-
+    line     = text "*" <> filler w '-' 2 <> text  "*"
+    header s = text "|" <> center w s 2 <> text "|"    
hunk ./src/UI/UIStarter.hs 270
+textLine w str offset = filler w '-' (length str + 1 + offset) <+> text str
+filler w c offset = hcat (replicate (w - offset) (char c))
+center w str offset = spaces <> text str <> spaces
+    where
+    spaces = hcat $ replicate ((w - (length str) - offset) `div` 2) space 
hunk ./src/UI/UIStarter.hs 297
-    [ (":help",                         "Print this message.",          return (Help False))
-    , (":verboseHelp",                  "Print verbose help.",          return (Help True))
+    [ (":help",                         "Show this help.",          return (Help False))
+    , (":verboseHelp",                  "Show verbose help.",          return (Help True))
hunk ./src/UI/UIStarter.hs 314
-getHelp :: (String, String, a) -> String
-getHelp (cmd, help, _) = cmd ++ replicate (35 - length cmd) ' ' ++ help
+getHelp :: (String, String, a) -> Doc
+getHelp (cmd, help, _) =
+    hang 35 $ (fill 35 (text cmd)) <> fillSep (map text (words help))
hunk ./src/UI/UIStarter.hs 322
+    , ("dumpLog",           "dump log to file",             dumpLog, \ v s -> s { dumpLog  = v })
hunk ./src/UI/UIStarter.hs 325
-options :: [(String, String, EnvState->Integer, Integer->EnvState->EnvState)]
-options = 
+intOptions :: [(String, String, EnvState->Integer, Integer->EnvState->EnvState)]
+intOptions = 
hunk ./src/UI/UIStarter.hs 328
+    , ("colWidth",          "set the column width of your display",  colWidth,  \ v s -> s { colWidth = v})
hunk ./src/UI/UIStarter.hs 330
-           
+   
+strOptions :: [(String, String, EnvState->String, String->EnvState->EnvState)]
+strOptions = 
+    [ ("dumpDir",          "directory of log files",  dumpDir,  \ v s -> s { dumpDir = v})
+    ]          
+
hunk ./src/UI/UIStarter.hs 337
+getSettings :: EnvState -> Doc
+getSettings s =  
+    linebreak <> 
+    center w "Current settings" 0 <$>
+    textLine w "Flags" 0 <$> showEntries flags  <$>
+    textLine w "Options" 0  <$> showEntries intOptions
+                            <$> showEntries strOptions <$>
+    if verbose s then  pretty (context s) else text ""  <> linebreak
+    where
+    w = (fromInteger.colWidth $ s)
+    showEntry name value descr = 
+        fill 25 ((fill 15 (text name) <> text " = ") <> 
+                        text (show value)) <> 
+                      text descr 
+    showEntries entries = 
+        indent 2 $ vcat [ showEntry name (getter s) descr |
+                         (name,descr,getter,_setter) <- entries]
hunk ./src/UI/UIStarter.hs 364
-                             [ o | (o,_,_,_) <-  options]
+                             [ o | (o,_,_,_) <-  intOptions]++
+                             [ o | (o,_,_,_) <-  strOptions]
hunk ./src/UI/UIStarter.hs 405
-pSet =  do cmds <-  many1 (choice [pFlag, pOption])
+pSet =  do cmds <-  many1 (choice [pFlag, pIntOption, pStrOption])
hunk ./src/UI/UIStarter.hs 421
-pOption :: Parser Cmd
-pOption = do{ f <- choice [do{reserved o; return s} | (o,_,_,s) <- options]
+pIntOption :: Parser Cmd
+pIntOption = do{ f <- choice [do{reserved o; return s} | (o,_,_,s) <- intOptions]
hunk ./src/UI/UIStarter.hs 428
+          
+pStrOption :: Parser Cmd
+pStrOption = do{ f <- choice [do{reserved o; return s} | (o,_,_,s) <- strOptions]
+            ; reservedOp "="
+            ; i <- stringLiteral
+            ; return $ Set (f i)
+            }
+   <?> "<option>=<value>"