{-# 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 = newModule
{ moduleCmds = return
[ (command "spell")
{ help = say helpStr
, process = doSpell
}
, (command "spell-all")
{ help = say helpStr
, process = spellAll
}
, (command "nazi-on")
{ privileged = True
, help = say helpStr
, process = const (nazi True)
}
, (command "nazi-off")
{ privileged = True
, help = say helpStr
, process = const (nazi False)
}
]
, moduleDefState = return False
, contextual = \txt -> do
alive <- readMS
binary <- getConfig aspellBinary
if alive then io (spellingNazi binary txt) >>= mapM_ say
else return ()
}
helpStr :: String
helpStr = "spell <word>. Show spelling of word"
doSpell :: [Char] -> Cmd Spell ()
doSpell [] = say "No word to spell."
doSpell s = do
binary <- getConfig aspellBinary
(say . showClean . take 5) =<< (io (spell binary s))
spellAll :: [Char] -> Cmd Spell ()
spellAll [] = say "No phrase to spell."
spellAll s = do
binary <- getConfig aspellBinary
liftIO (spellingNazi binary s) >>= mapM_ say
nazi :: Bool -> Cmd (ModuleT Bool LB) ()
nazi True = lift on >> say "Spelling nazi engaged."
nazi False = lift off >> say "Spelling nazi disengaged."
on :: Spell ()
on = writeMS True
off :: Spell ()
off = writeMS False
args :: [String]
args = ["pipe"]
--
-- | Find the first misspelled word in the input line, and return plausible
-- output.
--
spellingNazi :: String -> String -> IO [String]
spellingNazi binary lin = fmap (take 1 . concat) (mapM correct (words lin))
where correct word = do
var <- take 5 `fmap` spell binary word
return $ if null var || any (equating' (map toLower) word) var
then []
else ["Did you mean " ++ listToStr "or" var ++ "?"]
equating' f x y = f x == f 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 binary word = spellWithArgs binary word []
spellWithArgs :: String -> String -> [String] -> IO [String]
spellWithArgs binary word ex = do
(_,out,err) <- readProcessWithExitCode binary (args++ex) word
let o = fromMaybe [word] ((clean_ . lines) out)
e = fromMaybe e ((clean_ . lines) err)
return $ case () of {_
| null o && null e -> []
| null o -> e
| otherwise -> o
}
--
-- Parse the output of aspell (would probably work for ispell too)
--
clean_ :: [String] -> Maybe [String]
clean_ (('@':'(':'#':')':_):rest) = clean' rest -- drop header
clean_ s = clean' 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' (('*':_):_) = Nothing -- correct spelling
clean' (('#':_):_) = Just [] -- no match
clean' (('&':rest):_) = Just $ splitOn ", " (clean'' rest) -- suggestions
clean' _ = Just [] -- not sure
clean'' :: String -> String
clean'' s = maybe s mrAfter (s =~~ pat)
where pat = "[^:]*: " -- drop header