packages feed

tabloid 0.2 → 0.3

raw patch · 22 files changed

+1315/−1 lines, 22 files

Files

+ Component.hs view
@@ -0,0 +1,28 @@+module Component where++import Data.IORef+import Control.Applicative++-- reference management:+newtype Ref a =  Ref (IORef a)++infixr 0 .<, .<<, .>, .>>++(.>>) :: Ref (state) -> (state -> IO a) -> IO a+(.>>) (Ref c) a = readIORef c >>= a++(.<<) :: Ref (state) -> (state -> IO state) -> IO ()+(.<<) (Ref c) a = readIORef c >>= a >>= writeIORef c++(.<) :: Ref (state) -> (state -> state) -> IO ()+(.<) (Ref c) a = readIORef c >>= writeIORef c . a++(.>) :: Ref (state) -> (state -> a) -> IO a+(.>) c getter =  c .>> return . getter+    +newRef :: state -> IO (Ref (state))+newRef c = Ref <$> newIORef c ++unRef :: Ref (state) -> IO (state)+unRef (Ref c) = readIORef c+
+ DataProcController.hs view
@@ -0,0 +1,56 @@+module DataProcController where++import Graphics.UI.Gtk+import Control.Monad+import Control.Applicative++import qualified DataProcView as View+import qualified ShellCmdInputController as Shell+import qualified LineSplitterController as RxDef+import qualified TableController as Table++import qualified Data.ByteString.Lazy.Char8 as L+import SimpleRegex+ +import WindowedApp+import Component++type Controller = Ref C++view = View.mainWidget . gui++new :: IO Controller+new = do+  s <- Shell.new+  r <- RxDef.new+  t <- Table.new+  sv <- (s.>Shell.view) +  rv <- (r.>RxDef.view) +  tv <- (t.>Table.view)+  g <- View.new sv rv tv +  this <- newRef $ C g s r t RxDef.defaultFilter+  s .< Shell.onUpdate +        (Just (\lines -> this .>> showData lines))+  r .< RxDef.onUpdate +        (Just (\filt -> do+                   this .< (\stat -> stat {filterFun = filt})+                   postGUIAsync $ s .<< Shell.runText))+  return this++-- internal++showData :: L.ByteString -> C -> IO ()+showData x state = (filterFun state x) >>= Table.push (table state) ++data C = C {+      gui :: View.ViewState+    , shell :: Shell.Controller+    , rxdef :: RxDef.Controller+    , table :: Table.Controller+    , filterFun :: RxDef.Filter+    }++-- tests+test = windowedApp "DataProcController test" $ do+         t <- new  :: IO Controller+         t .> view
+ DataProcView.hs view
@@ -0,0 +1,30 @@+module DataProcView where++import Graphics.UI.Gtk+import Graphics.UI.Gtk.ModelView as MV++data ViewState = V +    {+      mainWidget :: Widget+    }++new :: Widget -> Widget -> Widget -> IO ViewState+new w1 w2 w3 = do+  vbox <- vBoxNew False 2+  vbox2 <- vBoxNew False 0++  w1ex <- expanderNew "Shell Command"+  expanderSetExpanded w1ex True+  containerAdd w1ex w1++  w2ex <- expanderNew "Splitter Regex"+  expanderSetExpanded w2ex False+  containerAdd w2ex w2++  boxPackStart vbox2 w1ex PackNatural 2+  boxPackEnd vbox2 w2ex PackNatural 2++  boxPackStart vbox vbox2 PackNatural 2+  boxPackStart vbox w3 PackGrow 2+  return (V (toWidget vbox))+
+ DataSourceView.hs view
@@ -0,0 +1,34 @@+module DataSourceView where++import Graphics.UI.Gtk+import Control.Monad+import Control.Applicative++data ViewState = V +    { mainWidget :: Widget+    , cmdModeRB :: RadioButton+    , dynamicHaskellModeRB :: RadioButton+    }++new :: Widget -> IO ViewState+new shellModeW dynHaskellModeW = do+  vbox <- vBoxNew False 2+  hbox <- vBoxNew False 2+  +  boxPackStart vbox hbox PackNatural 2+  boxPackEnd vbox rw PackGrow 2++++  linesplit `toggleButtonSetActive` False+  dis `toggleButtonSetActive` True++  boxPackStart hbox dis PackNatural 2+  boxPackStart hbox linesplit PackNatural 2+  boxPackStart hbox submatch PackNatural 2++  return $ V (toWidget vbox) dis submatch linesplit++  ++
+ FileChooser.hs view
@@ -0,0 +1,42 @@+module FileChooser +    (+     openFileDialog+    , saveFileDialog+    ) where++import Graphics.UI.Gtk++saveFileDialog:: String -> (Maybe String) -> (FilePath -> IO ()) -> IO ()+saveFileDialog title fp action = fileDialog title "gtk-save" FileChooserActionSave action fp++openFileDialog:: String -> (Maybe String) -> (FilePath -> IO ()) -> IO ()+openFileDialog title fp action = fileDialog title "gtk-open" FileChooserActionOpen action fp+++fileDialog thetitle accepttitle accepttype action filterPattern = do+  dialog <- fileChooserDialogNew+              (Just $ thetitle)+              Nothing+              accepttype+	      [("gtk-cancel"       +	       ,ResponseCancel)+	      ,(accepttitle                                  +	       , ResponseAccept)]+  case filterPattern of +    Nothing -> return ()+    Just filterPattern' ->+        do+          filt <- fileFilterNew+          fileFilterAddPattern filt filterPattern'+          set dialog [fileChooserFilter := filt]+  fileChooserSetPreviewWidgetActive dialog True+  widgetShow dialog+  response <- dialogRun dialog+  case response of +    ResponseAccept -> do +                  Just fileName <- fileChooserGetFilename dialog+                  action fileName+    ResponseCancel -> return ()+    ResponseDeleteEvent -> return ()+  widgetHide dialog+
+ LineSplitterController.hs view
@@ -0,0 +1,135 @@+module LineSplitterController +    (+     new+    , test+    , onUpdate+    , view+    , Controller+    , Filter+    , OnUpdate+    , defaultFilter+    ) where++import Graphics.UI.Gtk+import Control.Monad+import Control.Applicative+import Data.Maybe++import WindowedApp+import Component+import SimpleRegex++import qualified LineSplitterView as View+import qualified RegexDefinitionController as RxDef+import qualified Data.ByteString.Lazy.Char8 as L+import SimpleRegex++type Controller = Ref C+type Filter = L.ByteString -> IO [[L.ByteString]]+type OnUpdate = Filter -> IO ()++view = View.mainWidget . gui++new :: IO Controller+new = do+  rx <- RxDef.new+  rxv <- rx .> RxDef.view+  v@(View.V mw dis sm ls ) <- View.new rxv  +  this <- newRef (C v Nothing defaultFilter rxv Nothing)+  onToggled dis $ do+        disA <- toggleButtonGetActive dis+        unless disA $ widgetSetSensitivity rxv True+        when disA (this .<< updateState)+  rx .< RxDef.onUpdate +         (Just (\ s -> updateStateRx this s >> (this .<< updateState)))+  this .<< updateState+  return this++onUpdate :: Maybe OnUpdate -> C -> C+onUpdate u c = c { updateCB = u }++-- internal functions+defaultFilter :: Filter+defaultFilter s = do+  putStrLn "defaultFilter"+  return (map (:[])  (L.lines s))++updateStateRx :: Ref C -> Maybe (Regex,String) -> IO ()+updateStateRx this rx = do+  putStrLn $ "got new regex: " ++ maybe "Nothing" snd rx+  this .< (\c -> c {regex = rx})+  this .<< updateState++updateState :: C -> IO C+updateState state = do+  di <- toggleButtonGetActive (View.disableRB (gui state))+  sp <- toggleButtonGetActive (View.linesplitModeRB (gui state))+  sm <- toggleButtonGetActive (View.submatchModeRB (gui state))+  newFilter <- case (di, sp, sm) of+                 (_, True, _) -> do+                      postGUIAsync $ widgetSetSensitivity (regexDefView state) True+                      makeRegexFilterFieldSep state                     +                 (_, _, True) -> do+                      postGUIAsync $ widgetSetSensitivity (regexDefView state) True+                      makeRegexFilterSubMatches state+                 _ -> do+                      postGUIAsync $ widgetSetSensitivity (regexDefView state) False+                      return defaultFilter+  let newstate = (state {filterFun = newFilter})+  notifyUpdateCallback newstate+  return newstate++withMaybeRegex :: Maybe a -> (a -> Filter) -> Filter+withMaybeRegex Nothing _ = defaultFilter+withMaybeRegex (Just rx) f = f rx++makeRegexFilterSubMatches :: C -> IO Filter+makeRegexFilterSubMatches state = do+    return $ withMaybeRegex (regex state)+               (\(rx,src) indat -> do+                  putStrLn $ "makeRegexFilterSubMatches" ++ src+                  let sms = catSubmatches rx $ L.lines indat+                      res = map (\ (ss, s) -> +                                     case ss of+                                       [] -> [s]+                                       _ -> ss) sms+                  return res)++                                                         +makeRegexFilterFieldSep :: C -> IO Filter+makeRegexFilterFieldSep state =     +    return $ withMaybeRegex (regex state)+               (\(rx,src) d -> do+                  putStrLn ("makeRegexFilterFieldSep " ++ src)+                  let res = map (regexSplit rx) (L.lines d)+                  return res)++notifyUpdateCallback :: C -> IO ()+notifyUpdateCallback state = +    case updateCB state of+      Nothing -> do+          return ()+      Just updateCB' -> do       +          updateCB' (filterFun state)+                    +data C = C {+      gui :: View.ViewState+    , updateCB :: Maybe OnUpdate+    , filterFun :: Filter+    , regexDefView :: Widget+    , regex :: Maybe (Regex, String)+    }++test = windowedApp "RegexDefinitionController test" $ do+         clut <- new+         mw <- View.mainWidget <$>  (clut .> gui)+         clut .< onUpdate (Just tryNewFilter)+         return mw++testdata = L.unlines $ L.pack <$>+           [concat (map ((++ ";") . show) [x * 10 .. 9 + x * 10]) | +            x <- [1..10]]++tryNewFilter f = do+  res <- (f testdata)+  putStrLn (take 100 (show res))
+ LineSplitterView.hs view
@@ -0,0 +1,39 @@+module LineSplitterView where++import Graphics.UI.Gtk+import Control.Monad+import Control.Applicative++data ViewState = V +    {+       mainWidget :: Widget+      , disableRB :: RadioButton+      , submatchModeRB :: RadioButton+      , linesplitModeRB :: RadioButton+    }++new :: Widget -> IO ViewState+new rw = do+  vbox <- vBoxNew False 2+  hbox <- vBoxNew False 2+  +  boxPackStart vbox hbox PackNatural 2+  boxPackEnd vbox rw PackGrow 2++  dis <- radioButtonNewWithLabel "Disabled"+  linesplit <- radioButtonNewWithLabelFromWidget dis "Field Seperation"+  submatch <- radioButtonNewWithLabelFromWidget dis "Use Submatches"++  linesplit `toggleButtonSetActive` False+  submatch `toggleButtonSetActive` False+  dis `toggleButtonSetActive` True++  boxPackStart hbox dis PackNatural 2+  boxPackStart hbox linesplit PackNatural 2+  boxPackStart hbox submatch PackNatural 2++  return $ V (toWidget vbox) dis submatch linesplit++  ++
+ LoadSaveController.hs view
@@ -0,0 +1,95 @@+module LoadSaveController +    ( Controller+    , new+    , view+    , onSave+    , onLoad+    , clearLabel+    ) where++import qualified LoadSaveView as View+import qualified Data.ByteString.Lazy.Char8 as L+import Component+import Graphics.UI.Gtk+import WindowedApp+import FileChooser+import Control.Applicative+import Data.List++type Controller = Ref C+type LoadFun = L.ByteString -> IO ()+type SaveFun = IO (Maybe L.ByteString)++view :: C -> Widget+view = View.mainWidget . gui++new :: Maybe String -> IO Controller+new fnSuffix = do+  v <- View.new+  this <- newRef $ C v Nothing Nothing fnSuffix+  (View.saveB v) `onClicked` (this .>> save)+  (View.openB v) `onClicked` (this .>> load)+  return this++onSave :: Maybe SaveFun -> C -> C+onSave action state = state { onSaveCB = action }++onLoad :: Maybe LoadFun -> C -> C+onLoad action state = state { onLoadCB = action }++clearLabel :: C -> IO () +clearLabel state = labelSetText (View.statusL (gui state)) ""+    +-- internal affairs+data C = C +    { gui :: View.ViewState+    , onSaveCB :: Maybe SaveFun+    , onLoadCB :: Maybe LoadFun+    , filesuffix :: Maybe String+    }++save :: C -> IO ()+save state = saveFileDialog "Save file " (maybe Nothing (Just . (++) "*.") (filesuffix state)) $ +             do \fileName ->+                    case onSaveCB state of+                      Nothing -> +                          return ()+                      Just callback ->+                          do+                            c <- callback+                            case c of+                              Nothing -> +                                   return ()+                              Just c' ->+                                  let realfn = maybe +                                                fileName +                                                (extendFileName fileName) +                                                (filesuffix state)+                                  in do +                                    L.writeFile realfn c'+                                    postGUIAsync $ labelSetText (View.statusL $ gui state) $ realfn ++ " Saved."                                           +    where+      extendFileName fileName suffix = if isSuffixOf suffix fileName +                                         then fileName +                                         else fileName ++ "." ++ suffix++load :: C -> IO ()+load state = openFileDialog "Open file" (maybe Nothing (Just . (++) "*.") (filesuffix state)) $ +             do \fileName ->+                    case onLoadCB state of+                      Nothing -> +                          return ()+                      Just callback ->+                          do+                            c <- L.readFile fileName+                            callback c+                            postGUIAsync $ labelSetText (View.statusL $ gui state) $ fileName ++ " Loaded."+                            +{-+test = windowedApp "LoadSaveController test" $ do+         clut <- new $ Nothing+         mw <- View.mainWidget <$>  (clut .> gui)+         clut .< onLoad (Just L.putStrLn)+         clut .< onSave (Just (return (Just  (L.pack "this is a test"))))+         return mw+-}
+ LoadSaveView.hs view
@@ -0,0 +1,25 @@+module LoadSaveView where++import Graphics.UI.Gtk++data ViewState = ViewState +    {+      mainWidget :: Widget+    , statusL :: Label+    , saveB :: Button+    , openB :: Button+    }++new :: IO ViewState+new = do+  l <- labelNew Nothing+  labelSetSelectable l True+  s <- buttonNewFromStock stockSave+  o <- buttonNewFromStock stockOpen++  box <- hBoxNew False 2+  boxPackStart box o PackNatural 2+  boxPackStart box s PackNatural 2+  boxPackEnd box l PackNatural 2++  return $ ViewState (toWidget box) l s o
+ MultiWidgetContainerController.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE ExistentialQuantification #-}++module MultiWidgetContainerController+    (+     new+    , test+    , view+    , Controller+    ) where++import Graphics.UI.Gtk+import qualified MultiWidgetContainerView as View+import qualified DataProcController as DP+import Component+import WindowedApp+import Control.Applicative+import qualified Data.Map as M++type Controller = Ref C++view = View.mainWidget . gui++new :: IO Controller+new = do+  v@(View.V _ _ _ ab) <- View.new +  this <- newRef (C v M.empty)+  onClicked ab (this .<< addComponent) +  return this++removeComponent :: String -> C -> C+removeComponent name state = +  state { components = (M.delete name (components state)) }+  +addComponent :: C -> IO C+addComponent (C g cs) = do+  name <- entryGetText (View.nameE g)+  putStrLn $ "add comp " ++ name+  dpc <- DP.new+  (dpc .> DP.view) >>= View.add g name+  let cs' =  M.insert name dpc cs+  return (C g cs')++-- internal +data C = C +    { gui :: View.ViewState+    , components :: M.Map String DP.Controller+    }++test = windowedApp "RegexDefinitionController test" $ do+         clut <- new+         mw <- View.mainWidget <$>  (clut .> gui)         +         return mw
+ MultiWidgetContainerView.hs view
@@ -0,0 +1,37 @@+module MultiWidgetContainerView where++import Graphics.UI.Gtk++data ViewState = V +    { mainWidget :: Widget+    , notebook :: Notebook+    , nameE :: Entry+    , addB :: Button+    }++new :: IO ViewState+new = do+  vbox <- vBoxNew False 4+  nb <- notebookNew +  set nb [ notebookScrollable := True+         , notebookEnablePopup := True+         , notebookTabPos := PosRight +         ]+  hbox <- hBoxNew False 4  +  nameE <- entryNew+  addB <- buttonNewFromStock stockAdd++  boxPackEnd hbox addB PackNatural 2+  boxPackEnd hbox nameE PackNatural 2+  boxPackStart vbox nb PackGrow 2+  sep <- hSeparatorNew+  boxPackStart vbox sep PackNatural 2+  boxPackStart vbox hbox PackNatural 2+  return (V (toWidget vbox) nb nameE addB)++add :: ViewState -> String -> Widget -> IO ()+add vs name w = do+  putStrLn $ "appending notebook page " ++ name+  notebookAppendPage (notebook vs) w name+  widgetShowAll (notebook vs) +  return ()
+ PerformanceTuning.hs view
@@ -0,0 +1,41 @@+module Main where ++import qualified System.Process as P+import System.IO+import qualified Data.ByteString.Lazy.Char8 as L+import SimpleRegex+import Control.Concurrent++main = do+  lines <- L.readFile "testdata"+  res <- testAction lines+  putStrLn $ show res+  return ()+++interactive_test = do+  let text = "cat testdata"+  (hin, hout, _, ph) <- P.runInteractiveProcess "/bin/bash" [] Nothing  Nothing+  hPutStr hin text+  lines <- L.hGetContents hout+  res <- testAction lines+  putStrLn $ show  res+  ec <- P.waitForProcess ph +  return ()++test_rx = "([0-9]{4}-[0-9]{2}-[0-9]{2} ..:..:..),....+[[][0-9]+[]] ([^ ]+) +(incoming|outgoing) c[Aa]ll #([0-9]+)/R:(.+)/C:(.+)/L:([0-9-]+) BCH#(.+)/DCH#(.+):(.+)/BRD#(.+) .+ CRN ([0-9A-Za-z]+) @([-0-9]+) (from|local) (.+) (to|remote) (.+) [[][^ ]+ *(.*)$"++testAction c = do+  rx <- compile "(incoming)"+  return $ map (submatches rx) (L.lines c)++testAction2 c = do+--  rx <- compile "([0-9]{4}-[0-9]{2}-[0-9]{2} ..:..:..),....+[[][0-9]+[]] ([^ ]+) +(incoming|outgoing) c[Aa]ll #([0-9]+)/R:(.+)/C:(.+)/L:([0-9-]+) BCH#(.+)/DCH#(.+):(.+)/BRD#(.+) .+ CRN ([0-9A-Za-z]+) @([-0-9]+) local (.+) remote (.+) [[][^ ]+ *(.*)$"+  rx <- compile "(incoming)"+  let sms = catSubmatches rx $ L.lines c+  return $  map (\ (ss, s) -> +                     case ss of+                       [] -> [s]+                       _ -> ss) sms++
+ README view
@@ -0,0 +1,6 @@++Tabloid is a gtk program that captures output from arbitrary shell commands in tables. +Each line can be separated with regular expressions. It aims to be somewhere between a +graphical awk and excel, although less powerful than both in every respect, it will +help analyze large logfiles. It allows outputs of diffrent programs/shellscripts +to be viewed directly.
+ RegexDefinitionController.hs view
@@ -0,0 +1,95 @@+module RegexDefinitionController+    (  +     test+    , Controller+    , new+    , onUpdate+    , view+    ) where++import qualified Graphics.UI.Gtk.ModelView as MV +import qualified RegexDefinitionView as View+import qualified Data.ByteString.Lazy.Char8 as L+import SimpleRegex+import Component+import Graphics.UI.Gtk+import Data.IORef+import Data.Maybe+import Data.List+import Control.Monad+import Control.Applicative+import Control.Concurrent+import WindowedApp+import qualified LoadSaveController as LSC++type Controller = Ref C++view = View.mainWidget . gui++new =  do+  lsc <- LSC.new (Just "regex")+  lscv <- (lsc .> LSC.view)+  v <- View.new lscv+  this <- newRef $ C Nothing v Nothing+  lsc .< (LSC.onLoad (Just (\cont -> +                                (this .<< (\state -> do+                                             entrySetText (View.regexE (gui state)) (L.unpack cont)+                                             onCh state)))))++  lsc .< (LSC.onSave (Just (this .>> (\state -> +                                          Just <$> L.pack <$> (entryGetText $ View.regexE (gui state))))))+                                        +  (View.regexE v) `onEntryActivate` (this .>> onAct)+  (View.regexE v) `onEditableChanged` (do +                                        lsc .>> LSC.clearLabel+                                        this .<< onCh)+  (View.applyB v) `onClicked` (this .>> onAct)+  (View.applyB v) `widgetSetSensitivity` False+  return this++onUpdate :: Maybe ((Maybe (Regex,String)) -> IO ()) -> C -> C+onUpdate ma c = c { regexUpdateCB = ma }++-- internal main state record+data C = C+    { +      regexUpdateCB :: Maybe (Maybe (Regex, String) -> IO ())+    , gui :: View.ViewState+    , currentRegex :: Maybe (Regex, String)+    }++-- internal callbacks and functions+onAct :: C -> IO ()+onAct c = do   +  case regexUpdateCB c of+    Just uf ->  uf (currentRegex c)+    _ -> return ()++onCh :: C -> IO C+onCh c = do +  str <- entryGetText $ View.regexE (gui c)+  res <- compileWithError str+  let v = gui c+  c' <- case res of +          Right r -> +              do+                labelSetText (View.errorL (gui c)) ""+                (View.applyB v) `widgetSetSensitivity` (str /= "")+                return (c {currentRegex = Just (r, str)})+          Left err -> +              do+                labelSetText (View.errorL (gui c)) err +                (View.applyB v) `widgetSetSensitivity` False+                return (c {currentRegex = Nothing})+  return c'++-- tests+test = windowedApp "RegexDefinitionController test" $ do+         clut <- new+         clut .< onUpdate $ Just (\r ->+                                      case r of+                                        Nothing -> putStrLn "not ok"+                                        Just (_,str) -> putStrLn $ "ok" ++ str)+         mw <- View.mainWidget <$>  (clut .> gui)+         return mw+
+ RegexDefinitionView.hs view
@@ -0,0 +1,25 @@+module RegexDefinitionView where++import Graphics.UI.Gtk++data ViewState = ViewState+    {+      mainWidget :: Widget+    , regexE :: Entry+    , errorL :: Label+    , applyB :: Button+    }++new :: Widget -> IO ViewState+new openSaveW = do+  e <- entryNew +  vbox <- vBoxNew False 2+  hbox <- hBoxNew False 2+  boxPackStart vbox e PackGrow 2+  boxPackStart vbox hbox PackNatural 2+  l <- labelNew Nothing+  applyB <- buttonNewFromStock stockApply+  boxPackStart hbox openSaveW PackNatural 2+  boxPackStart hbox l PackNatural 2+  boxPackEnd hbox applyB PackNatural 2+  return (ViewState (toWidget vbox) e l applyB)
+ ShellCmdInputController.hs view
@@ -0,0 +1,111 @@+module ShellCmdInputController+    (+     Controller+     , test+     , new+     , onUpdate+     , view+     , OnUpdate+     , runText+     ) where++import qualified Graphics.UI.Gtk.ModelView as MV +import qualified ShellCmdInputView as View+import Graphics.UI.Gtk+import Control.Monad+import Control.Applicative+import Control.Concurrent+import qualified System.Process as P+import System.IO+import WindowedApp+import Component+import qualified Data.ByteString.Lazy.Char8 as L+import SimpleRegex+import Control.Concurrent.MVar+import qualified LoadSaveController as LSC++type Controller = Ref C++view = View.mainWidget . gui++new = do+  buf <- textBufferNew Nothing+  lsc <- LSC.new (Just "sh")+  lscv <- (lsc .> LSC.view)+  v@(View.V _ runB _ _ _ _) <- View.new buf lscv+  lock <- newEmptyMVar+  this <- newRef (C v "" Nothing buf lock)+  runB `onClicked` (this .<< runText)+  lsc .< (LSC.onLoad (Just (\cont -> textBufferSetText buf (L.unpack cont))))+  lsc .< (LSC.onSave (Just (Just <$> L.pack <$> getBufferText buf)))       +  onBufferChanged buf (lsc .>> LSC.clearLabel)+  return this++type OnUpdate = L.ByteString -> IO ()++onUpdate :: Maybe OnUpdate -> C -> C+onUpdate cb state = state {executeCB = cb}+-- internal functions +data C = C +    { +      gui :: View.ViewState+    , currentCmd :: String+    , executeCB :: Maybe OnUpdate+    , buffer :: TextBuffer+    , execLock :: MVar Bool+    }++getBufferText buf = do+  s <- textBufferGetStartIter buf+  e <- textBufferGetEndIter buf+  textBufferGetText buf s e True+  +runText :: C -> IO C+runText state = do+  locked <- tryPutMVar (execLock state) True+  if locked then+      case executeCB state of+        Just execCB -> +            do+              text <- getBufferText (buffer state)+              theshell <- entryGetText (View.shellE (gui state))+              forkOS $ executeCmd text execCB state (words theshell)+              return $ state+        Nothing -> +            return state+    else return state++executeCmd text execCB state (theshell:theargs) = do+  postGUISync $ widgetSetSensitivity (View.cancelB $ gui state) True+  postGUISync $ widgetSetSensitivity (View.executeB $ gui state) False+  postGUISync $ widgetSetSensitivity (View.textView $ gui state) False+  postGUISync $ labelSetText (View.exitCodeL $ gui state) $ "Executing..."+  (hin, hout, _, ph) <- P.runInteractiveProcess theshell theargs Nothing  Nothing+  postGUISync $ (View.cancelB $ gui state) `onClicked` (do+                                                         P.terminateProcess ph+                                                         return ())+  forkOS $ do+    hPutStr hin text+    lines <- L.hGetContents hout+    postGUISync $ execCB lines++  ec <- P.waitForProcess ph ++  postGUISync $ (View.cancelB $ gui state) `onClicked` (return ())+  postGUISync $ widgetSetSensitivity (View.cancelB $ gui state) False+  postGUISync $ widgetSetSensitivity (View.textView $ gui state) True+  postGUISync $ widgetSetSensitivity (View.executeB $ gui state) True+  postGUISync $ labelSetText (View.exitCodeL $ gui state) $ "Exit Code: " ++ show ec+  takeMVar (execLock state)+  return ()+                     +-- tests+test = windowedApp "ShellCmdInputController test" $ do+         t <- new  :: IO Controller+         t .< onUpdate (Just ((mapM_ putStrLn) +                              . (take 100)  +                              . lines +                              . L.unpack))+         t .> view+         +
+ ShellCmdInputView.hs view
@@ -0,0 +1,68 @@+module ShellCmdInputView where++import Graphics.UI.Gtk+import Graphics.UI.Gtk.ModelView as MV++data ViewState = V +    {+      mainWidget :: Widget+    , executeB :: Button+    , exitCodeL :: Label+    , textView :: TextView+    , cancelB :: Button+    , shellE :: Entry+    }++new buf fileButtons = do  +  cmdE <- textViewNewWithBuffer buf++  let stateTypes = [StateNormal, StateActive, StatePrelight, StateSelected, StateInsensitive]+      fgCols = [Color 65535 49152 0, Color  65535 49152 0, Color  65535 49152 0, Color  65535 49152 0]+      bgCols = [Color 255 192 0, Color 0 0 0, Color 0 0 0, Color 32535 32535 0]++  mapM_ (uncurry (widgetModifyText cmdE)) $+             stateTypes `zip` fgCols++  mapM_ (uncurry (widgetModifyBase cmdE)) $+             stateTypes `zip` bgCols++  scrollWin <- scrolledWindowNew Nothing Nothing+  set scrollWin +          [ containerBorderWidth := 5+          , scrolledWindowShadowType := ShadowIn+          , scrolledWindowVscrollbarPolicy := PolicyAutomatic+          , scrolledWindowHscrollbarPolicy  := PolicyAutomatic+          ]+  containerAdd scrollWin cmdE++  cmdBHbox <- hBoxNew False 2+  cmdRunB <- buttonNewFromStock stockExecute+  boxPackEnd cmdBHbox cmdRunB PackNatural 2+             +  cancB <- buttonNewFromStock stockCancel+  widgetSetSensitivity cancB False+  boxPackEnd cmdBHbox cancB PackNatural 2+             +  boxPackStart cmdBHbox fileButtons PackNatural 2++  exitL <- labelNew Nothing+  boxPackStart cmdBHbox exitL PackGrow 2++  shellH <- hBoxNew False 2+  shellL <- labelNew $ Just "Shell: "+  shellE <- entryNew+  entrySetText shellE "/bin/bash"+  boxPackStart shellH shellL PackNatural 2+  boxPackStart shellH shellE PackGrow 2++  centerHB <- hBoxNew False 2+  +  cmdVbox <- vBoxNew False 2+  boxPackStart cmdVbox shellH PackNatural 2+  boxPackStart cmdVbox scrollWin PackGrow 2+  boxPackStart cmdVbox cmdBHbox PackNatural 2  ++  vbox <- vBoxNew False 2+  boxPackStart vbox  cmdVbox PackGrow 2++  return $ V (toWidget vbox) cmdRunB exitL cmdE cancB shellE
+ SimpleRegex.hs view
@@ -0,0 +1,99 @@+module SimpleRegex +    (+     Regex+    , submatches+    , compile+    , compileWithError+    , ByteString    +    , regexSplit+    , catSubmatches+    ) where++import qualified Text.Regex.Posix.ByteString.Lazy as R+import Data.ByteString.Lazy.Char8 as L hiding (putStrLn, map, take, concat, zipWith)+import Data.Either+import Data.Maybe+import Text.Regex.Base.RegexLike+import Control.Monad+import System.IO.Unsafe++type Regex = R.Regex++-- very simple matching functions for lazy bytestream regexp++submatches :: Regex -> ByteString -> Maybe [ByteString]+submatches r s = let m = unsafePerformIO (R.regexec r s) in+                 case m of+    Right (Just (_,_,_,ms)) -> +        Just ms+    _ -> +        Nothing++catSubmatches ::  Regex -> [ByteString] -> [([ByteString], ByteString)]+catSubmatches r ss = let sms = map (submatches r) ss+                     in catMaybes $ zipWith (\le ri -> le >>= (\le' -> return (le', ri))) sms ss++regexSplit :: Regex -> ByteString -> [ByteString]+regexSplit  r s = +    let+      m = unsafePerformIO (R.regexec r s)+    in case m of+         Right (Just (bef,_,aft,_)) -> +            if L.length bef > 0 +             then (bef : regexSplit r aft) +             else [aft]+         _ -> +            [s]++compile :: String -> IO Regex+compile rx = do+  (Right r) <- R.compile defaultCompOpt defaultExecOpt $ pack rx+  return r++compileWithError :: String -> IO (Either String Regex)+compileWithError rx = do+  r <- R.compile defaultCompOpt defaultExecOpt $ pack rx+  return $ case r of+             (Right r') -> +                 Right r'+             (Left (rc, rs)) -> +                 Left ("Error: " ++ rs)+++-- tests+{-+test1 = do+  rx <- compile ";"+  let teststr = L.pack ";;123;3456;234;"+      res = regexSplit rx teststr+  putStrLn (show res)+     +test2 = do+  rx <- compile ";"+  let testlines = L.pack ";;123;3456;234;\na;;asd;;24;das"+      res = (map (regexSplit rx)) (L.lines testlines)+  putStrLn (show res)+     +test3 = do+  rx <- compile ";"+  let ff d = catSubmatches rx d+      res = ff (L.lines testdata)+  putStrLn (show (take 200 res))+  +test4 = do+  rx <- compile " ;"+  let ff d = map (regexSplit rx) d+      res = ff (L.lines testdata)+  putStrLn (take 200 (show res))+  +test5 = do+  rx <- compile ""+  let testlines = L.pack ";;123;3456;234;\na;;asd;;24;das"+      res = (map (regexSplit rx)) (L.lines testlines)+  putStrLn (show res)+     +testdata = L.unlines $ L.pack <$>+           [concat (map ((++ ";") . show) [x * 10 .. 9 + x * 10]) | +            x <- [1..10]]++-}
+ TableController.hs view
@@ -0,0 +1,188 @@+module TableController+    (+     Controller+    , test+    , new+    , view+    , push    +    ) where+    +import qualified Data.ByteString.Lazy.Char8 as L+import qualified Graphics.UI.Gtk.ModelView as MV +import qualified LoadSaveController as LSC+import qualified TableView as View+import Graphics.UI.Gtk+import Data.Maybe+import Data.List+import SimpleRegex+import Control.Monad+import Control.Applicative+import WindowedApp+import Component++type Controller = Ref C++type StringList = MV.ListStore [L.ByteString]++view :: C -> Widget+view = View.mainWidget . gui++new :: IO Controller+new = do+  lsc <- LSC.new (Just "jira")+  lsv <- (lsc .> LSC.view)+  l <- MV.listStoreNew [] +  v <- View.new l lsv+  lsc .< (LSC.onSave (Just (Just <$> toJira l)))+  onClicked (View.searchPB v) (searchTableBackward (View.searchE v) l (View.treeView v))+  onClicked (View.searchNB v) (searchTableForward (View.searchE v) l (View.treeView v))+  View.add_col (View.treeView v) l (L.unpack . (!! 0)) "Line" 0+  this <- newRef (C v l 1 Nothing)+  onToggled (View.groupB v) (this .<< updateGrouping)+  onValueSpinned (View.groupE v) (this .<< updateGrouping)+  return this++push this rows = +  this .<< \s -> +      case groupCol s of+        Nothing -> +           pushRaw (zipWith (:) (map (L.pack . show) [1..]) rows) s+        Just (c, _) ->+           pushRaw (zipWith (:) (map (L.pack . show) [1..]) rows) (s {groupCol = Just (c, rows)})++-- internal functions+groupRows [] _ = []+groupRows (row:rows) col = row : sameGroup ++ groupRows rest col+    where cell = row !! col+          (sameGroup, rest) = partition ((== cell) . (!! col)) rows +++updateGrouping state@(C g listM mc gCol) = +    do+      col <- spinButtonGetValueAsInt (View.groupE g)+      grouping <- toggleButtonGetActive (View.groupB g)+      if grouping then +          do+            rows <- MV.listStoreToList listM            +            case gCol of+              Nothing ->                   +                  pushRaw rows (state { groupCol = Just (col, rows)})+              Just (ccol, crows) ->+                  pushRaw crows (state { groupCol = Just (col, crows)})++          else+              case gCol of+                Nothing -> +                    return (state { groupCol = Nothing }) +                Just (ccols, crows) ->+                    pushRaw crows (state { groupCol = Nothing})+                    ++searchTableBackward entry liststore treeview = do+  selI <- getSelectedRow treeview+  rows' <- MV.listStoreToList liststore+  let rows = reverse $ zip [0..] (take selI rows')+  searchRowRange rows entry treeview++searchTableForward entry liststore treeview = do+  selI <- getSelectedRow treeview+  rows' <- MV.listStoreToList liststore+  let rows = zip [(selI + 1) ..] (drop (selI + 1) rows')+  searchRowRange rows entry  treeview++searchRowRange rows entry treeview = do+  searchTerm <- entryGetText entry+  let sI = filter (any (isInfixOf searchTerm) . (map L.unpack) . snd)  rows+  case sI of+    ((nexti, _):_) -> do+            MV.treeViewSetCursor treeview [nexti] Nothing+    _ -> +        beep++getSelectedRow treeV = do+  tsel <- MV.treeViewGetSelection treeV+  sel <-  MV.treeSelectionGetSelectedRows tsel+  return $ case sel of+             ((fst_sel:_):_) -> fst_sel+             _ -> 0++{-+toCsv :: StringList -> IO L.ByteString +toCsv liststore = do+  cont <- MV.listStoreToList liststore+  return (L.unlines (lineToCsv <$> cont))+    where+      lineToCsv :: [L.ByteString] -> L.ByteString+      lineToCsv ls = +          let els = doQuotes <$> ls+          in L.concat (intersperse (L.pack ";") els)+      doQuotes :: L.ByteString -> L.ByteString+      doQuotes cont = +          let escaped = L.foldl' (\s c -> +                                      s `L.append` +                                            (if c == '"' +                                              then L.pack ['\\', c] +                                              else L.pack [c])) +                        L.empty+                        cont+          in (L.pack "\"") `L.append` escaped `L.append` (L.pack "\"")+-}+toJira :: StringList -> IO L.ByteString +toJira liststore = do+  cont <- MV.listStoreToList liststore+  return (L.unlines (lineToCsv <$> cont))+    where+      lineToCsv :: [L.ByteString] -> L.ByteString+      lineToCsv ls = +          let els = escape <$> ls+          in (L.pack "| ") `L.append` +             L.concat (intersperse (L.pack " | ") els) `L.append` (L.pack " |")+      escape :: L.ByteString -> L.ByteString+      escape cont = L.foldl' (\s c -> +                                  s `L.append` +                                        (if c == '|' +                                          then L.pack ['\\', c] +                                          else L.pack [c])) +                    L.empty+                    cont++pushRaw :: [[L.ByteString]] -> C -> IO C+pushRaw rows c@(C g listM mc groupCol) =+    let +      addRows n [] = return n+      addRows n (r:rs) = do+        let r' = length r+        when (r' > n) $ forM_ [n .. r' - 1] +                 (\i -> +                      View.add_col (View.treeView g)+                          listM (at i) ("$" ++ show i) i)+        (MV.listStoreAppend listM) r+        addRows (max n r') rs+      at :: Int -> [L.ByteString] -> String+      at i xs +         | (length xs) <= i =  ""+         | otherwise        = L.unpack $ xs !! i+    in +      do+        (MV.listStoreClear listM)+        rowcount <- spinButtonGetValueAsInt (View.maxLines g)+        let groupedRows = maybe selRows (groupRows selRows . fst) groupCol+            selRows = (take rowcount rows)            +        cs <- addRows mc groupedRows+        spinButtonSetRange (View.groupE g) 0 (fromIntegral (cs - 1))+        return (c { cols = cs })++data C = C +    { +      gui :: View.ViewState+    , listModel :: StringList+    , cols :: Int+    , groupCol :: Maybe (Int, [[L.ByteString]])+    }+++-- tests+test = windowedApp "TableController test" $ do+         t <- new  :: IO Controller+         t `push` [[(L.pack . show) (c `rem` 3)| c <- [r .. r + 10]] | r <- [0 .. 9]]        +         t .> view
+ TableView.hs view
@@ -0,0 +1,86 @@+module TableView where++import Graphics.UI.Gtk+import Graphics.UI.Gtk.ModelView as MV+import qualified Data.ByteString.Lazy.Char8 as L++data ViewState = V +    {+      mainWidget :: Widget+    , treeView :: MV.TreeView+    , maxLines :: SpinButton+    , searchE :: Entry+    , searchPB :: Button+    , searchNB :: Button+    , groupB :: ToggleButton+    , groupE :: SpinButton+    }++new treeM loadSaveW = do+  vbox <- vBoxNew False 2+  hbox <- hBoxNew False 2+  l <- labelNew (Just "Max. Lines: ")++  sl <- labelNew (Just "Search in Table: ")+  searchE <- entryNew+  searchNB <- buttonNewFromStock stockGoDown+  searchPB <- buttonNewFromStock stockGoUp++  maxLines <- spinButtonNewWithRange 1 50000 1+  spinButtonSetValue maxLines 5000.0 ++  groupL <- labelNew (Just "Column: ")+  groupE <- spinButtonNewWithRange 0 50000 1+  spinButtonSetWrap groupE True+  spinButtonSetSnapToTicks groupE True+  spinButtonSetValue groupE 0+  groupB <- toggleButtonNewWithLabel "Group"++  v1 <- vSeparatorNew+  v2 <- vSeparatorNew+  v3 <- vSeparatorNew++  boxPackStart hbox loadSaveW PackNatural 2  +  boxPackStart hbox v1 PackNatural 2  +  boxPackStart hbox sl PackNatural 2  +  boxPackStart hbox searchE PackNatural 2  +  boxPackStart hbox searchPB PackNatural 2  +  boxPackStart hbox searchNB PackNatural 2  +  boxPackStart hbox v2 PackNatural 2  +  boxPackStart hbox groupL PackNatural 2  +  boxPackStart hbox groupE PackNatural 2  +  boxPackStart hbox groupB PackNatural 2                 +  boxPackStart hbox v3 PackNatural 2  +  boxPackEnd hbox maxLines PackNatural 2  +  boxPackEnd hbox l PackNatural 2++  treeV <- MV.treeViewNewWithModel treeM+  scrollWin <- scrolledWindowNew Nothing Nothing+  containerAdd scrollWin treeV++  boxPackStart vbox scrollWin PackGrow 2+  boxPackStart vbox hbox PackNatural 2++  set treeV [ MV.treeViewHeadersClickable := True+            , MV.treeViewHeadersVisible := True+--            , MV.treeViewEnableGridLines := MV.TreeViewGridLinesHorizontal +            , MV.treeViewReorderable := True+            , MV.treeViewRulesHint := True+            , MV.treeViewEnableSearch := True+--            , MV.treeViewRubberBanding := True+            ]+  return $ V (toWidget vbox) treeV maxLines searchE searchPB searchNB groupB groupE++add_col treeV listM row_sel title scolid = do+  strCol <- MV.treeViewColumnNew+  strColRenderer <- MV.cellRendererTextNew+  set strColRenderer [ MV.cellTextEditable := True ]+  MV.treeViewColumnPackStart strCol strColRenderer True+  MV.treeViewColumnSetSortColumnId strCol scolid  +  MV.cellLayoutPackStart strCol strColRenderer True+  MV.treeViewColumnSetResizable strCol True+  MV.cellLayoutSetAttributes strCol strColRenderer listM $ \row -> +      [MV.cellText := (row_sel row) ]+  MV.treeViewColumnSetTitle strCol title+  MV.treeViewAppendColumn treeV strCol+  return ()
+ WindowedApp.hs view
@@ -0,0 +1,22 @@+module WindowedApp +    (+     windowedApp+    ) where+    +import Graphics.UI.Gtk++windowedApp :: String -> IO Widget -> IO ()+windowedApp title action = do+  unsafeInitGUIForThreadedRTS+  window <- windowNew+  mainWidget <- action+  set window [windowDefaultWidth := 800, +              windowDefaultHeight := 600,+              containerBorderWidth := 10, +              windowTitle := title,+              containerChild := mainWidget]++  onDestroy window mainQuit+  widgetShowAll window+  mainGUI+
tabloid.cabal view
@@ -1,5 +1,5 @@ Name:	         tabloid-Version:         0.2+Version:         0.3 Description:     GUI for shell commands and log analysis Category:	 System Synopsis:	 View the output of shell commands in a table