{- |
Module      :  XMonad.Prompt.Unicode
Description :  A prompt for inputting Unicode characters.
Copyright   :  (c) 2016 Joachim Breitner
                   2017 Nick Hu
License     :  BSD-style (see LICENSE)

Maintainer  :  <mail@joachim-breitner.de>
Stability   :  stable

A prompt for searching unicode characters by name and inserting them into
the clipboard.

The provided @unicodePrompt@ and @typeUnicodePrompt@ use @xsel@ and @xdotool@
respectively.
-}

module XMonad.Prompt.Unicode (
 -- * Usage
 -- $usage
 unicodePrompt,
 typeUnicodePrompt,
 mkUnicodePrompt
 ) where

import qualified Data.ByteString.Char8 as BS
import Numeric
import System.IO
import System.IO.Error
import Text.Printf
import Control.Arrow (second)

import XMonad
import XMonad.Prelude
import qualified XMonad.Util.ExtensibleState as XS
import XMonad.Util.Run
import XMonad.Prompt

data Unicode = Unicode
instance XPrompt Unicode where
  showXPrompt :: Unicode -> String
showXPrompt Unicode
Unicode = String
"Unicode: "
  commandToComplete :: Unicode -> String -> String
commandToComplete Unicode
Unicode String
s = String
s
  nextCompletion :: Unicode -> String -> [String] -> String
nextCompletion Unicode
Unicode = String -> [String] -> String
getNextCompletion

newtype UnicodeData = UnicodeData { UnicodeData -> [(Char, ByteString)]
getUnicodeData :: [(Char, BS.ByteString)] }
  deriving (ReadPrec [UnicodeData]
ReadPrec UnicodeData
Int -> ReadS UnicodeData
ReadS [UnicodeData]
(Int -> ReadS UnicodeData)
-> ReadS [UnicodeData]
-> ReadPrec UnicodeData
-> ReadPrec [UnicodeData]
-> Read UnicodeData
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [UnicodeData]
$creadListPrec :: ReadPrec [UnicodeData]
readPrec :: ReadPrec UnicodeData
$creadPrec :: ReadPrec UnicodeData
readList :: ReadS [UnicodeData]
$creadList :: ReadS [UnicodeData]
readsPrec :: Int -> ReadS UnicodeData
$creadsPrec :: Int -> ReadS UnicodeData
Read, Int -> UnicodeData -> String -> String
[UnicodeData] -> String -> String
UnicodeData -> String
(Int -> UnicodeData -> String -> String)
-> (UnicodeData -> String)
-> ([UnicodeData] -> String -> String)
-> Show UnicodeData
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [UnicodeData] -> String -> String
$cshowList :: [UnicodeData] -> String -> String
show :: UnicodeData -> String
$cshow :: UnicodeData -> String
showsPrec :: Int -> UnicodeData -> String -> String
$cshowsPrec :: Int -> UnicodeData -> String -> String
Show)

instance ExtensionClass UnicodeData where
  initialValue :: UnicodeData
initialValue = [(Char, ByteString)] -> UnicodeData
UnicodeData []
  extensionType :: UnicodeData -> StateExtension
extensionType = UnicodeData -> StateExtension
forall a. ExtensionClass a => a -> StateExtension
StateExtension

{- $usage

You can use this module by importing it, along with
"XMonad.Prompt", into your ~\/.xmonad\/xmonad.hs file:

> import XMonad.Prompt
> import XMonad.Prompt.Unicode

and adding an appropriate keybinding, for example:

>  , ((modm .|. controlMask, xK_u), unicodePrompt "/path/to/unicode-data" def)

More flexibility is given by the @mkUnicodePrompt@ function, which takes a
command and a list of arguments to pass as its first two arguments. See
@unicodePrompt@ for details.
-}

populateEntries :: String -> X Bool
populateEntries :: String -> X Bool
populateEntries String
unicodeDataFilename = do
  [(Char, ByteString)]
entries <- (UnicodeData -> [(Char, ByteString)])
-> X UnicodeData -> X [(Char, ByteString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnicodeData -> [(Char, ByteString)]
getUnicodeData (X UnicodeData
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get :: X UnicodeData)
  if [(Char, ByteString)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Char, ByteString)]
entries
    then do
      Either IOError ByteString
datE <- IO (Either IOError ByteString) -> X (Either IOError ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOError ByteString) -> X (Either IOError ByteString))
-> (IO ByteString -> IO (Either IOError ByteString))
-> IO ByteString
-> X (Either IOError ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO ByteString -> IO (Either IOError ByteString)
forall a. IO a -> IO (Either IOError a)
tryIOError (IO ByteString -> X (Either IOError ByteString))
-> IO ByteString -> X (Either IOError ByteString)
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BS.readFile String
unicodeDataFilename
      case Either IOError ByteString
datE of
        Left IOError
e -> IO Bool -> X Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> X Bool) -> IO Bool -> X Bool
forall a b. (a -> b) -> a -> b
$ do
          Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Could not read file \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
unicodeDataFilename String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""
          Handle -> IOError -> IO ()
forall a. Show a => Handle -> a -> IO ()
hPrint Handle
stderr IOError
e
          Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"Do you have unicode-data installed?"
          Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Right ByteString
dat -> do
          UnicodeData -> X ()
forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put (UnicodeData -> X ())
-> ([(Char, ByteString)] -> UnicodeData)
-> [(Char, ByteString)]
-> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Char, ByteString)] -> UnicodeData
UnicodeData ([(Char, ByteString)] -> UnicodeData)
-> ([(Char, ByteString)] -> [(Char, ByteString)])
-> [(Char, ByteString)]
-> UnicodeData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Char, ByteString) -> Int)
-> [(Char, ByteString)] -> [(Char, ByteString)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (ByteString -> Int
BS.length (ByteString -> Int)
-> ((Char, ByteString) -> ByteString) -> (Char, ByteString) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char, ByteString) -> ByteString
forall a b. (a, b) -> b
snd) ([(Char, ByteString)] -> X ()) -> [(Char, ByteString)] -> X ()
forall a b. (a -> b) -> a -> b
$ ByteString -> [(Char, ByteString)]
parseUnicodeData ByteString
dat
          Bool -> X Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    else Bool -> X Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

parseUnicodeData :: BS.ByteString -> [(Char, BS.ByteString)]
parseUnicodeData :: ByteString -> [(Char, ByteString)]
parseUnicodeData = (ByteString -> Maybe (Char, ByteString))
-> [ByteString] -> [(Char, ByteString)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ByteString -> Maybe (Char, ByteString)
forall (m :: * -> *).
MonadFail m =>
ByteString -> m (Char, ByteString)
parseLine ([ByteString] -> [(Char, ByteString)])
-> (ByteString -> [ByteString])
-> ByteString
-> [(Char, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
BS.lines
  where parseLine :: ByteString -> m (Char, ByteString)
parseLine ByteString
l = do
          ByteString
field1 : ByteString
field2 : [ByteString]
_ <- [ByteString] -> m [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ByteString] -> m [ByteString]) -> [ByteString] -> m [ByteString]
forall a b. (a -> b) -> a -> b
$ Char -> ByteString -> [ByteString]
BS.split Char
';' ByteString
l
          [(Int
c,String
"")] <- [(Int, String)] -> m [(Int, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Int, String)] -> m [(Int, String)])
-> (String -> [(Int, String)]) -> String -> m [(Int, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [(Int, String)]
forall a. (Eq a, Num a) => ReadS a
readHex (String -> m [(Int, String)]) -> String -> m [(Int, String)]
forall a b. (a -> b) -> a -> b
$ ByteString -> String
BS.unpack ByteString
field1
          (Char, ByteString) -> m (Char, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Char
chr Int
c, ByteString
field2)

type Predicate = String -> String -> Bool

searchUnicode :: [(Char, BS.ByteString)] -> Predicate -> String -> [(Char, String)]
searchUnicode :: [(Char, ByteString)] -> Predicate -> String -> [(Char, String)]
searchUnicode [(Char, ByteString)]
entries Predicate
p String
s = ((Char, ByteString) -> (Char, String))
-> [(Char, ByteString)] -> [(Char, String)]
forall a b. (a -> b) -> [a] -> [b]
map ((ByteString -> String) -> (Char, ByteString) -> (Char, String)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ByteString -> String
BS.unpack) ([(Char, ByteString)] -> [(Char, String)])
-> [(Char, ByteString)] -> [(Char, String)]
forall a b. (a -> b) -> a -> b
$ ((Char, ByteString) -> Bool)
-> [(Char, ByteString)] -> [(Char, ByteString)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Char, ByteString) -> Bool
forall a. (a, ByteString) -> Bool
go [(Char, ByteString)]
entries
  where w :: [String]
w = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isAscii) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (Int -> Bool) -> (String -> Int) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper String
s
        go :: (a, ByteString) -> Bool
go (a
_, ByteString
d) = (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Predicate
`p` ByteString -> String
BS.unpack ByteString
d) [String]
w

mkUnicodePrompt :: String -> [String] -> String -> XPConfig -> X ()
mkUnicodePrompt :: String -> [String] -> String -> XPConfig -> X ()
mkUnicodePrompt String
prog [String]
args String
unicodeDataFilename XPConfig
xpCfg =
  X Bool -> X () -> X ()
whenX (String -> X Bool
populateEntries String
unicodeDataFilename) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ do
    [(Char, ByteString)]
entries <- (UnicodeData -> [(Char, ByteString)])
-> X UnicodeData -> X [(Char, ByteString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnicodeData -> [(Char, ByteString)]
getUnicodeData (X UnicodeData
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get :: X UnicodeData)
    Unicode -> XPConfig -> ComplFunction -> (String -> X ()) -> X ()
forall p.
XPrompt p =>
p -> XPConfig -> ComplFunction -> (String -> X ()) -> X ()
mkXPrompt
      Unicode
Unicode
      (XPConfig
xpCfg {sorter :: String -> [String] -> [String]
sorter = XPConfig -> String -> [String] -> [String]
sorter XPConfig
xpCfg (String -> [String] -> [String])
-> (String -> String) -> String -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper})
      ([(Char, ByteString)] -> Predicate -> ComplFunction
unicodeCompl [(Char, ByteString)]
entries (Predicate -> ComplFunction) -> Predicate -> ComplFunction
forall a b. (a -> b) -> a -> b
$ XPConfig -> Predicate
searchPredicate XPConfig
xpCfg)
      String -> X ()
forall (m :: * -> *). MonadIO m => String -> m ()
paste
  where
    unicodeCompl :: [(Char, BS.ByteString)] -> Predicate -> String -> IO [String]
    unicodeCompl :: [(Char, ByteString)] -> Predicate -> ComplFunction
unicodeCompl [(Char, ByteString)]
_ Predicate
_ String
"" = [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    unicodeCompl [(Char, ByteString)]
entries Predicate
p String
s = do
      let m :: [(Char, String)]
m = [(Char, ByteString)] -> Predicate -> String -> [(Char, String)]
searchUnicode [(Char, ByteString)]
entries Predicate
p String
s
      [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String])
-> ([(Char, String)] -> [String])
-> [(Char, String)]
-> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Char, String) -> String) -> [(Char, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(Char
c,String
d) -> String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"%s %s" [Char
c] String
d) ([(Char, String)] -> IO [String])
-> [(Char, String)] -> IO [String]
forall a b. (a -> b) -> a -> b
$ Int -> [(Char, String)] -> [(Char, String)]
forall a. Int -> [a] -> [a]
take Int
20 [(Char, String)]
m
    paste :: String -> m ()
paste [] = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    paste (Char
c:String
_) = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      Handle
handle <- String -> IO Handle
forall (m :: * -> *). MonadIO m => String -> m Handle
spawnPipe (String -> IO Handle) -> String -> IO Handle
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
prog String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
args
      Handle -> Char -> IO ()
hPutChar Handle
handle Char
c
      Handle -> IO ()
hClose Handle
handle
      () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Prompt the user for a Unicode character to be inserted into the paste buffer of the X server.
unicodePrompt :: String -> XPConfig -> X ()
unicodePrompt :: String -> XPConfig -> X ()
unicodePrompt = String -> [String] -> String -> XPConfig -> X ()
mkUnicodePrompt String
"xsel" [String
"-i"]

-- | Prompt the user for a Unicode character to be typed by @xdotool@.
typeUnicodePrompt :: String -> XPConfig -> X ()
typeUnicodePrompt :: String -> XPConfig -> X ()
typeUnicodePrompt = String -> [String] -> String -> XPConfig -> X ()
mkUnicodePrompt String
"xdotool" [String
"type", String
"--clearmodifiers", String
"--file", String
"-"]