Xec-0.1.6: Main.hs

module Main where
import Control.Concurrent
import Control.Monad
import Control.Monad.Trans
import Data.Binary hiding(get)
import qualified Data.Binary as B
import qualified Data.ByteString.Lazy as BS
import Data.Char
import Data.Digest.Pure.SHA
import Data.IORef
import Data.List
import Data.Maybe
import Data.Monoid
import Data.Map (Map)
import qualified Data.Map as M
import Data.Ord
import Data.Word
import Graphics.Rendering.Cairo
import Graphics.UI.Gtk
import Graphics.UI.Gtk.Gdk.Events
import System.Directory
import System.Environment
import System.Posix.Process
import System.Time
import System.FilePath.Posix

import Identicon
import Debug.Trace


-- this is a command launcher intented to be used with xmonad.
-- nice replacement for gnome-panel when used with xmobar.
-- Don't do too much things. Shells/scripting languages are there for complex things. 

-- ***IMPLEMENTED***
-- features: (refinement needed)
--    * command history depicted as identicon (thus no need to smuggle around with app icons, etc.)
--    * on-the-fly command ambiguous search
-- version alpha: only implements identicon and search

-- ***IDEAS***
-- it's good to have command common string are automatically given an identicon
-- show difference by highlighting and
-- drag'n'drop???
-- one command may have multiple identicon.


-- | Needs configuration in xmonad.hs to always float this window in start-up.
main=do
    home_path<-getEnv "HOME"
    let histDir =joinPath [home_path,".Xec"]
        histFile=joinPath [histDir,"history.dat"]
    createDirectoryIfMissing True histDir
    
    initGUI
    (query,poll,notify,finalize)<-beginSearch histFile
    
    -- this order is not arbitrary. can you guess the rule?
    area   <- drawingAreaNew
    entry  <- entryNew
    box    <- vBoxNew False 1
    boxPackStart box area PackGrow 0
    boxPackEnd box entry PackNatural 0
    window <- windowNew
    set window [containerBorderWidth:=4,containerChild:=box]
    windowSetDefaultSize window 250 450
    windowSetPosition window WinPosCenter
    windowSetTitle window "Xec"

    result_local<-newIORef []
    waiting     <-newIORef False -- Enter -> complete  double-Enter -> exec anyway
    
    -- register event handlers
    let handlePoll=do
            yield
            result<-poll
            case result of
                Just x  -> writeIORef result_local x >> widgetQueueDraw area
                Nothing -> return ()
            return True
        handleExec=do -- single: complete
            writeIORef waiting False
            rs<-readIORef result_local
            unless (null rs) $ set entry [entryText:=head rs]
            return False
        
    timeoutAddFull handlePoll priorityDefaultIdle 50

    onExpose area $ \Expose {} -> do
        result<-readIORef result_local
        (w,h) <-widgetGetSize area
        dw    <-widgetGetDrawWindow area
        renderWithDrawable dw $ do
            translate 0 (fromIntegral h)
            drawCommands w result
            return True

    let newQuery=do
        text <-get entry entryText
        (_,h)<-widgetGetSize area
        query (1+h `div` commandHeight) text
            
    onEditableChanged entry newQuery
        
    onEntryActivate entry $ do
        w<-readIORef waiting
        if w
            then do -- double: execute anyway
                text<-get entry entryText
                set entry [entryText:=""]
                runMaybeT (execute text) >>= maybe (return ()) (\x->notify x >> mainQuit)
            else do -- initiate
                writeIORef waiting True
                timeoutAddFull handleExec priorityDefaultIdle 350
                return ()
    
    onDestroy window mainQuit
        
    -- show all widgets and enter main loop
    widgetShowAll window
    newQuery
    mainGUI
        
    -- finalize searcher
    finalize




-- | Monad Transformer for Maybe
data MaybeT m a=MaybeT {runMaybeT :: m (Maybe a)}

instance Monad m => Monad (MaybeT m) where
    return=MaybeT . return . Just
    f >>= g=MaybeT $ runMaybeT f >>= maybe (return Nothing) (runMaybeT . g)
    fail _=MaybeT $ return Nothing
        
instance MonadTrans MaybeT where
    lift f=MaybeT $ f >>= return . Just

-- | Fail without an argument.
fail_ :: Monad m => m a
fail_=fail undefined

-- | This can get ultra large. There should be no limit to number of entries.
-- data CommandLog=CommandLog deriving(Show) -- there's currently no need for this

-- | Processed form of commands. Monoid.
data CommandHistory=CommandHistory (Map String CommandStat)
data CommandStat=CommandStat {lastInvoked :: ClockTime, timesInvoked :: Int}

magic :: Word32
magic=3141592653

instance Binary CommandHistory where
    put (CommandHistory m)=put magic >> put m
    get=do
        x<-B.get
        if x/=magic then error "Incorrectly formatted data found. Exiting."
                    else liftM CommandHistory B.get

instance Binary CommandStat where
    put (CommandStat x y)=put x >> put y
    get=liftM2 CommandStat B.get B.get
    
instance Binary ClockTime where
    put (TOD secs picosecs)=put secs >> put picosecs
    get=liftM2 TOD B.get B.get
                    
instance Monoid CommandHistory where
    mempty=CommandHistory M.empty
    mappend (CommandHistory m0) (CommandHistory m1)=CommandHistory $ M.unionWith merge m0 m1
        where merge s0 s1=CommandStat {lastInvoked =max (lastInvoked s0) (lastInvoked s1)
                                      ,timesInvoked=timesInvoked s0+timesInvoked s1}


-- | Create CommandHistory of only one given command execution.                                      
histSingleton :: String -> IO CommandHistory
histSingleton com=do
    time<-getClockTime
    return $ CommandHistory $ M.singleton com $ CommandStat {lastInvoked=time,timesInvoked=1}


-- | Score commands and return the best ones.
histSearch :: Int -> String -> ClockTime -> CommandHistory -> [String]
histSearch n q time (CommandHistory hist)=map fst $ take n $ reverse $ sortBy (comparing snd) pairs
    where
        pairs=catMaybes $ zipWith4 eval (M.keys hist) score_n score_d score_m
        eval k n d m
            |m<=0      = Nothing
            |otherwise = Just (k,n+m+d)
        --
        score_n=evalN      $ M.elems hist
        score_d=evalD time $ M.elems hist
        score_m=evalM q    $ M.keys  hist

-- | Score CommandStats in terms of total number of times of execution.
evalN :: [CommandStat] -> [Double]
evalN=map (log . (+1) . fromIntegral . timesInvoked)

-- | Score CommandStats in terms of relative durations between last invocation.
evalD :: ClockTime -> [CommandStat] -> [Double]
evalD time ss=map f ds
    where
        f x=fromIntegral (1+minimum ds)/fromIntegral (1+x)
        ds=map (getDurationInSeconds time . lastInvoked) ss

-- | Most important. Score Commands in terms of mathing with the query.
-- Commands with 0 point should be removed from the result.
evalM :: String -> [String] -> [Double]
evalM k=map (\x->sum $ map (toI . isPrefixOf k) $ splitRedundant x)
    where toI True =1
          toI False=0
    
        
-- | Returns all possible words by separation.
splitRedundant :: String -> [String]
splitRedundant s=nub $ s:concatMap (flip looseSepBy s) " :_-/"

looseSepBy :: Eq a => a -> [a] -> [[a]]
looseSepBy s xs=map reverse $ filter (not.null) $ aux xs []
    where
        aux [] t=[t]
        aux (x:xs) t
            |x==s = t:aux xs []
            |x/=s = aux xs (x:t)


-- | Get duration between 2 ClotkTimes in exact seconds.
getDurationInSeconds :: ClockTime -> ClockTime -> Integer
getDurationInSeconds (TOD t1 _) (TOD t0 _)=t1-t0

stringToIdenticon :: String -> Identicon
stringToIdenticon=mapIdenticon . (flip mod numIdenticon) . integerDigest . sha256 . BS.pack . map (fromIntegral.ord)


commandMargin,commandSize,commandHeight :: Int
commandSize  =24
commandMargin=1
commandHeight=commandSize+commandMargin*2

drawCommands :: Int -> [String] -> Render ()
drawCommands width rs=zipWithM_ (\ix r->drawCommand width ix r $ ix==0) [0..] rs

drawCommand :: Int -> Int -> String -> Bool -> Render ()
drawCommand w i s compl=do
    save
    translate 0 $ fromIntegral (i*negate commandHeight)
    
    -- highlight
    when compl $ do
        setSourceRGBA 1 0.9 0.3 0.5
        rectangle 0 (fromIntegral $ negate commandHeight) (fromIntegral w) (fromIntegral commandHeight)
        fill
    
    -- separator
    setLineWidth 1
    setSourceRGB 0.3 0.3 0.35
    moveTo 0 0
    lineTo (fromIntegral w) 0
    stroke
    
    -- identicon
    save
    translate 0 $ negate $ fromIntegral $ commandSize+commandMargin
    scale size size
    Identicon.render $ stringToIdenticon s
    restore
    
    -- text
    selectFontFace "Monospace" FontSlantNormal FontWeightNormal
    setFontSize $ 0.65*size
    ext<-textExtents s
    translate (fromIntegral $ commandSize+commandMargin) (0.5*(textExtentsHeight ext-(fromIntegral commandHeight)))
    
    setSourceRGB 0 0 0
    showText s
    fill
    
    restore
    where size=fromIntegral commandSize


-- | Return absolute path of the executable if it exists.
getExecutable :: String -> MaybeT IO FilePath
getExecutable name=do
    ps<-lift getSearchPath
    xs<-lift $ mapM (runMaybeT . check) $ reverse ps
    MaybeT $ return $! selectMaybe xs
    where check p=do
              let path=joinPath [p,name]
              x<-lift $ doesFileExist path
              unless x fail_
              perm<-lift $ getPermissions path
              unless (executable perm) fail_
              return path
        
-- | execute given command in a separate process.
execute :: String -> MaybeT IO CommandHistory
execute command=do
    exe<-getExecutable com
    hist<-lift $ histSingleton $ unwords $ com:args
    lift $ forkProcess $ executeFile exe False args Nothing
    return hist
    where (com:args)=words command


-- | Read CommandHistory from file and search asynchronously. This function returns immediately.
-- Returns (query,poll,notify,finialize). Returned actions are thread-safe.
beginSearch :: FilePath -> IO (Int->String->IO (),IO (Maybe [String]),CommandHistory->IO(),IO())
beginSearch path=do
    -- read history file strictly
    exist<-doesFileExist path
    let getHist|exist     = BS.readFile path >>= return . decode . BS.reverse . BS.reverse 
               |otherwise = return mempty
    hv<-getHist >>= newIORef

    qv<-newEmptyMVar
    rv<-newEmptyMVar
    
    let loop x=do
            q<-takeMVar qv
            maybe (return ()) killThread x
            s<-spawn q
            loop $ Just s
        spawn (n,q)=forkIO $ do
            hist<-readIORef hv
            time<-getClockTime
            putMVar rv (histSearch n q time hist)
        
    forkIO $ loop Nothing
    
    let query n q=putMVar qv (n,q)
        poll=tryTakeMVar rv
        notify dh=readIORef hv >>= writeIORef hv . mappend dh
        finalize=readIORef hv >>= encodeFile path

    return (query,poll,notify,finalize)

selectMaybe :: [Maybe a] -> Maybe a
selectMaybe ms=case catMaybes ms of
    []  -> Nothing
    x:_ -> Just x