{- |
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 Codec.Binary.UTF8.String (decodeString)
import qualified Data.ByteString.Char8 as BS
import Numeric
import System.IO
import System.IO.Error
import Text.Printf

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 -> [Char]
showXPrompt Unicode
Unicode = [Char]
"Unicode: "
  commandToComplete :: Unicode -> [Char] -> [Char]
commandToComplete Unicode
Unicode [Char]
s = [Char]
s
  nextCompletion :: Unicode -> [Char] -> [[Char]] -> [Char]
nextCompletion Unicode
Unicode = [Char] -> [[Char]] -> [Char]
getNextCompletion

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

instance ExtensionClass UnicodeData where
  initialValue :: UnicodeData
initialValue = [(Char, [Char])] -> 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.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)

A path to a @UnicodeData.txt@ file or equivalent must be provided.  This file
should be available through your package manager; search for @unicode-data@.
If no package is found, one may opt to download this file directly from
[unicode.org](http://www.unicode.org/Public/UNIDATA/UnicodeData.txt).

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

parseUnicodeData :: BS.ByteString -> [(Char, String)]
parseUnicodeData :: ByteString -> [(Char, [Char])]
parseUnicodeData = (ByteString -> Maybe (Char, [Char]))
-> [ByteString] -> [(Char, [Char])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ByteString -> Maybe (Char, [Char])
forall {m :: * -> *}. MonadFail m => ByteString -> m (Char, [Char])
parseLine ([ByteString] -> [(Char, [Char])])
-> (ByteString -> [ByteString]) -> ByteString -> [(Char, [Char])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
BS.lines
  where parseLine :: ByteString -> m (Char, [Char])
parseLine ByteString
l = do
          field1 : field2 : _ <- [ByteString] -> m [ByteString]
forall a. a -> m a
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
          [(c,"")] <- return . readHex $ BS.unpack field1
          desc <- return . decodeString $ BS.unpack field2
          return (chr c, desc)

type Predicate = String -> String -> Bool

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

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

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

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