{-
 An example IRC bot that uses GF (http://gf.digitalgrammars.com/) grammars
 to communicate in natural language. When run, the bot joins #gfbot-testing
 on irc.freenode.net. It responds to these commands:

 !quit 
    Disconnects and exists.
 !echo some text
    Says the given text.
 !say some text
    Parses the given text with the GF grammar in grammars/GFBotEng.gf,
    and uses the same grammar to produce a suitable reply.
    GFBotEng.gf uses the resource grammar library. GFBotEngNoLib.gf
    is a string-based hack that does the same thing without the
    resource grammar, just to illustrate the coverage.
    With the existing grammar, it understands these inputs: 
    "!say does the bear shit in the forest ?"
    "!say is the sky blue ?"
     (the space before the question mark is currently required,
     this is because the GFCC interpreter does not yet handle
     the lexer and unlexer flags)

 To compile, get the darcs version of GF:

 $ darcs get --partial --set-scripts-executable http://www.cs.chalmers.se/Cs/Research/Language-technology/darcs/GF/

 Compile the experimental gfc program:

 $ (cd GF/src && autoconf && ./configure && make gfc)

 Compile the resource grammar library with gfc:

 $ make -C GF/lib/resource-1.0 gf3

 Set GF_LIB_PATH:

 $ export GF_LIB_PATH=$PWD/GF

 Make sure that gfc is in your PATH:

 $ export PATH=$PWD/GF/bin:$PATH

 Compile gfbot:

 $ make

 Run gfbot:

 $ ./gfbot


Example session:

[10:25pm] gfbot joined the chat room.
[10:26pm] bringert: !say does the bear shit in the forest ?
[10:26pm] gfbot: yes ! the bear shits in the forest .
[10:26pm] bringert: !say is the sky blue ?
[10:26pm] gfbot: yes ! the sky is blue .
[10:26pm] bringert: !echo hello
[10:26pm] gfbot: hello
[10:26pm] bringert: !quit
[10:26pm] gfbot left the chat room. (Client Quit)

 The IRC code is based on http://haskell.org/haskellwiki/Roll_your_own_IRC_bot
-}

import Data.Char
import Data.List
import Network
import System.IO
import System.Exit
import Control.Monad.Reader
import Control.Exception
import Text.Printf
import Prelude hiding (catch)

-- GF API for parsing and linearization
import GF.GFCC.API

-- Module generated by GF with Haskell data types for the abstract syntax.
import GSyntax

server = "irc.freenode.org"
port   = 6667
chan   = "#gfbot-testing"
nick   = "gfbot"
name   = "GF tutorial bot"

gfccFile   = "GFBot.gfcc"

-- The 'Net' monad, a wrapper over IO, carrying the bot's immutable state.
type Net = ReaderT Bot IO

data Bot = Bot { socket :: Handle, grammar :: MultiGrammar }


---------------------------------------------------------------------
-- Application-specific command handling

runCommand :: String -> String -> Net ()
runCommand "quit" "" = quit
runCommand "echo" x  = privmsg x
runCommand "say" x   = handleText x
runCommand _ _       = return ()

handleText :: String -> Net ()
handleText i = 
    do rs <- parseInput i
       ls <- asks (languages . grammar)
       case rs of
         [] -> privmsg ("Unable to parse input with " ++ show ls)
         [(l,input)] -> do output <- io $ translate input
                           o <- linearizeOutput l output
                           privmsg o
         _ -> privmsg ("Ambiguous input " ++ show rs)

-- Parses a string as 'Input' with all available languages.
parseInput :: String -> Net [(Language,GInput)]
parseInput s =
    do gr <- asks grammar
       return [(l, fg t) | (l,ts) <- parseAllLang gr "Input" s, t <- ts ]

-- Linearizes an 'Output' value in a given language.
linearizeOutput :: Language -> GOutput -> Net String
linearizeOutput l o = 
    do gr <- asks grammar
       return (linearize gr l (gf o))

translate :: GInput -> IO GOutput
translate (GQuestion x) = return (GAffirmative x)


---------------------------------------------------------------------


-- Set up actions to run on start and end, and run the main loop
main :: IO ()
main = bracket connect disconnect loop
  where
    disconnect = hClose . socket
    loop st    = catch (runReaderT run st) (const $ return ())

-- Connect to the server and return the initial bot state
connect :: IO Bot
connect = 
    do g <- notify (printf "Loading %s" gfccFile) $ 
             file2grammar gfccFile
       h <- notify (printf "Connecting to %s" server) $ do
              h <- connectTo server (PortNumber (fromIntegral port))
              hSetBuffering h NoBuffering
              return h
       return $ Bot { socket = h, grammar = g }
  where
    notify s = bracket_
        (putStr (s ++ " ... ") >> hFlush stdout)
        (putStrLn "done.")

-- We're in the Net monad now, so we've connected successfully
-- Join a channel, and start processing commands
run :: Net ()
run = do
    write "NICK" nick
    write "USER" (nick ++ " 0 * :" ++ name)
    write "JOIN" chan
    asks socket >>= listen

-- Process each line from the server
listen :: Handle -> Net ()
listen h = forever $ do
    s <- init `fmap` io (hGetLine h)
    io (putStrLn s)
    if ping s then pong s else eval (clean s)
  where
    forever a = a >> forever a
    clean     = drop 1 . dropWhile (/= ':') . drop 1
    ping x    = "PING :" `isPrefixOf` x
    pong x    = write "PONG" (':' : drop 6 x)

-- Dispatch a command
eval :: String -> Net ()
eval ('!':rest) = let (c,r) = break isSpace rest in runCommand c (dropWhile isSpace r)
eval _ = return ()

quit :: Net ()
quit = do write "QUIT" ":Exiting"
          io (exitWith ExitSuccess)

-- Send a privmsg to the current chan + server
privmsg :: String -> Net ()
privmsg s = write "PRIVMSG" (chan ++ " :" ++ s)

-- Send a message out to the server we're currently connected to
write :: String -> String -> Net ()
write s t = do
    h <- asks socket
    io $ hPrintf h "%s %s\r\n" s t
    io $ printf    "> %s %s\n" s t

-- Convenience.
io :: IO a -> Net a
io = liftIO