content: {-# 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
  