{-# 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 = forall st. Module st
newModule
    { moduleCmds :: ModuleT Bool LB [Command (ModuleT Bool LB)]
moduleCmds = forall (m :: * -> *) a. Monad m => a -> m a
return
        [ (String -> Command Identity
command String
"spell")
            { help :: Cmd (ModuleT Bool LB) ()
help = 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 = 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 = forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
helpStr
            , process :: String -> Cmd (ModuleT Bool LB) ()
process = 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 = forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
helpStr
            , process :: String -> Cmd (ModuleT Bool LB) ()
process = forall a b. a -> b -> a
const (Bool -> Cmd (ModuleT Bool LB) ()
nazi Bool
False)
            }
        ]
    , moduleDefState :: LB Bool
moduleDefState = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

    , contextual :: String -> Cmd (ModuleT Bool LB) ()
contextual = \String
txt -> do
        Bool
alive <- forall (m :: * -> *). MonadLBState m => m (LBState m)
readMS
        String
binary <- forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config String
aspellBinary
        if Bool
alive then forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> String -> IO [String]
spellingNazi String
binary String
txt) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). Monad m => String -> Cmd m ()
say
                 else 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 [] = forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"No word to spell."
doSpell String
s  = do
    String
binary <- forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config String
aspellBinary
    (forall (m :: * -> *). Monad m => String -> Cmd m ()
say forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => [a] -> String
showClean forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
take Int
5) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (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 [] = forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"No phrase to spell."
spellAll String
s  = do
    String
binary <- forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config String
aspellBinary
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> String -> IO [String]
spellingNazi String
binary String
s) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). Monad m => String -> Cmd m ()
say

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

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

off :: Spell ()
off :: Spell ()
off = forall (m :: * -> *). MonadLBState m => LBState m -> m ()
writeMS Bool
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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Int -> [a] -> [a]
take Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) (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 <- forall a. Int -> [a] -> [a]
take Int
5 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> String -> IO [String]
spell String
binary String
word
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
var Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall {a} {t}. Eq a => (t -> a) -> t -> t -> Bool
equating' (forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower) String
word) [String]
var
                then []
                else [String
"Did you mean " forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
listToStr String
"or" [String]
var 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 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]
argsforall a. [a] -> [a] -> [a]
++[String]
ex) String
word
    let o :: [String]
o = forall a. a -> Maybe a -> a
fromMaybe [String
word] (([String] -> Maybe [String]
clean_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines) String
out)
        e :: [String]
e = forall a. a -> Maybe a -> a
fromMaybe [String]
e      (([String] -> Maybe [String]
clean_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines) String
err)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case () of {()
_
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
o Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
e -> []
        | 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]
_)    = forall a. Maybe a
Nothing                          -- correct spelling
clean' ((Char
'#':String
_):[String]
_)    = forall a. a -> Maybe a
Just []                          -- no match
clean' ((Char
'&':String
rest):[String]
_) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
", " (String -> String
clean'' String
rest) -- suggestions
clean' [String]
_              = forall a. a -> Maybe a
Just []                          -- not sure

clean'' :: String -> String
clean'' :: String -> String
clean'' String
s = forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
s forall a. MatchResult a -> a
mrAfter (String
s 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