{-# LANGUAGE PatternGuards #-}
-- Copyright (c) 2004-6 Don Stewart - http://www.cse.unsw.edu.au/~dons
-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)
--
-- | Interface to /aspell/, an open source spelling checker, from a
-- suggestion by Kai Engelhardt. Requires you to install aspell.
module Lambdabot.Plugin.Reference.Spell (spellPlugin) where

import Lambdabot.Config.Reference
import Lambdabot.Plugin
import Lambdabot.Util

import Control.Monad.Trans
import Data.Char
import Data.List.Split
import Data.Maybe
import System.Process
import Text.Regex.TDFA


type Spell = ModuleT Bool LB

spellPlugin :: Module Bool
spellPlugin :: Module Bool
spellPlugin = Module Bool
forall st. Module st
newModule
    { moduleCmds :: ModuleT Bool LB [Command (ModuleT Bool LB)]
moduleCmds = [Command (ModuleT Bool LB)]
-> ModuleT Bool LB [Command (ModuleT Bool LB)]
forall (m :: * -> *) a. Monad m => a -> m a
return
        [ (String -> Command Identity
command String
"spell")
            { help :: Cmd (ModuleT Bool LB) ()
help = String -> Cmd (ModuleT Bool LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
helpStr
            , process :: String -> Cmd (ModuleT Bool LB) ()
process = String -> Cmd (ModuleT Bool LB) ()
doSpell
            }
        , (String -> Command Identity
command String
"spell-all")
            { help :: Cmd (ModuleT Bool LB) ()
help = String -> Cmd (ModuleT Bool LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
helpStr
            , process :: String -> Cmd (ModuleT Bool LB) ()
process = String -> Cmd (ModuleT Bool LB) ()
spellAll
            }
        , (String -> Command Identity
command String
"nazi-on")
            { privileged :: Bool
privileged = Bool
True
            , help :: Cmd (ModuleT Bool LB) ()
help = String -> Cmd (ModuleT Bool LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
helpStr
            , process :: String -> Cmd (ModuleT Bool LB) ()
process = Cmd (ModuleT Bool LB) () -> String -> Cmd (ModuleT Bool LB) ()
forall a b. a -> b -> a
const (Bool -> Cmd (ModuleT Bool LB) ()
nazi Bool
True)
            }
        , (String -> Command Identity
command String
"nazi-off")
            { privileged :: Bool
privileged = Bool
True
            , help :: Cmd (ModuleT Bool LB) ()
help = String -> Cmd (ModuleT Bool LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
helpStr
            , process :: String -> Cmd (ModuleT Bool LB) ()
process = Cmd (ModuleT Bool LB) () -> String -> Cmd (ModuleT Bool LB) ()
forall a b. a -> b -> a
const (Bool -> Cmd (ModuleT Bool LB) ()
nazi Bool
False)
            }
        ]
    , moduleDefState :: LB Bool
moduleDefState = Bool -> LB Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

    , contextual :: String -> Cmd (ModuleT Bool LB) ()
contextual = \String
txt -> do
        Bool
alive <- Cmd (ModuleT Bool LB) Bool
forall (m :: * -> *). MonadLBState m => m (LBState m)
readMS
        String
binary <- Config String -> Cmd (ModuleT Bool LB) String
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config String
aspellBinary
        if Bool
alive then IO [String] -> Cmd (ModuleT Bool LB) [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> String -> IO [String]
spellingNazi String
binary String
txt) Cmd (ModuleT Bool LB) [String]
-> ([String] -> Cmd (ModuleT Bool LB) ())
-> Cmd (ModuleT Bool LB) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> Cmd (ModuleT Bool LB) ())
-> [String] -> Cmd (ModuleT Bool LB) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> Cmd (ModuleT Bool LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say
                 else () -> Cmd (ModuleT Bool LB) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    }

helpStr :: String
helpStr :: String
helpStr = String
"spell <word>. Show spelling of word"

doSpell :: [Char] -> Cmd Spell ()
doSpell :: String -> Cmd (ModuleT Bool LB) ()
doSpell [] = String -> Cmd (ModuleT Bool LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"No word to spell."
doSpell String
s  = do
    String
binary <- Config String -> Cmd (ModuleT Bool LB) String
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config String
aspellBinary
    (String -> Cmd (ModuleT Bool LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say (String -> Cmd (ModuleT Bool LB) ())
-> ([String] -> String) -> [String] -> Cmd (ModuleT Bool LB) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall a. Show a => [a] -> String
showClean ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
5) ([String] -> Cmd (ModuleT Bool LB) ())
-> Cmd (ModuleT Bool LB) [String] -> Cmd (ModuleT Bool LB) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (IO [String] -> Cmd (ModuleT Bool LB) [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> String -> IO [String]
spell String
binary String
s))

spellAll :: [Char] -> Cmd Spell ()
spellAll :: String -> Cmd (ModuleT Bool LB) ()
spellAll [] = String -> Cmd (ModuleT Bool LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"No phrase to spell."
spellAll String
s  = do
    String
binary <- Config String -> Cmd (ModuleT Bool LB) String
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config String
aspellBinary
    IO [String] -> Cmd (ModuleT Bool LB) [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> String -> IO [String]
spellingNazi String
binary String
s) Cmd (ModuleT Bool LB) [String]
-> ([String] -> Cmd (ModuleT Bool LB) ())
-> Cmd (ModuleT Bool LB) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> Cmd (ModuleT Bool LB) ())
-> [String] -> Cmd (ModuleT Bool LB) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> Cmd (ModuleT Bool LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say

nazi :: Bool -> Cmd (ModuleT Bool LB) ()
nazi :: Bool -> Cmd (ModuleT Bool LB) ()
nazi Bool
True  = ModuleT Bool LB () -> Cmd (ModuleT Bool LB) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ModuleT Bool LB ()
on  Cmd (ModuleT Bool LB) ()
-> Cmd (ModuleT Bool LB) () -> Cmd (ModuleT Bool LB) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Cmd (ModuleT Bool LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"Spelling nazi engaged."
nazi Bool
False = ModuleT Bool LB () -> Cmd (ModuleT Bool LB) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ModuleT Bool LB ()
off Cmd (ModuleT Bool LB) ()
-> Cmd (ModuleT Bool LB) () -> Cmd (ModuleT Bool LB) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Cmd (ModuleT Bool LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"Spelling nazi disengaged."

on :: Spell ()
on :: ModuleT Bool LB ()
on  = LBState (ModuleT Bool LB) -> ModuleT Bool LB ()
forall (m :: * -> *). MonadLBState m => LBState m -> m ()
writeMS Bool
LBState (ModuleT Bool LB)
True

off :: Spell ()
off :: ModuleT Bool LB ()
off = LBState (ModuleT Bool LB) -> ModuleT Bool LB ()
forall (m :: * -> *). MonadLBState m => LBState m -> m ()
writeMS Bool
LBState (ModuleT Bool LB)
False

args :: [String]
args :: [String]
args = [String
"pipe"]

--
-- | Find the first misspelled word in the input line, and return plausible
-- output.
--
spellingNazi :: String -> String -> IO [String]
spellingNazi :: String -> String -> IO [String]
spellingNazi String
binary String
lin = ([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
1 ([String] -> [String])
-> ([[String]] -> [String]) -> [[String]] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) ((String -> IO [String]) -> [String] -> IO [[String]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO [String]
correct (String -> [String]
words String
lin))
    where correct :: String -> IO [String]
correct String
word = do
            [String]
var <- Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
5 ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> String -> IO [String]
spell String
binary String
word
            [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
var Bool -> Bool -> Bool
|| (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((String -> String) -> String -> String -> Bool
forall a t. Eq a => (t -> a) -> t -> t -> Bool
equating' ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower) String
word) [String]
var
                then []
                else [String
"Did you mean " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
listToStr String
"or" [String]
var String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"?"]
          equating' :: (t -> a) -> t -> t -> Bool
equating' t -> a
f t
x t
y = t -> a
f t
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== t -> a
f t
y
--
-- | Return a list of possible spellings for a word
-- 'String' is a word to check the spelling of.
--
spell :: String -> String -> IO [String]
spell :: String -> String -> IO [String]
spell String
binary String
word = String -> String -> [String] -> IO [String]
spellWithArgs String
binary String
word []

spellWithArgs :: String -> String -> [String] -> IO [String]
spellWithArgs :: String -> String -> [String] -> IO [String]
spellWithArgs String
binary String
word [String]
ex = do
    (ExitCode
_,String
out,String
err) <- String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
binary ([String]
args[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++[String]
ex) String
word
    let o :: [String]
o = [String] -> Maybe [String] -> [String]
forall a. a -> Maybe a -> a
fromMaybe [String
word] (([String] -> Maybe [String]
clean_ ([String] -> Maybe [String])
-> (String -> [String]) -> String -> Maybe [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines) String
out)
        e :: [String]
e = [String] -> Maybe [String] -> [String]
forall a. a -> Maybe a -> a
fromMaybe [String]
e      (([String] -> Maybe [String]
clean_ ([String] -> Maybe [String])
-> (String -> [String]) -> String -> Maybe [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines) String
err)
    [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ case () of {()
_
        | [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
o Bool -> Bool -> Bool
&& [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
e -> []
        | [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
o           -> [String]
e
        | Bool
otherwise        -> [String]
o
    }

--
-- Parse the output of aspell (would probably work for ispell too)
--
clean_ :: [String] -> Maybe [String]
clean_ :: [String] -> Maybe [String]
clean_ ((Char
'@':Char
'(':Char
'#':Char
')':String
_):[String]
rest) = [String] -> Maybe [String]
clean' [String]
rest -- drop header
clean_ [String]
s = [String] -> Maybe [String]
clean' [String]
s                             -- no header for some reason

--
-- Parse rest of aspell output.
--
-- Grammar is:
--      OK          ::=  *
--      Suggestions ::= & <original> <count> <offset>: <miss>, <miss>, ...
--      None        ::= # <original> <offset>
--
clean' :: [String] -> Maybe [String]
clean' :: [String] -> Maybe [String]
clean' ((Char
'*':String
_):[String]
_)    = Maybe [String]
forall a. Maybe a
Nothing                          -- correct spelling
clean' ((Char
'#':String
_):[String]
_)    = [String] -> Maybe [String]
forall a. a -> Maybe a
Just []                          -- no match
clean' ((Char
'&':String
rest):[String]
_) = [String] -> Maybe [String]
forall a. a -> Maybe a
Just ([String] -> Maybe [String]) -> [String] -> Maybe [String]
forall a b. (a -> b) -> a -> b
$ String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
", " (String -> String
clean'' String
rest) -- suggestions
clean' [String]
_              = [String] -> Maybe [String]
forall a. a -> Maybe a
Just []                          -- not sure

clean'' :: String -> String
clean'' :: String -> String
clean'' String
s = String
-> (MatchResult String -> String)
-> Maybe (MatchResult String)
-> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
s MatchResult String -> String
forall a. MatchResult a -> a
mrAfter (String
s String -> String -> Maybe (MatchResult String)
forall source source1 target (m :: * -> *).
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target, MonadFail m) =>
source1 -> source -> m target
=~~ String
pat)
    where pat :: String
pat  = String
"[^:]*: "    -- drop header