Xec (empty) → 0.1.6
raw patch · 5 files changed
+558/−0 lines, 5 filesdep +SHAdep +basedep +binarysetup-changed
Dependencies added: SHA, base, binary, bytestring, cairo, containers, directory, filepath, gtk, mtl, old-time, unix
Files
- Identicon.hs +165/−0
- LICENSE +25/−0
- Main.hs +344/−0
- Setup.hs +2/−0
- Xec.cabal +22/−0
+ Identicon.hs view
@@ -0,0 +1,165 @@+module Identicon where+import Control.Monad+import Data.List+import Graphics.Rendering.Cairo+import Text.Printf++curry3 f a b c=f (a,b,c)+uncurry3 f (a,b,c)=f a b c++defaultBlocks :: [Block]+defaultBlocks=nub $ concatMap expand+ [Block [0,1,4,3]+ ,Block [0,1,6]+ ,Block [0,1,3]+ ,Block [1,4,3]+ ,Block [0,1,7,6]+ ,Block [0,1,8,3]+ ,Block [0,1,5,8,7,3]+ ,Block [0,1,7,3]+ ,Block [0,1,3,7,6,3]+ -- ,Block [1,5,7,3] -- intentionally omitted for an aesthetic reason+ ]++defaultColors :: [Color]+defaultColors=map (\ix->hsvColor (fromIntegral ix/fromIntegral n) 0.45 1) [0..n-1]+ where n=12+++test2 :: FilePath -> Identicon -> IO ()+test2 path ident=withImageSurface FormatRGB24 size size $ \s->renderWith s r >> surfaceWriteToPNG s path+ where r=do+ scale (fromIntegral size) (fromIntegral size)+ render ident+ size=36++testAll :: IO ()+testAll=mapM_ (\(ix,b)->test (printf "prim%03d.png" ix) b) $ zip ([1..] :: [Int]) defaultBlocks++test :: FilePath -> Block -> IO ()+test path block=withImageSurface FormatRGB24 size size $ \s->renderWith s r >> surfaceWriteToPNG s path+ where r=do+ scale (fromIntegral size) (fromIntegral size)+ + setSourceRGB 0 0 0+ rectangle 0 0 1 1+ fill+ + setSourceRGB 1 0 0+ renderBlock block+ fill+ size=32+++-- | Identicon instance+data Identicon=Identicon Color Block Block Block deriving(Show,Eq)++numIdenticon :: Integer+numIdenticon=(fromIntegral $ length defaultBlocks)^3*(fromIntegral $ length defaultColors)++mapIdenticon :: Integer -> Identicon+mapIdenticon x=Identicon (appC per) (appB corner) (appB edge) (appB mid)+ where+ appB=(defaultBlocks!!)+ appC=(defaultColors!!)+ + [per,corner,edge,mid]=decompose [m,n,n,n] x+ n=length defaultBlocks+ m=length defaultColors++decompose :: [Int] -> Integer -> [Int]+decompose [] x=[]+decompose (b:bs) x=fromIntegral m:decompose bs q+ where (q,m)=x `divMod` (fromIntegral b)+++render :: Identicon -> Render ()+render (Identicon per c e m)=do+ setSourceColor $ RGB 1 1 1+ rectangle 0 0 1 1+ fill+ + setSourceColor per+ zipWithM_ renderB table ss+ withinRegion 3 3 1 1 $ renderMid m+ fill+ where+ renderB (x,y) block=withinRegion 3 3 x y $ renderBlock block+ + ss=[r0 c,r0 e,r1 c+ ,r3 e ,r1 e+ ,r3 c,r2 e,r2 c]+ + [r0,r1,r2,r3]=take 4 $ iterate (.rotateB) id+ table=[(x,y)|y<-[0,1,2],x<-[0,1,2],x/=1||y/=1]++renderMid m=mapM_ (uncurry renderB) $ zip [(0,0),(1,0),(1,1),(0,1)] $ take 4 $ iterate rotateB m+ where renderB (x,y) block=withinRegion 2 2 x y $ renderBlock block++withinRegion :: Int -> Int -> Int -> Int -> Render a -> Render a+withinRegion nx ny x y f=do+ save+ scale (1/fromIntegral nx) (1/fromIntegral ny)+ translate (fromIntegral x) (fromIntegral y)+ r<-f+ restore+ return r+++-- | Unified color+data Color=RGB !Double !Double !Double deriving(Show,Eq)++rgbColor,hsvColor :: Double -> Double -> Double -> Color+rgbColor r g b=RGB r g b+hsvColor h s v=case i `mod` 6 of+ 0 -> RGB v t p+ 1 -> RGB q v t+ 2 -> RGB p v t+ 3 -> RGB p q v+ 4 -> RGB t p v+ 5 -> RGB v p q+ where+ (i,f)=properFraction $ h*6+ + p=v*(1-s)+ q=v*(1-s*f)+ t=v*(1-s*(1-f))++setSourceColor :: Color -> Render ()+setSourceColor (RGB r g b)=setSourceRGB r g b++setSourceColorA :: Color -> Double -> Render ()+setSourceColorA (RGB r g b) alpha=setSourceRGBA r g b alpha+++-- | Primitive shape+-- points' locations are:+-- 0 1 2+-- 3 4 5+-- 6 7 8+newtype Block=Block [Int] deriving(Show)++-- | This is not complete. (ie:0,1,2 and 0,2)+instance Eq Block where+ (Block xs) == (Block ys)+ |length xs/=length ys = False+ |otherwise = isInfixOf xs (ys++ys) || isInfixOf (reverse xs) (ys++ys)++-- maximum of 8 patterns (rot:4 * rev:2)+expand :: Block -> [Block]+expand block=nub $ map ($block) syms+ where+ syms=rots++map (.reverseB) rots+ rots=take 4 $ iterate (.rotateB) id++renderBlock :: Block -> Render ()+renderBlock (Block (x:xs))=do+ uncurry moveTo (table!!x)+ mapM_ (uncurry lineTo . (table!!)) xs+ closePath+ where table=[(0.5*fromIntegral x,0.5*fromIntegral y)|y<-[0,1,2],x<-[0,1,2]]++rotateB (Block xs)=Block $ map ([2,5,8,1,4,7,0,3,6]!!) xs+reverseB (Block xs)=Block $ map ([2,1,0,5,4,3,8,7,6]!!) xs++
+ LICENSE view
@@ -0,0 +1,25 @@+Copyright © 2008-2012 Daiki Handa+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted+provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright notice, this list of conditions+ and the following disclaimer.++ * Redistributions in binary form must reproduce the above copyright notice, this list of+ conditions and the following disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of the copyright holders nor the names of the contributors may be used to+ endorse or promote products derived from this software without specific prior written+ permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS “AS IS” AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER+IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF+THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Main.hs view
@@ -0,0 +1,344 @@+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+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Xec.cabal view
@@ -0,0 +1,22 @@+name: Xec+version: 0.1.6+synopsis: Gtk command launcher with identicon+description:+ Xec (pron. exec) is a launcher with identicon. It's originally intended to be used with xmonad, + but you can use it anywhere gtk is available. Hit enter twice in a row to run the command as-is.+ Hit enter once to complete the command with highlited one.+license: BSD3+license-File: LICENSE+build-type: Simple+cabal-version: >=1.8+category: Utils+maintainer: Daiki Handa (xanxys@gmail.com)+source-repository head+ type: darcs+ location: https://patch-tag.com/r/xanxys/Xec/++executable Xec+ Build-Depends: base >=3 && <5, binary>=0.4, bytestring, gtk, cairo, filepath>=1.0, old-time, unix>=2.0,+ directory, containers>=0.1, mtl, SHA+ Main-Is: Main.hs+ Other-Modules: Identicon