historian-0.0.1: historian.hs

import qualified Data.Map as M
import Data.List (group, isPrefixOf, sort)
import Text.Regex
import Text.Regex.Posix
import Data.Char (isSpace)
import Control.Arrow (second)
import Control.Applicative ((<$>), liftA2)
import System.Cmd (rawSystem)
import System.FilePath ((</>))
import System.Directory (removeFile)
import System.Environment (getArgs, getEnv)

type PatternDB = M.Map String Pattern
type Pattern = String

extractPatterns :: String -> PatternDB
extractPatterns =   --M.map makeRegex
                    M.fromListWith (\x y -> x ++ '|':y) .
                    map (second (\x -> "(" ++ x ++ ")") . splitCmd . tail) .
                    filter (">" `isPrefixOf`) .
                    lines

splitCmd :: String -> (String, String)
splitCmd = second (dropWhile isSpace) . break isSpace . dropWhile isSpace

extractInteresting :: PatternDB -> [String] -> [String]
extractInteresting db = filter (not . liftA2 (||) (`inDB` db) ("#" `isPrefixOf`))

inDB :: String -> PatternDB -> Bool
cmd `inDB` db = let (prog, args) = splitCmd cmd in
                    case M.lookup prog db of
                        Just pat -> args =~ pat
                        Nothing -> False

main = do
        homeDir <- catch (getEnv "HOME") (const . return $ ".")
        editor <- catch (getEnv "EDITOR") (const . return $ "nano")
        args <- getArgs
        let fn = case args of
                    [] -> homeDir </> "interesting_history"
                    [x] -> x

        let histfile = homeDir </> ".bash_history"
        boring <- extractPatterns <$> readFile fn
        history <- readFile $ histfile
        let interesting = map head . group . sort . extractInteresting boring . lines $ history
        boring `seq` (appendFile fn . unlines . map ("> " ++) $ interesting)
        interesting `seq` writeFile histfile "# history has been rewritten\n"
        rawSystem editor [fn]