{-# LANGUAGE PatternGuards #-}
-- | DICT (RFC 2229) Lookup Module for lambdabot IRC robot.
-- Tom Moertel <tom@moertel.com>
module Lambdabot.Plugin.Reference.Dict (dictPlugin) where

import Lambdabot.Plugin
import qualified Lambdabot.Plugin.Reference.Dict.DictLookup as Dict
import Lambdabot.Util

import Control.Monad
import Data.List

type Dict = ModuleT () LB

dictPlugin :: Module ()
dictPlugin :: Module ()
dictPlugin = Module ()
forall st. Module st
newModule
    { moduleCmds :: ModuleT () LB [Command (ModuleT () LB)]
moduleCmds = [Command (ModuleT () LB)]
-> ModuleT () LB [Command (ModuleT () LB)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Command (ModuleT () LB)]
 -> ModuleT () LB [Command (ModuleT () LB)])
-> [Command (ModuleT () LB)]
-> ModuleT () LB [Command (ModuleT () LB)]
forall a b. (a -> b) -> a -> b
$
        [ (String -> Command Identity
command "dict-help")
            { help :: Cmd (ModuleT () LB) ()
help = [String] -> Cmd (ModuleT () LB) ()
getHelp []
            , process :: String -> Cmd (ModuleT () LB) ()
process = [String] -> Cmd (ModuleT () LB) ()
getHelp ([String] -> Cmd (ModuleT () LB) ())
-> (String -> [String]) -> String -> Cmd (ModuleT () LB) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words
            }
        ] [Command (ModuleT () LB)]
-> [Command (ModuleT () LB)] -> [Command (ModuleT () LB)]
forall a. [a] -> [a] -> [a]
++
        [ (String -> Command Identity
command String
name)
            { help :: Cmd (ModuleT () LB) ()
help = [String] -> Cmd (ModuleT () LB) ()
getHelp [String
name]
            , process :: String -> Cmd (ModuleT () LB) ()
process = \args :: String
args -> case String -> [String]
parseTerms String
args of
                [] -> [String] -> Cmd (ModuleT () LB) ()
getHelp [String
name]
                [s :: String
s]  -> String -> Cmd (ModuleT () LB) LookupResult
doLookup String
s Cmd (ModuleT () LB) LookupResult
-> (LookupResult -> Cmd (ModuleT () LB) ())
-> Cmd (ModuleT () LB) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LookupResult -> Cmd (ModuleT () LB) ()
sayResult
                _ -> String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say "Sorry, look up one word at a time please."
            }
        | (name :: String
name, (srv :: QueryConfig
srv, db :: String
db, _)) <- [(String, (QueryConfig, String, String))]
dictTable
        , let doLookup :: String -> Cmd (ModuleT () LB) LookupResult
doLookup  = IO LookupResult -> Cmd (ModuleT () LB) LookupResult
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO LookupResult -> Cmd (ModuleT () LB) LookupResult)
-> (String -> IO LookupResult)
-> String
-> Cmd (ModuleT () LB) LookupResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QueryConfig -> String -> String -> IO LookupResult
Dict.simpleDictLookup QueryConfig
srv String
db
              sayResult :: LookupResult -> Cmd (ModuleT () LB) ()
sayResult = String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say (String -> Cmd (ModuleT () LB) ())
-> (LookupResult -> String)
-> LookupResult
-> Cmd (ModuleT () LB) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> (String -> String) -> LookupResult -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ("Error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++) String -> String
forall a. a -> a
id
        ]
    }

-- | Configuration.

dictTable :: [(String, (Dict.QueryConfig, String, String))]
dictTable :: [(String, (QueryConfig, String, String))]
dictTable =
    -- @command     (server  , database,       description)
    [ ("all-dicts", (QueryConfig
dict_org, "*"       ,     "Query all databases on dict.org"))
    , ("bouvier"  , (QueryConfig
dict_org, "bouvier",      "Bouvier's Law Dictionary"))
    , ("cide"     , (QueryConfig
dict_org, "gcide",        "The Collaborative International Dictionary of English"))
    , ("devils"   , (QueryConfig
dict_org, "devil",        "The Devil's Dictionary"))
    , ("easton"   , (QueryConfig
dict_org, "easton",       "Easton's 1897 Bible Dictionary"))
    , ("elements" , (QueryConfig
dict_org, "elements",     "Elements database"))
    , ("foldoc"   , (QueryConfig
dict_org, "foldoc",       "The Free On-line Dictionary of Computing"))
    , ("gazetteer", (QueryConfig
dict_org, "gaz2k-places", "U.S. Gazetteer (2000)"))
    , ("hitchcock", (QueryConfig
dict_org, "hitchcock",    "Hitchcock's Bible Names Dictionary (late 1800's)"))
    , ("jargon"   , (QueryConfig
dict_org, "jargon",       "Jargon File"))
    , ("thesaurus", (QueryConfig
dict_org, "moby-thes",    "Moby Thesaurus II"))
    , ("vera"     , (QueryConfig
dict_org, "vera",         "V.E.R.A.: Virtual Entity of Relevant Acronyms"))
    , ("wn"       , (QueryConfig
dict_org, "wn",           "WordNet (r) 1.7"))
    , ("world02"  , (QueryConfig
dict_org, "world02",      "CIA World Factbook 2002"))
    ]
    where
    dict_org :: QueryConfig
dict_org    = String -> Int -> QueryConfig
Dict.QC "dict.org" 2628

dictNames :: [String]
dictNames :: [String]
dictNames = [String] -> [String]
forall a. Ord a => [a] -> [a]
sort (((String, (QueryConfig, String, String)) -> String)
-> [(String, (QueryConfig, String, String))] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, (QueryConfig, String, String)) -> String
forall a b. (a, b) -> a
fst [(String, (QueryConfig, String, String))]
dictTable)


-- | Print out help.

getHelp :: [String] -> Cmd Dict ()
getHelp :: [String] -> Cmd (ModuleT () LB) ()
getHelp []    = do
    String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say ("I perform dictionary lookups via the following "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
dictNames) String -> String -> String
forall a. [a] -> [a] -> [a]
++ " commands:\n")
    [String] -> Cmd (ModuleT () LB) ()
getHelp [String]
dictNames

getHelp dicts :: [String]
dicts = (String -> Cmd (ModuleT () LB) ())
-> [String] -> Cmd (ModuleT () LB) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say (String -> Cmd (ModuleT () LB) ())
-> (String -> String) -> String -> Cmd (ModuleT () LB) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
gH) [String]
dicts
    where
    gH :: String -> String
gH dict :: String
dict | Just (_, _, descr :: String
descr) <- String
-> [(String, (QueryConfig, String, String))]
-> Maybe (QueryConfig, String, String)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
dict [(String, (QueryConfig, String, String))]
dictTable
            = String -> String
pad String
dict String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
descr

            | Bool
otherwise
            = "There is no dictionary database '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dict String -> String -> String
forall a. [a] -> [a] -> [a]
++ "'."

    pad :: String -> String
pad xs :: String
xs = Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
padWidth (String
xs String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. a -> [a]
repeat '.')
    padWidth :: Int
padWidth = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((String -> Int) -> [String] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
dictNames) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 4


-- | Break a string into dictionary-query terms, handling quoting and
-- escaping along the way.  (This is ugly, and I don't particularly
-- like it.)  Given a string like the following, we want to do the
-- right thing, which is to break it into five query strings:
--
--     firefly "c'est la vie" 'pound cake' 'rock n\' roll' et\ al
--
--     (1) firefly
--     (2) "c'est la vie"
--     (3) 'pound cake'
--     (4) 'rock n\' roll'
--     (5) et\ al

parseTerms :: String -> [String]
parseTerms :: String -> [String]
parseTerms = [String] -> [String]
pW ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words
    where
    pW :: [String] -> [String]
pW []  = []
    pW (w :: String
w@(f :: Char
f:_):ws :: [String]
ws)
        | Char
f Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` "'\"" = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate " " [String]
qws String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String] -> [String]
pW [String]
ws'
        | String -> Char
forall a. [a] -> a
last String
w Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\\' = let (w' :: String
w':rest :: [String]
rest) = [String] -> [String]
pW [String]
ws in String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate " " [String
w, String
w'] String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
rest
        | Bool
otherwise      = String
w String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String] -> [String]
pW [String]
ws
        where
        (qws :: [String]
qws, ws' :: [String]
ws') = case (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break String -> Bool
isCloseQuotedWord (String
wString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
ws) of
            (qws' :: [String]
qws', [])    -> ([String] -> [String]
forall a. [a] -> [a]
init [String]
qws' [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [[String] -> String
forall a. [a] -> a
last [String]
qws' String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
f]], [])
            (qw :: [String]
qw, w' :: String
w':rest :: [String]
rest) -> ([String]
qw [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
w'], [String]
rest)
        isCloseQuotedWord :: String -> Bool
isCloseQuotedWord xs :: String
xs = case String -> String
forall a. [a] -> [a]
reverse String
xs of
            x :: Char
x:y :: Char
y:_ -> Char
f Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
x Bool -> Bool -> Bool
&& Char
y Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\\' -- quote doesn't count if escaped
            x :: Char
x:_   -> Char
f Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
x
            _     -> Bool
False
    pW _ = String -> [String]
forall a. HasCallStack => String -> a
error "DictModule: parseTerms: can't parse"