{-|
Module      : Client.Commands.WordCompletion
Description : Tab-completion logic
Copyright   : (c) Eric Mertens, 2016
License     : ISC
Maintainer  : emertens@gmail.com

This module provides the tab-completion logic used for nicknames and channels.

-}
module Client.Commands.WordCompletion
  ( Prefix(..)
  , wordComplete

  -- * Word completion modes
  , WordCompletionMode(..)
  , plainWordCompleteMode
  , defaultNickWordCompleteMode
  , slackNickWordCompleteMode

  , CaseText, caseText
  ) where

import qualified Client.State.EditBox as Edit
import           Control.Applicative
import           Control.Lens
import           Control.Monad
import           Data.List
import qualified Data.Set as Set
import           Data.String (IsString(..))
import qualified Data.Text as Text
import           Data.Text (Text)
import           Irc.Identifier

-- | Word completion prefix and suffix
data WordCompletionMode = WordCompletionMode
  { WordCompletionMode -> String
wcmStartPrefix, WordCompletionMode -> String
wcmStartSuffix, WordCompletionMode -> String
wcmMiddlePrefix, WordCompletionMode -> String
wcmMiddleSuffix :: String }
  deriving Int -> WordCompletionMode -> ShowS
[WordCompletionMode] -> ShowS
WordCompletionMode -> String
(Int -> WordCompletionMode -> ShowS)
-> (WordCompletionMode -> String)
-> ([WordCompletionMode] -> ShowS)
-> Show WordCompletionMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WordCompletionMode] -> ShowS
$cshowList :: [WordCompletionMode] -> ShowS
show :: WordCompletionMode -> String
$cshow :: WordCompletionMode -> String
showsPrec :: Int -> WordCompletionMode -> ShowS
$cshowsPrec :: Int -> WordCompletionMode -> ShowS
Show


-- | Word completion without adding any prefix or suffix
plainWordCompleteMode :: WordCompletionMode
plainWordCompleteMode :: WordCompletionMode
plainWordCompleteMode = String -> String -> String -> String -> WordCompletionMode
WordCompletionMode String
"" String
"" String
"" String
""


-- | Word completion adding a ": " suffix at the beginning of lines
defaultNickWordCompleteMode :: WordCompletionMode
defaultNickWordCompleteMode :: WordCompletionMode
defaultNickWordCompleteMode = String -> String -> String -> String -> WordCompletionMode
WordCompletionMode String
"" String
": " String
"" String
""

-- | Word completion using a "@" prefix intended
slackNickWordCompleteMode :: WordCompletionMode
slackNickWordCompleteMode :: WordCompletionMode
slackNickWordCompleteMode = String -> String -> String -> String -> WordCompletionMode
WordCompletionMode String
"@" String
" " String
"@" String
""

-- | Perform word completion on a text box.
--
-- The leading update operation is applied to the result of tab-completion
-- when tab completing from the beginning of the text box. This is useful
-- when auto-completing a nick and including a trailing colon.
--
-- The @reversed@ parameter indicates that tab-completion should return the
-- previous entry. When starting a fresh tab completion the priority completions
-- will be considered in order before resorting to the set of possible
-- completions.
wordComplete ::
  Prefix a =>
  (Char -> Bool) {- ^ valid character predicate -} ->
  WordCompletionMode {- ^ leading update operation -} ->
  Bool               {- ^ reversed -} ->
  [a]       {- ^ priority completions -} ->
  [a]       {- ^ possible completions -} ->
  Edit.EditBox -> Maybe Edit.EditBox
wordComplete :: (Char -> Bool)
-> WordCompletionMode
-> Bool
-> [a]
-> [a]
-> EditBox
-> Maybe EditBox
wordComplete Char -> Bool
p WordCompletionMode
mode Bool
isReversed [a]
hint [a]
vals EditBox
box =
  do let current :: String
current = (Char -> Bool) -> WordCompletionMode -> EditBox -> String
currentWord Char -> Bool
p WordCompletionMode
mode EditBox
box
     Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
current))
     let cur :: a
cur = String -> a
forall a. IsString a => String -> a
fromString String
current
     case Getting LastOperation EditBox LastOperation
-> EditBox -> LastOperation
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting LastOperation EditBox LastOperation
Lens' EditBox LastOperation
Edit.lastOperation EditBox
box of
       Edit.TabOperation String
patternStr
         | a -> a -> Bool
forall a. Prefix a => a -> a -> Bool
isPrefix a
pat a
cur ->

         do a
next <- Bool -> a -> a -> [a] -> Maybe a
forall a. Prefix a => Bool -> a -> a -> [a] -> Maybe a
tabSearch Bool
isReversed a
pat a
cur [a]
vals
            EditBox -> Maybe EditBox
forall a. a -> Maybe a
Just (EditBox -> Maybe EditBox) -> EditBox -> Maybe EditBox
forall a b. (a -> b) -> a -> b
$ (Char -> Bool)
-> WordCompletionMode -> String -> EditBox -> EditBox
replaceWith Char -> Bool
p WordCompletionMode
mode (a -> String
forall a. Prefix a => a -> String
toString a
next) EditBox
box
         where
           pat :: a
pat = String -> a
forall a. IsString a => String -> a
fromString String
patternStr

       LastOperation
_ ->
         do a
next <- (a -> Bool) -> [a] -> Maybe a
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (a -> a -> Bool
forall a. Prefix a => a -> a -> Bool
isPrefix a
cur) [a]
hint Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                    Bool -> a -> a -> [a] -> Maybe a
forall a. Prefix a => Bool -> a -> a -> [a] -> Maybe a
tabSearch Bool
isReversed a
cur a
cur [a]
vals
            EditBox -> Maybe EditBox
forall a. a -> Maybe a
Just (EditBox -> Maybe EditBox) -> EditBox -> Maybe EditBox
forall a b. (a -> b) -> a -> b
$ ASetter EditBox EditBox LastOperation LastOperation
-> LastOperation -> EditBox -> EditBox
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter EditBox EditBox LastOperation LastOperation
Lens' EditBox LastOperation
Edit.lastOperation (String -> LastOperation
Edit.TabOperation String
current)
                 (EditBox -> EditBox) -> EditBox -> EditBox
forall a b. (a -> b) -> a -> b
$ (Char -> Bool)
-> WordCompletionMode -> String -> EditBox -> EditBox
replaceWith Char -> Bool
p WordCompletionMode
mode (a -> String
forall a. Prefix a => a -> String
toString a
next) EditBox
box

replaceWith :: (Char -> Bool) -> WordCompletionMode -> String -> Edit.EditBox -> Edit.EditBox
replaceWith :: (Char -> Bool)
-> WordCompletionMode -> String -> EditBox -> EditBox
replaceWith Char -> Bool
p (WordCompletionMode String
spfx String
ssfx String
mpfx String
msfx) String
str EditBox
box =
    let box1 :: EditBox
box1 = (Char -> Bool) -> Bool -> EditBox -> EditBox
Edit.killWordBackward (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
p) Bool
False EditBox
box
        str1 :: String
str1 | Getting Int EditBox Int -> EditBox -> Int
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Int EditBox Int
forall c. HasLine c => Lens' c Int
Edit.pos EditBox
box1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = String
spfx String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
str String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ssfx
             | Bool
otherwise               = String
mpfx String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
str String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msfx
    in ASetter EditBox EditBox Content Content
-> (Content -> Content) -> EditBox -> EditBox
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter EditBox EditBox Content Content
Lens' EditBox Content
Edit.content (String -> Content -> Content
Edit.insertString String
str1) EditBox
box1


-- | Find the word preceeding the cursor skipping over any
-- characters that can be found in the prefix and suffix for
-- the current completion mode.
currentWord :: (Char -> Bool) -> WordCompletionMode -> Edit.EditBox -> String
currentWord :: (Char -> Bool) -> WordCompletionMode -> EditBox -> String
currentWord Char -> Bool
p (WordCompletionMode String
spfx String
ssfx String
mpfx String
msfx) EditBox
box
  = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`String
pfx)
  ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. [a] -> [a]
reverse
  ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
p
  ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`String
sfx)
  ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. [a] -> [a]
reverse
  ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
n String
txt
  where
    pfx :: String
pfx = String
spfxString -> ShowS
forall a. [a] -> [a] -> [a]
++String
mpfx
    sfx :: String
sfx = String
ssfxString -> ShowS
forall a. [a] -> [a] -> [a]
++String
msfx
    Edit.Line Int
n String
txt = Getting Line EditBox Line -> EditBox -> Line
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Line EditBox Line
forall c. HasLine c => Lens' c Line
Edit.line EditBox
box

-- | Class for types that are isomorphic to 'String'
-- and which can support a total order and a prefix
-- predicate.
--
-- @
-- 'Prefix.toString' ('fromString' x) == x
-- 'fromString' ('Prefix.toString' x) == x
-- 'Prefix.isPrefix' x y ==> x '<=' y
-- @
class (IsString a, Ord a) => Prefix a where
  -- | Check if the first argument is a lexicographic prefix of the second.
  isPrefix :: a -> a -> Bool
  -- | Convert to a 'String'.
  toString :: a -> String

instance Prefix Identifier where
  isPrefix :: Identifier -> Identifier -> Bool
isPrefix = Identifier -> Identifier -> Bool
idPrefix
  toString :: Identifier -> String
toString = Text -> String
Text.unpack (Text -> String) -> (Identifier -> Text) -> Identifier -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> Text
idText

instance Prefix Text where
  isPrefix :: Text -> Text -> Bool
isPrefix = Text -> Text -> Bool
Text.isPrefixOf
  toString :: Text -> String
toString = Text -> String
Text.unpack

newtype CaseText = CaseText { CaseText -> Text
unCaseText :: Text }
  deriving (CaseText -> CaseText -> Bool
(CaseText -> CaseText -> Bool)
-> (CaseText -> CaseText -> Bool) -> Eq CaseText
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CaseText -> CaseText -> Bool
$c/= :: CaseText -> CaseText -> Bool
== :: CaseText -> CaseText -> Bool
$c== :: CaseText -> CaseText -> Bool
Eq, Eq CaseText
Eq CaseText
-> (CaseText -> CaseText -> Ordering)
-> (CaseText -> CaseText -> Bool)
-> (CaseText -> CaseText -> Bool)
-> (CaseText -> CaseText -> Bool)
-> (CaseText -> CaseText -> Bool)
-> (CaseText -> CaseText -> CaseText)
-> (CaseText -> CaseText -> CaseText)
-> Ord CaseText
CaseText -> CaseText -> Bool
CaseText -> CaseText -> Ordering
CaseText -> CaseText -> CaseText
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CaseText -> CaseText -> CaseText
$cmin :: CaseText -> CaseText -> CaseText
max :: CaseText -> CaseText -> CaseText
$cmax :: CaseText -> CaseText -> CaseText
>= :: CaseText -> CaseText -> Bool
$c>= :: CaseText -> CaseText -> Bool
> :: CaseText -> CaseText -> Bool
$c> :: CaseText -> CaseText -> Bool
<= :: CaseText -> CaseText -> Bool
$c<= :: CaseText -> CaseText -> Bool
< :: CaseText -> CaseText -> Bool
$c< :: CaseText -> CaseText -> Bool
compare :: CaseText -> CaseText -> Ordering
$ccompare :: CaseText -> CaseText -> Ordering
$cp1Ord :: Eq CaseText
Ord, Int -> CaseText -> ShowS
[CaseText] -> ShowS
CaseText -> String
(Int -> CaseText -> ShowS)
-> (CaseText -> String) -> ([CaseText] -> ShowS) -> Show CaseText
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CaseText] -> ShowS
$cshowList :: [CaseText] -> ShowS
show :: CaseText -> String
$cshow :: CaseText -> String
showsPrec :: Int -> CaseText -> ShowS
$cshowsPrec :: Int -> CaseText -> ShowS
Show, ReadPrec [CaseText]
ReadPrec CaseText
Int -> ReadS CaseText
ReadS [CaseText]
(Int -> ReadS CaseText)
-> ReadS [CaseText]
-> ReadPrec CaseText
-> ReadPrec [CaseText]
-> Read CaseText
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [CaseText]
$creadListPrec :: ReadPrec [CaseText]
readPrec :: ReadPrec CaseText
$creadPrec :: ReadPrec CaseText
readList :: ReadS [CaseText]
$creadList :: ReadS [CaseText]
readsPrec :: Int -> ReadS CaseText
$creadsPrec :: Int -> ReadS CaseText
Read)

instance IsString CaseText where
  fromString :: String -> CaseText
fromString = Text -> CaseText
CaseText (Text -> CaseText) -> (String -> Text) -> String -> CaseText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.toLower (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack

instance Prefix CaseText where
  isPrefix :: CaseText -> CaseText -> Bool
isPrefix CaseText
x CaseText
y = Text -> Text -> Bool
Text.isPrefixOf (CaseText -> Text
unCaseText CaseText
x) (CaseText -> Text
unCaseText CaseText
y)
  toString :: CaseText -> String
toString = Text -> String
Text.unpack (Text -> String) -> (CaseText -> Text) -> CaseText -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CaseText -> Text
unCaseText

caseText :: Text -> CaseText
caseText :: Text -> CaseText
caseText = Text -> CaseText
CaseText (Text -> CaseText) -> (Text -> Text) -> Text -> CaseText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.toLower

-- | Find the next entry in a list of possible choices using an alphabetical
-- ordering.
tabSearch ::
  Prefix a =>
  Bool {- ^ reversed        -} ->
  a    {- ^ search prefix   -} ->
  a    {- ^ previous result -} ->
  [a]  {- ^ posibilities    -} ->
  Maybe a
tabSearch :: Bool -> a -> a -> [a] -> Maybe a
tabSearch Bool
isReversed a
pat a
cur [a]
vals
  | Set a -> Bool
forall a. Set a -> Bool
Set.null Set a
valSet                    = Maybe a
forall a. Maybe a
Nothing
  | Just a
next <- a -> Set a -> Maybe a
advanceFun a
cur Set a
valSet = a -> Maybe a
forall a. a -> Maybe a
Just a
next
  | Bool
isReversed                         = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$! Set a -> a
forall a. Set a -> a
Set.findMax Set a
valSet
  | Bool
otherwise                          = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$! Set a -> a
forall a. Set a -> a
Set.findMin Set a
valSet
  where
    valSet :: Set a
valSet = [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList ((a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> a -> Bool
forall a. Prefix a => a -> a -> Bool
isPrefix a
pat) [a]
vals)

    advanceFun :: a -> Set a -> Maybe a
advanceFun | Bool
isReversed = a -> Set a -> Maybe a
forall a. Ord a => a -> Set a -> Maybe a
Set.lookupLT
               | Bool
otherwise  = a -> Set a -> Maybe a
forall a. Ord a => a -> Set a -> Maybe a
Set.lookupGT