Cache more aggressively

Cache more aggressively

module CloogleServer

import StdArray
import StdBool
import StdFile
from StdFunc import id, o
import StdList
import StdMisc
import StdOrdList
import StdOverloaded
import StdString
import StdTuple

from TCPIP import :: IPAddress, :: Port, instance toString IPAddress

import Control.Applicative
import Control.Monad
import Data.Error
import qualified Data.Foldable as Foldable
from Data.Foldable import class Foldable
from Data.Func import $, hyperstrict, instance Functor ((->) r), mapSt, seqSt
import Data.Functor
from Data.List import permutations
import Data.Maybe
import Data.Tuple
import System._Posix
import System.CommandLine
import System.Time
from Text import class Text(concat,toLowerCase), instance Text String, <+
import Text.GenJSON

import Cloogle
import Type
import CloogleDB
import Search

import SimpleTCPServer
import Cache
import Memory

MAX_RESULTS        :== 15
CACHE_PREFETCH     :== 5
CACHE_NS_THRESHOLD :== 20000000

:: RequestCacheKey
	= { c_unify            :: Maybe Type
	  , c_name             :: Maybe String
	  , c_className        :: Maybe String
	  , c_typeName         :: Maybe String
	  , c_using            :: Maybe [String]
	  , c_modules          :: Maybe [String]
	  , c_libraries        :: Maybe [String]
	  , c_include_builtins :: Bool
	  , c_include_core     :: Bool
	  , c_include_apps     :: Bool
	  , c_page             :: Int
	  }

derive JSONEncode Kind, Type, RequestCacheKey, TypeRestriction
derive JSONDecode Kind, Type, RequestCacheKey, TypeRestriction
instance toString RequestCacheKey
where toString rck = toString $ toJSON rck

toRequestCacheKey :: !*CloogleDB !Request -> *(!RequestCacheKey, !*CloogleDB)
toRequestCacheKey db r
# (alwaysUnique,db) = alwaysUniquePredicate db
# (allsyns,db) = allTypeSynonyms db
= (
	{ c_unify            = snd <$>
		prepare_unification True alwaysUnique allsyns <$>
		(parseType o fromString =<< r.unify)
	, c_name             = toLowerCase <$> r.Request.name
	, c_className        = r.className
	, c_typeName         = r.typeName
	, c_using            = r.using
	, c_modules          = sort <$> r.modules
	, c_libraries        = sort <$> r.libraries
	, c_include_builtins = fromMaybe DEFAULT_INCLUDE_BUILTINS r.include_builtins
	, c_include_core     = fromMaybe DEFAULT_INCLUDE_CORE r.include_core
	, c_include_apps     = fromMaybe DEFAULT_INCLUDE_APPS r.include_apps
	, c_page             = fromMaybe 0 r.page
	}, db)
fromRequestCacheKey :: RequestCacheKey -> Request
fromRequestCacheKey k =
	{ unify            = concat <$> print False <$> unprepare <$> k.c_unify
	, name             = k.c_name
	, className        = k.c_className
	, typeName         = k.c_typeName
	, using            = k.c_using
	, modules          = k.c_modules
	, libraries        = k.c_libraries
	, include_builtins = Just k.c_include_builtins
	, include_core     = Just k.c_include_core
	, include_apps     = Just k.c_include_apps
	, page             = Just k.c_page
	}
where
	unprepare :: !Type -> Type
	unprepare (Type t ts) = Type t (map unprepare ts)
	unprepare (Func is t tc) = Func (map unprepare is) (unprepare t) (map unprepareTR tc)
	unprepare (Var tv) = Var (tv % (1,size tv-1))
	unprepare (Cons v ts) = Cons (v % (1,size v-1)) (map unprepare ts)
	unprepare (Uniq t) = Uniq (unprepare t)
	unprepare (Forall ts t tc) = Forall (map unprepare ts) (unprepare t) (map unprepareTR tc)
	unprepare (Arrow mt) = Arrow (unprepare <$> mt)

	unprepareTR :: !TypeRestriction -> TypeRestriction
	unprepareTR (Instance c ts) = Instance c (map unprepare ts)
	unprepareTR (Derivation g t) = Derivation g (unprepare t)

:: Options =
	{ port         :: Int
	, help         :: Bool
	, reload_cache :: Bool
	}

instance zero Options where zero = {port=31215, help=False, reload_cache=False}

parseOptions :: Options [String] -> MaybeErrorString Options
parseOptions opt [] = Ok opt
parseOptions opt ["-p":p:rest] = case (toInt p, p) of
	(0, "0") -> Error "Cannot use port 0"
	(0, p)   -> Error $ "'" <+ p <+ "' is not an integer"
	(p, _)   -> parseOptions {Options | opt & port=p} rest
parseOptions opt ["-h":rest] = parseOptions {opt & help=True} rest
parseOptions opt ["--help":rest] = parseOptions {opt & help=True} rest
parseOptions opt ["--reload-cache":rest] = parseOptions {opt & reload_cache=True} rest
parseOptions opt [arg:_] = Error $ "Unknown option '" <+ arg <+ "'"

Start w
# (cmdline, w) = getCommandLine w
# opts = parseOptions zero (tl cmdline)
| isError opts
	# (io,w) = stdio w
	# io = io <<< fromError opts <<< "\n"
	# (_,w) = fclose io w
	= w
# opts = fromOk opts
| opts.help = help (hd cmdline) w
# w = disableSwap w
#! (_,f,w) = fopen "types.json" FReadText w
#! (db,f) = openDB f
#! (ok,db) = isJustU db
| not ok
	# (io,w) = stdio w
	# io = io <<< "Could not open database\n"
	# (_,w) = fclose io w
	= w
#! db = hyperstrict (fromJust db)
#! (db,w) = if opts.reload_cache (doInBackground reloadCache) id (db,w)
#! (_,w) = fclose f w
= serve
	{ handler           = handle
	, logger            = Just log
	, port              = opts.Options.port
	, connect_timeout   = Just 3600000 // 1h
	, keepalive_timeout = Just 5000    // 5s
	} db w
where
	help :: String *World -> *World
	help pgm w
	# (io, w) = stdio w
	# io = io <<< "Usage: " <<< pgm <<< " [--reload-cache] [-p <port>] [-h] [--help]\n"
	= snd $ fclose io w

	disableSwap :: *World -> *World
	disableSwap w
	# (ok,w) = mlockall (MCL_CURRENT bitor MCL_FUTURE) w
	| ok = w
	# (err,w) = errno w
	# (io,w) = stdio w
	# io = io <<< "Could not lock memory (" <<< err <<< "); process may get swapped out\n"
	= snd $ fclose io w

	handle :: !(Maybe Request) !*CloogleDB !*World -> *(!Response, !(!Maybe CacheKey, !MicroSeconds), !*CloogleDB, !*World)
	handle Nothing db w = (err InvalidInput "Couldn't parse input", (Nothing,0), db, w)
	handle (Just request=:{unify,name,page}) db w
		#! (start,w) = nsTime w
		//Check cache
		#! (key,db) = toRequestCacheKey db request
		#! (mbResponse, w) = readCache key w
		| isJust mbResponse
			# r = fromJust mbResponse
			= respond start Nothing {r & return = if (r.return == 0) 1 r.return} db w
		| isJust name && size (fromJust name) > 40
			= respond start Nothing (err InvalidName "Function name too long") db w
		| isJust name && any isSpace (fromString $ fromJust name)
			= respond start Nothing (err InvalidName "Name cannot contain spaces") db w
		| isJust unify && isNothing (parseType $ fromString $ fromJust unify)
			= respond start Nothing (err InvalidType "Couldn't parse type") db w
		| all isNothing [unify,name,request.typeName,request.className] && isNothing request.using
			= respond start Nothing (err InvalidInput "Empty query") db w
		// Results
		#! drop_n = fromJust (page <|> pure 0) * MAX_RESULTS
		#! (res,db) = search request db
		#! results = drop drop_n res
		#! more = max 0 (length results - MAX_RESULTS)
		// Suggestions
		#! (suggestions,db) = case unify >>= parseType o fromString of
			Just t -> suggs name t db
			Nothing -> (Nothing, db)
		#! (db,w) = seqSt
			(\(req,res) (db,w) -> let (k,db`) = toRequestCacheKey db req in (db`,cachePages k CACHE_PREFETCH 0 zero res w))
			(fromMaybe [] suggestions)
			(db,w)
		#! suggestions
			= sortBy (\a b -> snd a > snd b) <$>
			  filter ((<) (length results) o snd) <$>
			  map (appSnd length) <$> suggestions
		#! (results,nextpages) = splitAt MAX_RESULTS results
		// Response
		#! response = if (isEmpty results)
			(err NoResults "No results")
			{ zero
		    & data           = results
		    , more_available = Just more
		    , suggestions    = suggestions
		    }
		// Save page prefetches
		#! w = cachePages key CACHE_PREFETCH 1 response nextpages w
		// Save cache file
		= respond start (Just key) response db w
	where
		respond :: !Timespec !(Maybe RequestCacheKey) !Response !*CloogleDB !*World ->
			*(!Response, !(!Maybe CacheKey, !MicroSeconds), !*CloogleDB, !*World)
		respond start key r db w
		#! (end,w) = nsTime w
		#! duration = 1000000000 * (end.tv_sec - start.tv_sec) + end.tv_nsec - start.tv_nsec
		#! cache = duration > CACHE_NS_THRESHOLD
		= (r, (if cache (cacheKey <$> key) Nothing, duration / 1000), db, case (cache,key) of
			(True,Just k) -> writeCache LongTerm k r w
			_             -> w)

		cachePages :: !RequestCacheKey !Int !Int !Response ![Result] !*World -> *World
		cachePages key _ _  _ [] w = w
		cachePages key 0 _  _ _  w = w
		cachePages key npages i response results w
		# w = writeCache Brief req` resp` w
		= cachePages key (npages - 1) (i + 1) response keep w
		where
			req` = { key & c_page = key.c_page + i }
			resp` =
				{ response
				& more_available = Just $ max 0 (length results - MAX_RESULTS)
				, data = give
				}
			(give,keep) = splitAt MAX_RESULTS results

	suggs :: !(Maybe String) !Type !*CloogleDB -> *(Maybe [(Request, [Result])], *CloogleDB)
	suggs n (Func is r cc) db | length is < 3
	= appFst Just $ mapSt (\r -> appFst (tuple r) o search r o resetDB) reqs db
	where
		reqs = [{zero & name=n, unify=Just $ concat $ print False $ Func is` r cc}
			\\ is` <- permutations is | is` <> is]
	suggs _ _ db = (Nothing, db)

	reloadCache :: !*(!*CloogleDB, !*World) -> *(!*CloogleDB, !*World)
	reloadCache (db,w)
	# (ks,w) = allCacheKeys LongTerm w
	= loop ks db w
	where
		loop :: ![RequestCacheKey] !*CloogleDB !*World -> *(!*CloogleDB, !*World)
		loop [] db w = (db,w)
		loop [k:ks] db w
		# w = removeFromCache LongTerm k w
		# (_,_,db,w) = handle (Just $ fromRequestCacheKey k) db w
		# db = resetDB db
		= loop ks db w

	doInBackground :: (*a -> *a) *a -> *a
	doInBackground f w
	#! (pid,w) = fork w
	| pid  < 0 = abort "fork failed\n"
	| pid  > 0 = w // Parent: return directly
	| pid == 0 = snd $ exit 0 $ f w // Child: do function

:: LogMemory =
	{ mem_ip         :: IPAddress
	, mem_time_start :: Tm
	, mem_time_end   :: Tm
	, mem_request    :: Maybe Request
	}

instance zero LogMemory
where
	zero =
		{ mem_ip         = undef
		, mem_time_start = undef
		, mem_time_end   = undef
		, mem_request    = undef
		}

:: MicroSeconds :== Int

:: LogMessage` :== LogMessage (Maybe Request) Response (Maybe CacheKey, MicroSeconds)

:: LogEntry =
	{ ip            :: String
	, time_start    :: (String, Int)
	, time_end      :: (String, Int)
	, microseconds  :: Int
	, request       :: Maybe Request
	, cachekey      :: Maybe String
	, response_code :: Int
	, results       :: Int
	}

derive JSONEncode LogEntry

log :: LogMessage` (Maybe LogMemory) *World -> *(Maybe LogMemory, *World)
log msg mem w
# mem     = fromJust (mem <|> pure zero)
# (mem,w) = updateMemory msg mem w
| not needslog = (Just mem, w)
# (io,w)  = stdio w
# io      = io <<< toString (toJSON $ makeLogEntry msg mem) <<< "\n"
= (Just mem, snd (fclose io w))
where
	needslog = case msg of (Sent _ _) = True; _ = False

	updateMemory :: LogMessage` LogMemory *World -> *(LogMemory, *World)
	updateMemory (Connected ip) s w = ({s & mem_ip=ip}, w)
	updateMemory (Received r)   s w
	# (t,w) = localTime w
	= ({s & mem_time_start=t, mem_request=r}, w)
	updateMemory (Sent _ _)     s w
	# (t,w) = localTime w
	= ({s & mem_time_end=t}, w)
	updateMemory _                   s w = (s,w)

	makeLogEntry :: LogMessage` LogMemory -> LogEntry
	makeLogEntry (Sent response (ck,us)) mem =
		{ ip            = toString mem.mem_ip
		, time_start    = (toString mem.mem_time_start, toInt $ timeGm mem.mem_time_start)
		, time_end      = (toString mem.mem_time_end, toInt $ timeGm mem.mem_time_end)
		, microseconds  = us
		, request       = mem.mem_request
		, cachekey      = ck
		, response_code = response.return
		, results       = length response.data
		}

err :: CloogleError String -> Response
err c m = { return         = toInt c
          , data           = []
          , msg            = m
          , more_available = Nothing
          , suggestions    = Nothing
          }

module CloogleServer

import StdArray
import StdBool
import StdFile
from StdFunc import id, o
import StdList
import StdMisc
import StdOrdList
import StdOverloaded
import StdString
import StdTuple

from TCPIP import :: IPAddress, :: Port, instance toString IPAddress

import Control.Applicative
import Control.Monad
import Data.Error
import qualified Data.Foldable as Foldable
from Data.Foldable import class Foldable
from Data.Func import $, hyperstrict, instance Functor ((->) r), mapSt, seqSt
import Data.Functor
from Data.List import permutations
import Data.Maybe
import Data.Tuple
import System._Posix
import System.CommandLine
import System.Time
from Text import class Text(concat,toLowerCase), instance Text String, <+
import Text.GenJSON

import Cloogle
import Type
import CloogleDB
import Search

import SimpleTCPServer
import Cache
import Memory

MAX_RESULTS        :== 15
CACHE_PREFETCH     :== 5
CACHE_NS_THRESHOLD :== 40000000

:: RequestCacheKey
	= { c_unify            :: Maybe Type
	  , c_name             :: Maybe String
	  , c_className        :: Maybe String
	  , c_typeName         :: Maybe String
	  , c_using            :: Maybe [String]
	  , c_modules          :: Maybe [String]
	  , c_libraries        :: Maybe [String]
	  , c_include_builtins :: Bool
	  , c_include_core     :: Bool
	  , c_include_apps     :: Bool
	  , c_page             :: Int
	  }

derive JSONEncode Kind, Type, RequestCacheKey, TypeRestriction
derive JSONDecode Kind, Type, RequestCacheKey, TypeRestriction
instance toString RequestCacheKey
where toString rck = toString $ toJSON rck

toRequestCacheKey :: !*CloogleDB !Request -> *(!RequestCacheKey, !*CloogleDB)
toRequestCacheKey db r
# (alwaysUnique,db) = alwaysUniquePredicate db
# (allsyns,db) = allTypeSynonyms db
= (
	{ c_unify            = snd <$>
		prepare_unification True alwaysUnique allsyns <$>
		(parseType o fromString =<< r.unify)
	, c_name             = toLowerCase <$> r.Request.name
	, c_className        = r.className
	, c_typeName         = r.typeName
	, c_using            = r.using
	, c_modules          = sort <$> r.modules
	, c_libraries        = sort <$> r.libraries
	, c_include_builtins = fromMaybe DEFAULT_INCLUDE_BUILTINS r.include_builtins
	, c_include_core     = fromMaybe DEFAULT_INCLUDE_CORE r.include_core
	, c_include_apps     = fromMaybe DEFAULT_INCLUDE_APPS r.include_apps
	, c_page             = fromMaybe 0 r.page
	}, db)
fromRequestCacheKey :: RequestCacheKey -> Request
fromRequestCacheKey k =
	{ unify            = concat <$> print False <$> unprepare <$> k.c_unify
	, name             = k.c_name
	, className        = k.c_className
	, typeName         = k.c_typeName
	, using            = k.c_using
	, modules          = k.c_modules
	, libraries        = k.c_libraries
	, include_builtins = Just k.c_include_builtins
	, include_core     = Just k.c_include_core
	, include_apps     = Just k.c_include_apps
	, page             = Just k.c_page
	}
where
	unprepare :: !Type -> Type
	unprepare (Type t ts) = Type t (map unprepare ts)
	unprepare (Func is t tc) = Func (map unprepare is) (unprepare t) (map unprepareTR tc)
	unprepare (Var tv) = Var (tv % (1,size tv-1))
	unprepare (Cons v ts) = Cons (v % (1,size v-1)) (map unprepare ts)
	unprepare (Uniq t) = Uniq (unprepare t)
	unprepare (Forall ts t tc) = Forall (map unprepare ts) (unprepare t) (map unprepareTR tc)
	unprepare (Arrow mt) = Arrow (unprepare <$> mt)

	unprepareTR :: !TypeRestriction -> TypeRestriction
	unprepareTR (Instance c ts) = Instance c (map unprepare ts)
	unprepareTR (Derivation g t) = Derivation g (unprepare t)

:: Options =
	{ port         :: Int
	, help         :: Bool
	, reload_cache :: Bool
	}

instance zero Options where zero = {port=31215, help=False, reload_cache=False}

parseOptions :: Options [String] -> MaybeErrorString Options
parseOptions opt [] = Ok opt
parseOptions opt ["-p":p:rest] = case (toInt p, p) of
	(0, "0") -> Error "Cannot use port 0"
	(0, p)   -> Error $ "'" <+ p <+ "' is not an integer"
	(p, _)   -> parseOptions {Options | opt & port=p} rest
parseOptions opt ["-h":rest] = parseOptions {opt & help=True} rest
parseOptions opt ["--help":rest] = parseOptions {opt & help=True} rest
parseOptions opt ["--reload-cache":rest] = parseOptions {opt & reload_cache=True} rest
parseOptions opt [arg:_] = Error $ "Unknown option '" <+ arg <+ "'"

Start w
# (cmdline, w) = getCommandLine w
# opts = parseOptions zero (tl cmdline)
| isError opts
	# (io,w) = stdio w
	# io = io <<< fromError opts <<< "\n"
	# (_,w) = fclose io w
	= w
# opts = fromOk opts
| opts.help = help (hd cmdline) w
# w = disableSwap w
#! (_,f,w) = fopen "types.json" FReadText w
#! (db,f) = openDB f
#! (ok,db) = isJustU db
| not ok
	# (io,w) = stdio w
	# io = io <<< "Could not open database\n"
	# (_,w) = fclose io w
	= w
#! db = hyperstrict (fromJust db)
#! (db,w) = if opts.reload_cache (doInBackground reloadCache) id (db,w)
#! (_,w) = fclose f w
= serve
	{ handler           = handle
	, logger            = Just log
	, port              = opts.Options.port
	, connect_timeout   = Just 3600000 // 1h
	, keepalive_timeout = Just 5000    // 5s
	} db w
where
	help :: String *World -> *World
	help pgm w
	# (io, w) = stdio w
	# io = io <<< "Usage: " <<< pgm <<< " [--reload-cache] [-p <port>] [-h] [--help]\n"
	= snd $ fclose io w

	disableSwap :: *World -> *World
	disableSwap w
	# (ok,w) = mlockall (MCL_CURRENT bitor MCL_FUTURE) w
	| ok = w
	# (err,w) = errno w
	# (io,w) = stdio w
	# io = io <<< "Could not lock memory (" <<< err <<< "); process may get swapped out\n"
	= snd $ fclose io w

	handle :: !(Maybe Request) !*CloogleDB !*World -> *(!Response, !(!Maybe CacheKey, !MicroSeconds), !*CloogleDB, !*World)
	handle Nothing db w = (err InvalidInput "Couldn't parse input", (Nothing,0), db, w)
	handle (Just request=:{unify,name,page}) db w
		#! (start,w) = nsTime w
		//Check cache
		#! (key,db) = toRequestCacheKey db request
		#! (mbResponse, w) = readCache key w
		| isJust mbResponse
			# r = fromJust mbResponse
			= respond start Nothing {r & return = if (r.return == 0) 1 r.return} db w
		| isJust name && size (fromJust name) > 40
			= respond start Nothing (err InvalidName "Function name too long") db w
		| isJust name && any isSpace (fromString $ fromJust name)
			= respond start Nothing (err InvalidName "Name cannot contain spaces") db w
		| isJust unify && isNothing (parseType $ fromString $ fromJust unify)
			= respond start Nothing (err InvalidType "Couldn't parse type") db w
		| all isNothing [unify,name,request.typeName,request.className] && isNothing request.using
			= respond start Nothing (err InvalidInput "Empty query") db w
		// Results
		#! drop_n = fromJust (page <|> pure 0) * MAX_RESULTS
		#! (res,db) = search request db
		#! results = drop drop_n res
		#! more = max 0 (length results - MAX_RESULTS)
		// Suggestions
		#! (suggestions,db) = case unify >>= parseType o fromString of
			Just t -> suggs name t db
			Nothing -> (Nothing, db)
		#! (db,w) = seqSt
			(\(req,res) (db,w) -> let (k,db`) = toRequestCacheKey db req in (db`,cachePages k CACHE_PREFETCH 0 zero res w))
			(fromMaybe [] suggestions)
			(db,w)
		#! suggestions
			= sortBy (\a b -> snd a > snd b) <$>
			  filter ((<) (length results) o snd) <$>
			  map (appSnd length) <$> suggestions
		#! (results,nextpages) = splitAt MAX_RESULTS results
		// Response
		#! response = if (isEmpty results)
			(err NoResults "No results")
			{ zero
		    & data           = results
		    , more_available = Just more
		    , suggestions    = suggestions
		    }
		// Save page prefetches
		#! w = cachePages key CACHE_PREFETCH 1 response nextpages w
		// Save cache file
		= respond start (Just key) response db w
	where
		respond :: !Timespec !(Maybe RequestCacheKey) !Response !*CloogleDB !*World ->
			*(!Response, !(!Maybe CacheKey, !MicroSeconds), !*CloogleDB, !*World)
		respond start key r db w
		#! (end,w) = nsTime w
		#! duration = 1000000000 * (end.tv_sec - start.tv_sec) + end.tv_nsec - start.tv_nsec
		#! cache = duration > CACHE_NS_THRESHOLD
		= (r, (if cache (cacheKey <$> key) Nothing, duration / 1000), db, case (cache,key) of
			(True,Just k) -> writeCache LongTerm k r w
			_             -> w)

		cachePages :: !RequestCacheKey !Int !Int !Response ![Result] !*World -> *World
		cachePages key _ _  _ [] w = w
		cachePages key 0 _  _ _  w = w
		cachePages key npages i response results w
		# w = writeCache Brief req` resp` w
		= cachePages key (npages - 1) (i + 1) response keep w
		where
			req` = { key & c_page = key.c_page + i }
			resp` =
				{ response
				& more_available = Just $ max 0 (length results - MAX_RESULTS)
				, data = give
				}
			(give,keep) = splitAt MAX_RESULTS results

	suggs :: !(Maybe String) !Type !*CloogleDB -> *(Maybe [(Request, [Result])], *CloogleDB)
	suggs n (Func is r cc) db | length is < 3
	= appFst Just $ mapSt (\r -> appFst (tuple r) o search r o resetDB) reqs db
	where
		reqs = [{zero & name=n, unify=Just $ concat $ print False $ Func is` r cc}
			\\ is` <- permutations is | is` <> is]
	suggs _ _ db = (Nothing, db)

	reloadCache :: !*(!*CloogleDB, !*World) -> *(!*CloogleDB, !*World)
	reloadCache (db,w)
	# (ks,w) = allCacheKeys LongTerm w
	= loop ks db w
	where
		loop :: ![RequestCacheKey] !*CloogleDB !*World -> *(!*CloogleDB, !*World)
		loop [] db w = (db,w)
		loop [k:ks] db w
		# w = removeFromCache LongTerm k w
		# (_,_,db,w) = handle (Just $ fromRequestCacheKey k) db w
		# db = resetDB db
		= loop ks db w

	doInBackground :: (*a -> *a) *a -> *a
	doInBackground f w
	#! (pid,w) = fork w
	| pid  < 0 = abort "fork failed\n"
	| pid  > 0 = w // Parent: return directly
	| pid == 0 = snd $ exit 0 $ f w // Child: do function

:: LogMemory =
	{ mem_ip         :: IPAddress
	, mem_time_start :: Tm
	, mem_time_end   :: Tm
	, mem_request    :: Maybe Request
	}

instance zero LogMemory
where
	zero =
		{ mem_ip         = undef
		, mem_time_start = undef
		, mem_time_end   = undef
		, mem_request    = undef
		}

:: MicroSeconds :== Int

:: LogMessage` :== LogMessage (Maybe Request) Response (Maybe CacheKey, MicroSeconds)

:: LogEntry =
	{ ip            :: String
	, time_start    :: (String, Int)
	, time_end      :: (String, Int)
	, microseconds  :: Int
	, request       :: Maybe Request
	, cachekey      :: Maybe String
	, response_code :: Int
	, results       :: Int
	}

derive JSONEncode LogEntry

log :: LogMessage` (Maybe LogMemory) *World -> *(Maybe LogMemory, *World)
log msg mem w
# mem     = fromJust (mem <|> pure zero)
# (mem,w) = updateMemory msg mem w
| not needslog = (Just mem, w)
# (io,w)  = stdio w
# io      = io <<< toString (toJSON $ makeLogEntry msg mem) <<< "\n"
= (Just mem, snd (fclose io w))
where
	needslog = case msg of (Sent _ _) = True; _ = False

	updateMemory :: LogMessage` LogMemory *World -> *(LogMemory, *World)
	updateMemory (Connected ip) s w = ({s & mem_ip=ip}, w)
	updateMemory (Received r)   s w
	# (t,w) = localTime w
	= ({s & mem_time_start=t, mem_request=r}, w)
	updateMemory (Sent _ _)     s w
	# (t,w) = localTime w
	= ({s & mem_time_end=t}, w)
	updateMemory _                   s w = (s,w)

	makeLogEntry :: LogMessage` LogMemory -> LogEntry
	makeLogEntry (Sent response (ck,us)) mem =
		{ ip            = toString mem.mem_ip
		, time_start    = (toString mem.mem_time_start, toInt $ timeGm mem.mem_time_start)
		, time_end      = (toString mem.mem_time_end, toInt $ timeGm mem.mem_time_end)
		, microseconds  = us
		, request       = mem.mem_request
		, cachekey      = ck
		, response_code = response.return
		, results       = length response.data
		}

err :: CloogleError String -> Response
err c m = { return         = toInt c
          , data           = []
          , msg            = m
          , more_available = Nothing
          , suggestions    = Nothing
          }


Add some ABC documentation

Add some ABC documentation

implementation module BuiltinABCInstructions

import _SystemArray
import StdList
import StdMisc

import Text

import Cloogle

import CloogleDB

builtin_abc_instructions :: [ABCInstructionEntry]
builtin_abc_instructions =
	[ i_create
	: arith_instructions ++
	  stack_operations ++
	  branches ++
	  miscellaneous ++
	  directives ++
	  [{zero & aie_instruction=i} \\ i <- other_instructions]
	]

instance zero ABCInstructionEntry
where
	zero =
		{ aie_instruction = undef
		, aie_arguments   = []
		, aie_description = "There is no documentation for this ABC instruction yet."
		}

LABEL    :== ABCArgument ABCTypeLabel        False
LABEL_   :== ABCArgument ABCTypeLabel        True
A_OFFSET :== ABCArgument ABCTypeAStackOffset False
B_OFFSET :== ABCArgument ABCTypeBStackOffset False
STRING   :== ABCArgument ABCTypeString       False
STRING_  :== ABCArgument ABCTypeString       True
BOOL     :== ABCArgument ABCTypeBool         False
BOOL_    :== ABCArgument ABCTypeBool         True
CHAR     :== ABCArgument ABCTypeChar         False
CHAR_    :== ABCArgument ABCTypeChar         True
INT      :== ABCArgument ABCTypeInt          False
INT_     :== ABCArgument ABCTypeInt          True
REAL     :== ABCArgument ABCTypeReal         False
REAL_    :== ABCArgument ABCTypeReal         True

i_create :: ABCInstructionEntry
i_create =
	{ zero
	& aie_instruction = "create"
	, aie_description = "Creates a new empty node and pushes its address to the A-stack."
	}

arith_instructions :: [ABCInstructionEntry]
arith_instructions =
	[ arith1 "absR"    "Real" "absolute value"
	, arith1 "acosR"   "Real" "arccosine"
	, arith1 "asinR"   "Real" "arcsine"
	, arith1 "atanR"   "Real" "arctangent"
	, arith1 "cosR"    "Real" "cosine"
	, arith1 "entierR" "Real" "(Int) entier (floor)"
	, arith1 "expR"    "Real" "exponential function (e^r)"
	, arith1 "lnR"     "Real" "natural logarithm"
	, arith1 "log10R"  "Real" "base-10 logarithm"
	, arith1 "notB"    "Bool" "logical negation"
	, arith1 "sinR"    "Real" "sine"
	, arith1 "sqrtR"   "Real" "square root"
	, arith1 "tanR"    "Real" "tangent"

	, op1 "decI" "Int"  "Decrements"
	, op1 "incI" "Int"  "Increments"
	, op1 "negI" "Int"  "Negates"
	, op1 "negR" "Real" "Negates"
	, op1 "not%" "Int"  "Bitwise negates"

	, op2 "addI"    "Int"  "Sums"
	, op2 "addR"    "Real" "Sums"
	, op2 "andB"    "Bool" "Logically conjuncts"
	, op2 "and%"    "Int"  "Bitwise conjuncts"
	, op2 "divI"    "Int"  "Divides"
	, op2 "divR"    "Real" "Divides"
	, op2 "eqB"     "Bool" "Checks equality on"
	, op2 "eqC"     "Char" "Checks equality on"
	, op2 "eqI"     "Int"  "Checks equality on"
	, op2 "eqR"     "Real" "Checks equality on"
	, op2 "gtC"     "Char" "Checks greater-than on"
	, op2 "gtI"     "Int"  "Checks greater-than on"
	, op2 "gtR"     "Real" "Checks greater-than on"
	, op2 "ltC"     "Char" "Checks less-than on"
	, op2 "ltI"     "Int"  "Checks less-than on"
	, op2 "ltR"     "Real" "Checks less-than on"
	, op2 "mulI"    "Int"  "Multiplies"
	, op2 "mulR"    "Real" "Multiplies"
	, op2 "orB"     "Bool" "Logically disjuncts"
	, op2 "or%"     "Int"  "Bitwise disjuncts"
	, op2 "powR"    "Real" "Raises to the power on"
	, op2 "remI"    "Int"  "Computes the remainder after division of"
	, op2 "rotl%"   "Int"  "Bitwise left-rotate on"
	, op2 "rotr%"   "Int"  "Bitwise right-rotate on"
	, op2 "shiftl%" "Int"  "Bitwise left-shift on"
	, op2 "shiftr%" "Int"  "Bitwise right-shift on"
	, op2 "subI"    "Int"  "Subtracts"
	, op2 "subR"    "Real" "Subtracts"
	, op2 "xor%"    "Int"  "Bitwise XOR on"

	, eq_arg "Bool" BOOL 'A'
	, eq_arg "Bool" BOOL 'B'
	, eq_arg "Char" CHAR 'A'
	, eq_arg "Char" CHAR 'B'
	, eq_arg "Int"  INT  'A'
	, eq_arg "Int"  INT  'B'
	, eq_arg "Real" REAL 'A'
	, eq_arg "Real" REAL 'B'

	, convert "CtoI"  "Char" "Int"
	, convert "CtoAC" "Char" "String"
	, convert "ItoC"  "Int"  "Char"
	, convert "ItoR"  "Int"  "Real"
	, convert "RtoI"  "Real" "Int"
	]
where
	arith1 :: !String !String !String -> ABCInstructionEntry
	arith1 instr type description =
		{ zero
		& aie_instruction = instr
		, aie_description = "Computes the " + description + " of the " + type + " on top of the B-stack."
		}

	op1 :: !String !String !String -> ABCInstructionEntry
	op1 instr type description =
		{ zero
		& aie_instruction = instr
		, aie_description = description + " the " + type + " on top of the B-stack."
		}

	op2 :: !String !String !String -> ABCInstructionEntry
	op2 instr type description =
		{ zero
		& aie_instruction = instr
		, aie_description = description + " the two " + type + "s on top of the B-stack."
		}

	eq_arg :: !String !ABCArgument !Char -> ABCInstructionEntry
	eq_arg type arg stack =
		{ zero
		& aie_instruction = {'e','q',type.[0],'_',toLower stack}
		, aie_arguments   = [if (stack == 'A') A_OFFSET B_OFFSET, arg]
		, aie_description = "Checks equality between the " + {stack} + "-stack element and the second argument."
		}

	convert :: !String !String !String -> ABCInstructionEntry
	convert instr fr to =
		{ zero
		& aie_instruction = instr
		, aie_description = "Converts the " + fr + " on top of the B-stack to " + to + "."
		}

stack_operations :: [ABCInstructionEntry]
stack_operations =
	[ push    "Bool" BOOL
	, push    "Char" CHAR
	, push    "Int"  INT
	, push    "Real" REAL
	, push_a  "Bool"
	, push_a  "Char"
	, push_a  "Int"
	, push_a  "Real"
	, build   "Bool" BOOL
	, build   "Char" CHAR
	, build   "Int"  INT
	, build   "Real" REAL
	, build_b "Bool"
	, build_b "Char"
	, build_b "Int"
	, build_b "Real"
	, i_pop_a
	, i_pop_b
	, i_push_a
	, i_push_b
	]
where
	push :: !String !ABCArgument -> ABCInstructionEntry
	push type arg =
		{ zero
		& aie_instruction = "push" + {type.[0]}
		, aie_arguments   = [arg]
		, aie_description = "Pushes the " + type + " argument to the B-stack."
		}

	push_a :: !String -> ABCInstructionEntry
	push_a type =
		{ zero
		& aie_instruction = "push" + {type.[0]} + "_a"
		, aie_arguments   = [INT]
		, aie_description = "Pushes the " + type + " from the nth position on the A-stack to the B-stack."
		}

	build :: !String !ABCArgument -> ABCInstructionEntry
	build type arg =
		{ zero
		& aie_instruction = "build" + {type.[0]}
		, aie_arguments   = [arg]
		, aie_description = "Builds a " + type + "-node with the argument as value on the A-stack."
		}

	build_b :: !String -> ABCInstructionEntry
	build_b type =
		{ zero
		& aie_instruction = "build" + {type.[0]} + "_b"
		, aie_arguments   = [INT]
		, aie_description = "Builds a " + type + "-node with the value on the nth position of the B-stack on the A-stack."
		}

	i_pop_a =
		{ zero
		& aie_instruction = "pop_a"
		, aie_arguments   = [A_OFFSET]
		, aie_description = "Pops elements off the A-stack until the referenced element."
		}
	i_pop_b =
		{ zero
		& aie_instruction = "pop_b"
		, aie_arguments   = [B_OFFSET]
		, aie_description = "Pops elements off the B-stack until the referenced element."
		}
	i_push_a =
		{ zero
		& aie_instruction = "push_a"
		, aie_arguments   = [A_OFFSET]
		, aie_description = "Pushes the referenced A-stack element on the A-stack."
		}
	i_push_b =
		{ zero
		& aie_instruction = "push_b"
		, aie_arguments   = [B_OFFSET]
		, aie_description = "Pushes the referenced B-stack element on the B-stack."
		}

branches :: [ABCInstructionEntry]
branches =
	[ i_jmp
	, i_jmp_false
	, i_jmp_true
	, i_jsr
	, i_jsr_eval
	, i_rtn
	]
where
	i_jmp =
		{ zero
		& aie_instruction = "jmp"
		, aie_arguments   = [LABEL]
		, aie_description = "Unconditional jump to a label."
		}
	i_jmp_false =
		{ zero
		& aie_instruction = "jmp_false"
		, aie_arguments   = [LABEL]
		, aie_description = "Jump to a label if the Bool on top of the B-stack is false."
		}
	i_jmp_true =
		{ zero
		& aie_instruction = "jmp_true"
		, aie_arguments   = [LABEL]
		, aie_description = "Jump to a label if the Bool on top of the B-stack is true."
		}
	i_jsr =
		{ zero
		& aie_instruction = "jsr"
		, aie_arguments   = [LABEL]
		, aie_description = "Subroutine jump to a label. {{`rtn`}} returns to the instruction after this `jsr`."
		}
	i_jsr_eval =
		{ zero
		& aie_instruction = "jsr_eval"
		, aie_arguments   = [A_OFFSET, LABEL]
		, aie_description = "Subroutine jump to evaluate the indicated A-stack element. {{`rtn`}} returns to the instruction after this `jsr_eval`."
		}
	i_rtn =
		{ zero
		& aie_instruction = "rtn"
		, aie_description = "Returns from a subroutine call (e.g. {{`jsr`}})."
		}

miscellaneous :: [ABCInstructionEntry]
miscellaneous =
	[ i_ccall
	, i_centry
	, i_get_node_arity
	, i_halt
	, i_instruction
	, i_load_i
	, i_load_si16
	, i_load_si32
	, i_load_ui8
	, i_no_op
	]
where
	i_ccall =
		{ zero
		& aie_instruction = "ccall"
		, aie_arguments   = [LABEL, STRING]
		, aie_description = join "\n"
			[ "Calls a C function."
			, "Some of this is documented in https://svn.cs.ru.nl/repos/clean-tools/trunk/htoclean/CallingCFromClean.html"
			, "The first argument is the name of the function, the second is the signature."
			, "\n"
			, "The signature has to be of the form `flags?input?sep output(sep state)?`, where"
			, "- sep    can be either `-` or `:`."
			, "- flags  can be `G` and/or `P`. `G` saves the state in global variables and is needed when the called C function will call Clean functions. `P` lets the callee pop arguments (necessary on 32-bit Windows)."
			, "- input  is a number of input argument types (allowed: `IpRrSsAOF`)."
			, "- output is a number of output argument types (allowed: `VIpRrSsAOF`)."
			, "- state  is a carried state that is not passed to the C function, for example used to thread {{`World`}} in ccalls (allowed: `IpRSA`)."
			, "\n"
			, "Input, output and state argument types can be:"
			, "- `I`    for integers"
			, "- `p`    for pointers (e.g. from {{`System.Pointer`}}; on most systems this is identical to `I`)"
			, "- [`Rr`] for reals"
			, "- `S`    for Clean Strings (`{#Char}`)."
			, "- `s`    for the characters of a Clean String (handy to use in conjuction with {{`packString`}})"
			, "- `A`    for A-stack elements (e.g. used for `*World`, a boxed integer under the hood)"
			, "- [`OF`] for function pointers"
			, "- `V`    for `void`, packs the following argument types in a tuple (e.g. `VIR` means `(Int, Real)`)"
			]
		}
	i_centry =
		{ zero
		& aie_instruction = "centry"
		, aie_arguments   = [LABEL, LABEL, STRING]
		, aie_description = join "\n"
			[ "Adds code to call a Clean function from C."
			, "Usually it is not needed to write this instruction yourself."
			, "It is generated with the `foreign export` construct.\n"
			, "The first label is the name of the C function to generate."
			, "The second label is the Clean function to link it to.\n"
			, "The string argument indicates the type."
			, "For more information, see {{`ccall`}}."
			]
		}

	i_get_node_arity =
		{ zero
		& aie_instruction = "get_node_arity"
		, aie_arguments   = [A_OFFSET]
		, aie_description = "Pushes the arity of the descriptor of the referenced A-stack element to the B-stack."
		}

	i_halt =
		{ zero
		& aie_instruction = "halt"
		, aie_description = "Terminates the program immediately."
		}

	i_instruction =
		{ zero
		& aie_instruction = "instruction"
		, aie_arguments   = [INT]
		, aie_description = "Adds the raw argument as a word in the generated object file."
		}

	i_load_i =
		{ zero
		& aie_instruction = "load_i"
		, aie_arguments   = [INT]
		, aie_description = join "\n\n"
			[ "Take the top of the B-stack as a pointer and read an integer from that pointer with the argument as offset."
			, "See also {{`load_si16`}}, {{`load_si32`}}, {{`load_ui8`}}."
			]
		}
	i_load_si16 =
		{ zero
		& aie_instruction = "load_si16"
		, aie_arguments   = [INT]
		, aie_description = join "\n\n"
			[ "Take the top of the B-stack as a pointer and read a 16-bit signed integer from that pointer with the argument as offset."
			, "See also {{`load_i}}, {{`load_si32`}}, {{`load_ui8`}}."
			]
		}
	i_load_si32 =
		{ zero
		& aie_instruction = "load_si32"
		, aie_arguments   = [INT]
		, aie_description = join "\n\n"
			[ "Take the top of the B-stack as a pointer and read a 32-bit signed integer from that pointer with the argument as offset."
			, "This instruction is only available on 64-bit systems. On 32-bit systems, {{`load_i`}} has the same effect."
			, "See also {{`load_i`}}, {{`load_si16`}}, {{`load_ui8`}}."
			]
		}
	i_load_ui8 =
		{ zero
		& aie_instruction = "load_ui8"
		, aie_arguments   = [INT]
		, aie_description = join "\n\n"
			[ "Take the top of the B-stack as a pointer and read a 8-bit unsigned integer from that pointer with the argument as offset."
			, "See also {{`load_i`}}, {{`load_si16`}}, {{`load_si32`}}."
			]
		}

	i_no_op =
		{ zero
		& aie_instruction = "no_op"
		, aie_description = join "\n"
			[ "Do nothing. This is for example useful in the `cast` function:\n"
			, "```clean"
			, "cast :: .a -> .b"
			, "cast _ = code {"
			, "\tno_op"
			, "}"
			, "```"
			]
		}

directives :: [ABCInstructionEntry]
directives =
	[ d_d
	, d_o
	, d_export
	, d_module
	, d_end
	, d_endinfo
	, d_start
	]
where
	d_d =
		{ zero
		& aie_instruction = ".d"
		, aie_arguments   = [A_OFFSET, B_OFFSET, STRING_]
		, aie_description = concat
			[ "Indicates how many stack elements are on the stack when a jump follows."
			, "The first integer is the number of elements on the A-stack; the second that of B-stack elements."
			, "The optional third argument indicates the type of the B-stack elements, e.g. `bbi` for two booleans and an integer."
			]
		}
	d_o =
		{ zero
		& aie_instruction = ".o"
		, aie_arguments   = [A_OFFSET, B_OFFSET, STRING_]
		, aie_description = concat
			[ "Indicates how many stack elements are 'given back' to a calling function when a {{`rtn`}} follows."
			, "The first integer is the number of elements on the A-stack; the second that of B-stack elements."
			, "The optional third argument indicates the type of the B-stack elements, e.g. `bbi` for two booleans and an integer."
			]
		}

	d_export =
		{ zero
		& aie_instruction = ".export"
		, aie_arguments   = [LABEL]
		, aie_description = "Exports a label (allows linking)."
		}

	d_module =
		{ zero
		& aie_instruction = ".module"
		, aie_arguments   = [LABEL]
		, aie_description = "Indicates the name of the module."
		}
	d_end =
		{ zero
		& aie_instruction = ".end"
		, aie_description = "Indicates the end of the ABC file."
		}
	d_endinfo =
		{ zero
		& aie_instruction = ".endinfo"
		, aie_description = "Indicates the end of the metadata in the ABC file."
		}
	d_start =
		{ zero
		& aie_instruction = ".start"
		, aie_arguments   = [LABEL]
		, aie_description = "Indicates the label to start execution at."
		}

/**
 * Instructions without documentation yet
 */
other_instructions :: [String]
other_instructions =
	[ "add_args"
	, "addLU"
	, "build"
	, "buildAC"
	, "buildF_b"
	, "buildh"
	, "build_r"
	, "build_u"
	, "catS"
	, "call"
	, "cmpS"
	, "ceilingR"
	, "copy_graph"
	, "code_channelP"
	, "create_array"
	, "create_array_"
	, "create_channel"
	, "currentP"
	, "del_args"
	, "divLU"
	, "divU"
	, "eqD_b"
	, "eqAC_a"
	, "eq_desc"
	, "eq_desc_b"
	, "eq_nulldesc"
	, "eq_symbol"
	, "exit_false"
	, "fill"
	, "fill1"
	, "fill2"
	, "fill3"
	, "fill1_r"
	, "fill2_r"
	, "fill3_r"
	, "fillcaf"
	, "fillcp"
	, "fillcp_u"
	, "fill_u"
	, "fillh"
	, "fillB"
	, "fillB_b"
	, "fillC"
	, "fillC_b"
	, "fillF_b"
	, "fillI"
	, "fillI_b"
	, "fillR"
	, "fillR_b"
	, "fill_a"
	, "fill_r"
	, "floordivI"
	, "getWL"
	, "get_desc_arity"
	, "get_desc_flags_b"
	, "get_desc0_number"
	, "gtU"
	, "in"
	, "is_record"
	, "ItoP"
	, "jmp_ap"
	, "jmp_ap_upd"
	, "jmp_upd"
	, "jmp_eval"
	, "jmp_eval_upd"
	, "jmp_not_eqZ"
	, "jrsr"
	, "jsr_ap"
	, "ltU"
	, "modI"
	, "mulUUL"
	, "new_ext_reducer"
	, "new_int_reducer"
	, "newP"
	, "out"
	, "print"
	, "printD"
	, "print_char"
	, "print_int"
	, "print_real"
	, "print_r_arg"
	, "print_sc"
	, "print_symbol"
	, "print_symbol_sc"
	, "pushcaf"
	, "push_finalizers"
	, "pushA_a"
	, "pushD"
	, "pushD_a"
	, "pushF_a"
	, "pushL"
	, "pushLc"
	, "pushzs"
	, "push_a_b"
	, "push_arg"
	, "push_arg_b"
	, "push_args"
	, "push_args_u"
	, "push_array"
	, "push_arraysize"
	, "push_b_a"
	, "push_node"
	, "push_node_u"
	, "push_a_r_args"
	, "push_t_r_a"
	, "push_t_r_args"
	, "push_r_args"
	, "push_r_args_a"
	, "push_r_args_b"
	, "push_r_args_u"
	, "push_r_arg_D"
	, "push_r_arg_t"
	, "push_r_arg_u"
	, "push_wl_args"
	, "pushZ"
	, "pushZR"
	, "putWL"
	, "randomP"
	, "release"
	, "remU"
	, "replace"
	, "repl_arg"
	, "repl_args"
	, "repl_args_b"
	, "repl_r_args"
	, "repl_r_args_a"
	, "select"
	, "send_graph"
	, "send_request"
	, "set_continue"
	, "set_defer"
	, "set_entry"
	, "set_finalizers"
	, "setwait"
	, "shiftrU"
	, "sincosR"
	, "sliceS"
	, "stop_reducer"
	, "subLU"
	, "addIo"
	, "mulIo"
	, "subIo"
	, "suspend"
	, "testcaf"
	, "truncateR"
	, "update_a"
	, "updatepop_a"
	, "update_b"
	, "updatepop_b"
	, "updateS"
	, "update"
	, ".algtype"
	, ".caf"
	, ".code"
	, ".comp"
	, ".a"
	, ".depend"
	, ".desc"
	, ".desc0"
	, ".descn"
	, ".descexp"
	, ".descs"
	, ".keep"
	, ".inline"
	, ".impdesc"
	, ".implab"
	, ".implib"
	, ".impmod"
	, ".impobj"
	, ".n"
	, ".nu"
	, ".newlocallabel"
	, ".n_string"
	, ".pb"
	, ".pd"
	, ".pe"
	, ".pl"
	, ".pld"
	, ".pn"
	, ".pt"
	, ".record"
	, ".string"
	]

implementation module BuiltinABCInstructions

import _SystemArray
import StdList
import StdMisc

import Text

import Cloogle

import CloogleDB

builtin_abc_instructions :: [ABCInstructionEntry]
builtin_abc_instructions =
	[ i_create
	: arith_instructions ++
	  pushes ++
	  branches ++
	  miscellaneous ++
	  directives ++
	  [{zero & aie_instruction=i} \\ i <- other_instructions]
	]

instance zero ABCInstructionEntry
where
	zero =
		{ aie_instruction = undef
		, aie_arguments   = []
		, aie_description = "There is no documentation for this ABC instruction yet."
		}

LABEL    :== ABCArgument ABCTypeLabel        False
LABEL_   :== ABCArgument ABCTypeLabel        True
A_OFFSET :== ABCArgument ABCTypeAStackOffset False
B_OFFSET :== ABCArgument ABCTypeBStackOffset False
STRING   :== ABCArgument ABCTypeString       False
STRING_  :== ABCArgument ABCTypeString       True
BOOL     :== ABCArgument ABCTypeBool         False
BOOL_    :== ABCArgument ABCTypeBool         True
CHAR     :== ABCArgument ABCTypeChar         False
CHAR_    :== ABCArgument ABCTypeChar         True
INT      :== ABCArgument ABCTypeInt          False
INT_     :== ABCArgument ABCTypeInt          True
REAL     :== ABCArgument ABCTypeReal         False
REAL_    :== ABCArgument ABCTypeReal         True

i_create :: ABCInstructionEntry
i_create =
	{ zero
	& aie_instruction = "create"
	, aie_description = "Creates a new empty node and pushes its address to the A-stack."
	}

arith_instructions :: [ABCInstructionEntry]
arith_instructions =
	[ arith1 "absR"    "Real" "absolute value"
	, arith1 "acosR"   "Real" "arccosine"
	, arith1 "asinR"   "Real" "arcsine"
	, arith1 "atanR"   "Real" "arctangent"
	, arith1 "cosR"    "Real" "cosine"
	, arith1 "entierR" "Real" "(Int) entier (floor)"
	, arith1 "expR"    "Real" "exponential function (e^r)"
	, arith1 "lnR"     "Real" "natural logarithm"
	, arith1 "log10R"  "Real" "base-10 logarithm"
	, arith1 "notB"    "Bool" "logical negation"
	, arith1 "sinR"    "Real" "sine"
	, arith1 "sqrtR"   "Real" "square root"
	, arith1 "tanR"    "Real" "tangent"

	, op1 "decI" "Int"  "Decrements"
	, op1 "incI" "Int"  "Increments"
	, op1 "negI" "Int"  "Negates"
	, op1 "negR" "Real" "Negates"
	, op1 "not%" "Int"  "Bitwise negates"

	, op2 "addI"    "Int"  "Sums"
	, op2 "addR"    "Real" "Sums"
	, op2 "andB"    "Bool" "Logically conjuncts"
	, op2 "and%"    "Int"  "Bitwise conjuncts"
	, op2 "divI"    "Int"  "Divides"
	, op2 "divR"    "Real" "Divides"
	, op2 "eqB"     "Bool" "Checks equality on"
	, op2 "eqC"     "Char" "Checks equality on"
	, op2 "eqI"     "Int"  "Checks equality on"
	, op2 "eqR"     "Real" "Checks equality on"
	, op2 "gtC"     "Char" "Checks greater-than on"
	, op2 "gtI"     "Int"  "Checks greater-than on"
	, op2 "gtR"     "Real" "Checks greater-than on"
	, op2 "ltC"     "Char" "Checks less-than on"
	, op2 "ltI"     "Int"  "Checks less-than on"
	, op2 "ltR"     "Real" "Checks less-than on"
	, op2 "mulI"    "Int"  "Multiplies"
	, op2 "mulR"    "Real" "Multiplies"
	, op2 "orB"     "Bool" "Logically disjuncts"
	, op2 "or%"     "Int"  "Bitwise disjuncts"
	, op2 "powR"    "Real" "Raises to the power on"
	, op2 "remI"    "Int"  "Computes the remainder after division of"
	, op2 "rotl%"   "Int"  "Bitwise left-rotate on"
	, op2 "rotr%"   "Int"  "Bitwise right-rotate on"
	, op2 "shiftl%" "Int"  "Bitwise left-shift on"
	, op2 "shiftr%" "Int"  "Bitwise right-shift on"
	, op2 "subI"    "Int"  "Subtracts"
	, op2 "subR"    "Real" "Subtracts"
	, op2 "xor%"    "Int"  "Bitwise XOR on"

	, eq_arg "Bool" BOOL 'A'
	, eq_arg "Bool" BOOL 'B'
	, eq_arg "Char" CHAR 'A'
	, eq_arg "Char" CHAR 'B'
	, eq_arg "Int"  INT  'A'
	, eq_arg "Int"  INT  'B'
	, eq_arg "Real" REAL 'A'
	, eq_arg "Real" REAL 'B'

	, convert "CtoI"  "Char" "Int"
	, convert "CtoAC" "Char" "String"
	, convert "ItoC"  "Int"  "Char"
	, convert "ItoR"  "Int"  "Real"
	, convert "RtoI"  "Real" "Int"
	]
where
	arith1 :: !String !String !String -> ABCInstructionEntry
	arith1 instr type description =
		{ zero
		& aie_instruction = instr
		, aie_description = "Computes the " + description + " of the " + type + " on top of the B-stack."
		}

	op1 :: !String !String !String -> ABCInstructionEntry
	op1 instr type description =
		{ zero
		& aie_instruction = instr
		, aie_description = description + " the " + type + " on top of the B-stack."
		}

	op2 :: !String !String !String -> ABCInstructionEntry
	op2 instr type description =
		{ zero
		& aie_instruction = instr
		, aie_description = description + " the two " + type + "s on top of the B-stack."
		}

	eq_arg :: !String !ABCArgument !Char -> ABCInstructionEntry
	eq_arg type arg stack =
		{ zero
		& aie_instruction = {'e','q',type.[0],'_',toLower stack}
		, aie_arguments   = [if (stack == 'A') A_OFFSET B_OFFSET, arg]
		, aie_description = "Checks equality between the " + {stack} + "-stack element and the second argument."
		}

	convert :: !String !String !String -> ABCInstructionEntry
	convert instr fr to =
		{ zero
		& aie_instruction = instr
		, aie_description = "Converts the " + fr + " on top of the B-stack to " + to + "."
		}

pushes :: [ABCInstructionEntry]
pushes =
	[ push    "Bool" BOOL
	, push    "Char" CHAR
	, push    "Int"  INT
	, push    "Real" REAL
	, push_a  "Bool"
	, push_a  "Char"
	, push_a  "Int"
	, push_a  "Real"
	, build   "Bool" BOOL
	, build   "Char" CHAR
	, build   "Int"  INT
	, build   "Real" REAL
	, build_b "Bool"
	, build_b "Char"
	, build_b "Int"
	, build_b "Real"
	]
where
	push :: !String !ABCArgument -> ABCInstructionEntry
	push type arg =
		{ zero
		& aie_instruction = "push" + {type.[0]}
		, aie_arguments   = [arg]
		, aie_description = "Pushes the " + type + " argument to the B-stack."
		}

	push_a :: !String -> ABCInstructionEntry
	push_a type =
		{ zero
		& aie_instruction = "push" + {type.[0]} + "_a"
		, aie_arguments   = [INT]
		, aie_description = "Pushes the " + type + " from the nth position on the A-stack to the B-stack."
		}

	build :: !String !ABCArgument -> ABCInstructionEntry
	build type arg =
		{ zero
		& aie_instruction = "build" + {type.[0]}
		, aie_arguments   = [arg]
		, aie_description = "Builds a " + type + "-node with the argument as value on the A-stack."
		}

	build_b :: !String -> ABCInstructionEntry
	build_b type =
		{ zero
		& aie_instruction = "build" + {type.[0]} + "_b"
		, aie_arguments   = [INT]
		, aie_description = "Builds a " + type + "-node with the value on the nth position of the B-stack on the A-stack."
		}

branches :: [ABCInstructionEntry]
branches =
	[ i_jmp
	, i_jmp_false
	, i_jmp_true
	, i_jsr
	, i_jsr_eval
	, i_rtn
	]
where
	i_jmp =
		{ zero
		& aie_instruction = "jmp"
		, aie_arguments   = [LABEL]
		, aie_description = "Unconditional jump to a label."
		}
	i_jmp_false =
		{ zero
		& aie_instruction = "jmp_false"
		, aie_arguments   = [LABEL]
		, aie_description = "Jump to a label if the Bool on top of the B-stack is false."
		}
	i_jmp_true =
		{ zero
		& aie_instruction = "jmp_true"
		, aie_arguments   = [LABEL]
		, aie_description = "Jump to a label if the Bool on top of the B-stack is true."
		}
	i_jsr =
		{ zero
		& aie_instruction = "jsr"
		, aie_arguments   = [LABEL]
		, aie_description = "Subroutine jump to a label. {{`rtn`}} returns to the instruction after this `jsr`."
		}
	i_jsr_eval =
		{ zero
		& aie_instruction = "jsr_eval"
		, aie_arguments   = [A_OFFSET, LABEL]
		, aie_description = "Subroutine jump to evaluate the indicated A-stack element. {{`rtn`}} returns to the instruction after this `jsr_eval`."
		}
	i_rtn =
		{ zero
		& aie_instruction = "rtn"
		, aie_description = "Returns from a subroutine call (e.g. {{`jsr`}})."
		}

miscellaneous :: [ABCInstructionEntry]
miscellaneous =
	[ i_ccall
	, i_centry
	, i_halt
	, i_instruction
	, i_load_i
	, i_load_si16
	, i_load_si32
	, i_load_ui8
	, i_no_op
	]
where
	i_ccall =
		{ zero
		& aie_instruction = "ccall"
		, aie_arguments   = [LABEL, STRING]
		, aie_description = join "\n"
			[ "Calls a C function."
			, "Some of this is documented in https://svn.cs.ru.nl/repos/clean-tools/trunk/htoclean/CallingCFromClean.html"
			, "The first argument is the name of the function, the second is the signature."
			, "\n"
			, "The signature has to be of the form `flags?input?sep output(sep state)?`, where"
			, "- sep    can be either `-` or `:`."
			, "- flags  can be `G` and/or `P`. `G` saves the state in global variables and is needed when the called C function will call Clean functions. `P` lets the callee pop arguments (necessary on 32-bit Windows)."
			, "- input  is a number of input argument types (allowed: `IpRrSsAOF`)."
			, "- output is a number of output argument types (allowed: `VIpRrSsAOF`)."
			, "- state  is a carried state that is not passed to the C function, for example used to thread {{`World`}} in ccalls (allowed: `IpRSA`)."
			, "\n"
			, "Input, output and state argument types can be:"
			, "- `I`    for integers"
			, "- `p`    for pointers (e.g. from {{`System.Pointer`}}; on most systems this is identical to `I`)"
			, "- [`Rr`] for reals"
			, "- `S`    for Clean Strings (`{#Char}`)."
			, "- `s`    for the characters of a Clean String (handy to use in conjuction with {{`packString`}})"
			, "- `A`    for A-stack elements (e.g. used for `*World`, a boxed integer under the hood)"
			, "- [`OF`] for function pointers"
			, "- `V`    for `void`, packs the following argument types in a tuple (e.g. `VIR` means `(Int, Real)`)"
			]
		}
	i_centry =
		{ zero
		& aie_instruction = "centry"
		, aie_arguments   = [LABEL, LABEL, STRING]
		, aie_description = join "\n"
			[ "Adds code to call a Clean function from C."
			, "Usually it is not needed to write this instruction yourself."
			, "It is generated with the `foreign export` construct.\n"
			, "The first label is the name of the C function to generate."
			, "The second label is the Clean function to link it to.\n"
			, "The string argument indicates the type."
			, "For more information, see {{`ccall`}}."
			]
		}

	i_halt =
		{ zero
		& aie_instruction = "halt"
		, aie_description = "Terminates the program immediately."
		}

	i_instruction =
		{ zero
		& aie_instruction = "instruction"
		, aie_arguments   = [INT]
		, aie_description = "Adds the raw argument as a word in the generated object file."
		}

	i_load_i =
		{ zero
		& aie_instruction = "load_i"
		, aie_arguments   = [INT]
		, aie_description = join "\n\n"
			[ "Take the top of the B-stack as a pointer and read an integer from that pointer with the argument as offset."
			, "See also {{`load_si16`}}, {{`load_si32`}}, {{`load_ui8`}}."
			]
		}
	i_load_si16 =
		{ zero
		& aie_instruction = "load_si16"
		, aie_arguments   = [INT]
		, aie_description = join "\n\n"
			[ "Take the top of the B-stack as a pointer and read a 16-bit signed integer from that pointer with the argument as offset."
			, "See also {{`load_i}}, {{`load_si32`}}, {{`load_ui8`}}."
			]
		}
	i_load_si32 =
		{ zero
		& aie_instruction = "load_si32"
		, aie_arguments   = [INT]
		, aie_description = join "\n\n"
			[ "Take the top of the B-stack as a pointer and read a 32-bit signed integer from that pointer with the argument as offset."
			, "This instruction is only available on 64-bit systems. On 32-bit systems, {{`load_i`}} has the same effect."
			, "See also {{`load_i`}}, {{`load_si16`}}, {{`load_ui8`}}."
			]
		}
	i_load_ui8 =
		{ zero
		& aie_instruction = "load_ui8"
		, aie_arguments   = [INT]
		, aie_description = join "\n\n"
			[ "Take the top of the B-stack as a pointer and read a 8-bit unsigned integer from that pointer with the argument as offset."
			, "See also {{`load_i`}}, {{`load_si16`}}, {{`load_si32`}}."
			]
		}

	i_no_op =
		{ zero
		& aie_instruction = "no_op"
		, aie_description = join "\n"
			[ "Do nothing. This is for example useful in the `cast` function:\n"
			, "```clean"
			, "cast :: .a -> .b"
			, "cast _ = code {"
			, "\tno_op"
			, "}"
			, "```"
			]
		}

directives :: [ABCInstructionEntry]
directives =
	[ d_d
	, d_o
	, d_export
	, d_module
	, d_end
	, d_endinfo
	, d_start
	]
where
	d_d =
		{ zero
		& aie_instruction = ".d"
		, aie_arguments   = [A_OFFSET, B_OFFSET, STRING_]
		, aie_description = concat
			[ "Indicates how many stack elements are on the stack when a jump follows."
			, "The first integer is the number of elements on the A-stack; the second that of B-stack elements."
			, "The optional third argument indicates the type of the B-stack elements, e.g. `bbi` for two booleans and an integer."
			]
		}
	d_o =
		{ zero
		& aie_instruction = ".o"
		, aie_arguments   = [A_OFFSET, B_OFFSET, STRING_]
		, aie_description = concat
			[ "Indicates how many stack elements are 'given back' to a calling function when a {{`rtn`}} follows."
			, "The first integer is the number of elements on the A-stack; the second that of B-stack elements."
			, "The optional third argument indicates the type of the B-stack elements, e.g. `bbi` for two booleans and an integer."
			]
		}

	d_export =
		{ zero
		& aie_instruction = ".export"
		, aie_arguments   = [LABEL]
		, aie_description = "Exports a label (allows linking)."
		}

	d_module =
		{ zero
		& aie_instruction = ".module"
		, aie_arguments   = [LABEL]
		, aie_description = "Indicates the name of the module."
		}
	d_end =
		{ zero
		& aie_instruction = ".end"
		, aie_description = "Indicates the end of the ABC file."
		}
	d_endinfo =
		{ zero
		& aie_instruction = ".endinfo"
		, aie_description = "Indicates the end of the metadata in the ABC file."
		}
	d_start =
		{ zero
		& aie_instruction = ".start"
		, aie_arguments   = [LABEL]
		, aie_description = "Indicates the label to start execution at."
		}

/**
 * Instructions without documentation yet
 */
other_instructions :: [String]
other_instructions =
	[ "add_args"
	, "addLU"
	, "build"
	, "buildAC"
	, "buildF_b"
	, "buildh"
	, "build_r"
	, "build_u"
	, "catS"
	, "call"
	, "cmpS"
	, "ceilingR"
	, "copy_graph"
	, "code_channelP"
	, "create_array"
	, "create_array_"
	, "create_channel"
	, "currentP"
	, "del_args"
	, "divLU"
	, "divU"
	, "eqD_b"
	, "eqAC_a"
	, "eq_desc"
	, "eq_desc_b"
	, "eq_nulldesc"
	, "eq_symbol"
	, "exit_false"
	, "fill"
	, "fill1"
	, "fill2"
	, "fill3"
	, "fill1_r"
	, "fill2_r"
	, "fill3_r"
	, "fillcaf"
	, "fillcp"
	, "fillcp_u"
	, "fill_u"
	, "fillh"
	, "fillB"
	, "fillB_b"
	, "fillC"
	, "fillC_b"
	, "fillF_b"
	, "fillI"
	, "fillI_b"
	, "fillR"
	, "fillR_b"
	, "fill_a"
	, "fill_r"
	, "floordivI"
	, "getWL"
	, "get_desc_arity"
	, "get_desc_flags_b"
	, "get_desc0_number"
	, "get_node_arity"
	, "gtU"
	, "in"
	, "is_record"
	, "ItoP"
	, "jmp_ap"
	, "jmp_ap_upd"
	, "jmp_upd"
	, "jmp_eval"
	, "jmp_eval_upd"
	, "jmp_not_eqZ"
	, "jrsr"
	, "jsr_ap"
	, "ltU"
	, "modI"
	, "mulUUL"
	, "new_ext_reducer"
	, "new_int_reducer"
	, "newP"
	, "out"
	, "pop_a"
	, "pop_b"
	, "print"
	, "printD"
	, "print_char"
	, "print_int"
	, "print_real"
	, "print_r_arg"
	, "print_sc"
	, "print_symbol"
	, "print_symbol_sc"
	, "pushcaf"
	, "push_finalizers"
	, "pushA_a"
	, "pushD"
	, "pushD_a"
	, "pushF_a"
	, "pushL"
	, "pushLc"
	, "pushzs"
	, "push_a"
	, "push_b"
	, "push_a_b"
	, "push_arg"
	, "push_arg_b"
	, "push_args"
	, "push_args_u"
	, "push_array"
	, "push_arraysize"
	, "push_b_a"
	, "push_node"
	, "push_node_u"
	, "push_a_r_args"
	, "push_t_r_a"
	, "push_t_r_args"
	, "push_r_args"
	, "push_r_args_a"
	, "push_r_args_b"
	, "push_r_args_u"
	, "push_r_arg_D"
	, "push_r_arg_t"
	, "push_r_arg_u"
	, "push_wl_args"
	, "pushZ"
	, "pushZR"
	, "putWL"
	, "randomP"
	, "release"
	, "remU"
	, "replace"
	, "repl_arg"
	, "repl_args"
	, "repl_args_b"
	, "repl_r_args"
	, "repl_r_args_a"
	, "select"
	, "send_graph"
	, "send_request"
	, "set_continue"
	, "set_defer"
	, "set_entry"
	, "set_finalizers"
	, "setwait"
	, "shiftrU"
	, "sincosR"
	, "sliceS"
	, "stop_reducer"
	, "subLU"
	, "addIo"
	, "mulIo"
	, "subIo"
	, "suspend"
	, "testcaf"
	, "truncateR"
	, "update_a"
	, "updatepop_a"
	, "update_b"
	, "updatepop_b"
	, "updateS"
	, "update"
	, ".algtype"
	, ".caf"
	, ".code"
	, ".comp"
	, ".a"
	, ".depend"
	, ".desc"
	, ".desc0"
	, ".descn"
	, ".descexp"
	, ".descs"
	, ".keep"
	, ".inline"
	, ".impdesc"
	, ".implab"
	, ".implib"
	, ".impmod"
	, ".impobj"
	, ".n"
	, ".nu"
	, ".newlocallabel"
	, ".n_string"
	, ".pb"
	, ".pd"
	, ".pe"
	, ".pl"
	, ".pld"
	, ".pn"
	, ".pt"
	, ".record"
	, ".string"
	]


Fix hostname parsing for cloaked hostnames

implementation module IRC

import StdList, StdTuple, StdOverloaded, StdFunc, StdString, StdChar, StdBool
import _SystemArray

import GenPrint
import GenIRC

import Control.Applicative
import Control.Monad
import Data.Either
import Data.Maybe
import Data.Tuple
import Text.Parsers.Simple.Chars
import Text.Parsers.Simple.Core

import StdDebug

from Data.Functor import <$>
from Data.Func import $
from StdMisc import undef, abort
from Text import class Text(lpad,trim,rtrim,split,indexOf,concat),
	instance Text String
import qualified Text

jon :== 'Text'.join

derive gPrint IRCErrors, IRCReplies, Maybe, Either, IRCUser, IRCNumReply

Start = (map (fmap toString) msgs, msgs)
where
	msgs =
		[ parseIRCMessage ":clooglebot!~cloogle@dhcp-077-249-221-037.chello.nl QUIT\r\n"
		, parseIRCMessage ":clooglebot!~cloogle QUIT\r\n"
		, parseIRCMessage ":frobnicator!~frobnicat@92.110.128.124 QUIT\r\n"
		, parseIRCMessage ":frobnicator!~frobnicat@92.110.128.124 AWAY test\r\n"
		, parseIRCMessage ":frobnicator!~frobnicat@92.110.128.124 AWAY :test with spaces\r\n"
		, parseIRCMessage ":cherryh.freenode.net NOTICE * :*** Found your hostname\r\n"
		, parseIRCMessage ":cherryh.freenode.net QUIT :hoi hoi\r\n"
		, parseIRCMessage ":cherryh.freenode.net JOIN #cha,#ch-b #twilight\r\n"
		, parseIRCMessage ":cherryh.freenode.net ISON a b c d e f :g h\r\n"
		, parseIRCMessage ":wilhelm.freenode.net 001 clooglebot :Welcome to the freenode Internet Relay Chat Network clooglebot\r\n"
		, parseIRCMessage "PING :orwell.freenode.net\r\n"
		, parseIRCMessage ":ChanServ!ChanServ@services. MODE #cloogle +o frobnicator\r\n"
		]

parseIRCMessage :: String -> Either [Error] IRCMessage
parseIRCMessage s = case runParser parsePrefix (fromString s) of
	// Prefix is parsed
	([(prefix, rest):_], _)
		//Try parsing a numeric reply
		= case parse parseReply rest of
			//Try a normal command
			Left e = case parseCmd rest of
				Left e2 = Left [e2:e]
				Right cmd = Right {IRCMessage | irc_prefix=prefix, irc_command=Right cmd}
			Right repl = Right {IRCMessage | irc_prefix=prefix, irc_command=Left repl}
	// Error parsing prefix
	(_, es) = Left ["Error parsing prefix"]

//Prefix
parsePrefix :: Parser Char (Maybe (Either IRCUser String))
parsePrefix
	= optional (pToken ':' >>| parseEither parseUser parseHost <* pToken ' ')
where
	parseEither :: (Parser a b) (Parser a c) -> Parser a (Either b c)
	parseEither p q = Left <$> p <|> Right <$> q

	parseUser :: Parser Char IRCUser
	parseUser = parseNick
			>>= \nick->optional (pToken '!' >>| parseUsr)
			>>= \muser->optional (pToken '@' >>| parseHost)
			>>= \mhost->pure {IRCUser
				| irc_nick=nick, irc_user=muser, irc_host=mhost}

	parseUsr :: Parser Char String
	parseUsr = toString <$> pSome (pNoneOf [' ', '@':illegal])

	parseNick :: Parser Char String
	parseNick = pAlpha
		>>= \c ->pMany (pAlpha <|> pDigit <|> pOneOf (fromString "-[]\\`^{}"))
		>>= \cs->pure (toString [c:cs])

	parseHost :: Parser Char String
	parseHost = jon "." <$> (pSepBy parseName (pToken '.'))
		>>= \s->optional (pToken '.') >>= pure o maybe s (\p->s+++toString s)
		where
			parseName :: Parser Char String
			parseName = toString <$> pSome (pAlpha <|> pDigit <|> pOneOf ['-', '/'])

//Parse Cmd
parseCmd :: [Char] -> Either Error IRCCommand
parseCmd cs = fst $ gIRCParse{|*|} $ argfun $ split " " $ toString cs
	where
		argfun :: [String] -> [String]
		argfun [] = []
		argfun [x:xs]
		# x = trim x
		| x.[0] == ':' = [jon " " $ [x % (1, size x):map rtrim xs]]
		| otherwise = [x:argfun xs]

//Reply

parseReply :: Parser Char IRCNumReply
parseReply = spaceParser
	>>|       (pMany (pToken '0') >>| pSome pDigit <* spaceParser)
	>>= \rep->(toString <$> pSome (pNoneOf [' ':illegal]) <* spaceParser)
	>>= \rec->(toString <$> pSome (pNoneOf illegal))
	>>= \msg->pure {IRCNumReply
		| irc_reply     = fromInt $ toInt $ toString rep
		, irc_recipient = rec
		, irc_message   = msg % (if (msg.[0] == ':') 1 0, size msg)
		}
	<* pToken '\r' <* pToken '\n'
	where
		spaceParser :: Parser Char [Char]
		spaceParser = pMany $ pToken ' '

//Common parsers
pNoneOf :: [a] -> Parser a a | Eq a
pNoneOf l = pSatisfy (not o flip isMember l)

illegal :: [Char]
illegal = ['\x00','\r','\n']

instance toString IRCNumReply where
	toString m = lpad (toString $ toInt m.irc_reply) 3 '0' <+ " " <+
		m.irc_recipient <+ " " <+ concat (gIRCPrint{|*|} m.irc_message)
instance toString IRCMessage where
	toString m = maybe "" (\s->either ((<+) ":") id s <+ " ") m.irc_prefix
		<+ either toString toString m.irc_command
instance toString IRCUser where
	toString m = m.irc_nick <+ maybe "" ((<+) "!") m.irc_user
		<+ maybe "" ((<+) "@") m.irc_host
instance toString IRCCommand where
	toString m = jon " " (gIRCPrint{|*|} m) +++ "\r\n"
instance toString IRCReplies where toString r = printToString r
instance toString IRCErrors where toString r = printToString r

(<+) infixr 5 :: a b -> String | toString a & toString b
(<+) a b = toString a +++ toString b

instance fromInt IRCReplies where
	fromInt r = case r of
		1 = RPL_WELCOME; 2 = RPL_YOURHOST;
		3 = RPL_CREATED; 4 = RPL_MYINFO;
		5 = RPL_BOUNCE; 200 = RPL_TRACELINK;
		201 = RPL_TRACECONNECTING; 202 = RPL_TRACEHANDSHAKE;
		203 = RPL_TRACEUNKNOWN; 204 = RPL_TRACEOPERATOR;
		205 = RPL_TRACEUSER; 206 = RPL_TRACESERVER;
		207 = RPL_TRACESERVICE; 208 = RPL_TRACENEWTYPE;
		209 = RPL_TRACECLASS; 210 = RPL_TRACERECONNECT;
		211 = RPL_STATSLINKINFO; 212 = RPL_STATSCOMMANDS;
		219 = RPL_ENDOFSTATS; 221 = RPL_UMODEIS;
		234 = RPL_SERVLIST; 235 = RPL_SERVLISTEND;
		242 = RPL_STATSUPTIME; 243 = RPL_STATSOLINE;
		251 = RPL_LUSERCLIENT; 252 = RPL_LUSEROP;
		253 = RPL_LUSERUNKNOWN; 254 = RPL_LUSERCHANNELS;
		255 = RPL_LUSERME; 256 = RPL_ADMINME;
		257 = RPL_ADMINLOC1; 258 = RPL_ADMINLOC2;
		259 = RPL_ADMINEMAIL; 261 = RPL_TRACELOG;
		262 = RPL_TRACEEND; 263 = RPL_TRYAGAIN;
		301 = RPL_AWAY; 302 = RPL_USERHOST;
		303 = RPL_ISON; 304 = RPL_UNAWAY;
		305 = RPL_NOWAWAY; 311 = RPL_WHOISUSER;
		312 = RPL_WHOISSERVER; 313 = RPL_WHOISOPERATOR;
		314 = RPL_WHOWASUSER; 315 = RPL_ENDOFWHO;
		317 = RPL_WHOISIDLE; 318 = RPL_ENDOFWHOIS;
		319 = RPL_WHOISCHANNELS; 321 = RPL_LISTSTART;
		322 = RPL_LIST; 323 = RPL_LISTEND;
		324 = RPL_CHANNELMODEIS; 325 = RPL_UNIQOPIS;
		331 = RPL_NOTOPIC; 332 = RPL_TOPIC;
		341 = RPL_INVITING; 342 = RPL_SUMMONING;
		346 = RPL_INVITELIST; 347 = RPL_ENDOFINVITELIST;
		348 = RPL_EXCEPTLIST; 349 = RPL_ENDOFEXCEPTLIST;
		351 = RPL_VERSION; 352 = RPL_WHOREPLY;
		353 = RPL_NAMREPLY; 364 = RPL_LINKS;
		365 = RPL_ENDOFLINKS; 366 = RPL_ENDOFNAMES;
		367 = RPL_BANLIST; 368 = RPL_ENDOFBANLIST;
		369 = RPL_ENDOFWHOWAS; 371 = RPL_INFO;
		372 = RPL_MOTD; 374 = RPL_ENDOFINFO;
		375 = RPL_MOTDSTART; 376 = RPL_ENDOFMOTD;
		381 = RPL_YOUREOPER; 382 = RPL_REHASHING;
		383 = RPL_YOURESERVICE; 391 = RPL_TIME;
		392 = RPL_USERSSTART; 393 = RPL_USERS;
		394 = RPL_ENDOFUSERS; 395 = RPL_NOUSERS;
		_ = abort $ "fromInt IRCReplies: " +++ toString r +++ " undef\n"

instance toInt IRCReplies where
	toInt r = case r of
		RPL_WELCOME = 1; RPL_YOURHOST = 2;
		RPL_CREATED = 3; RPL_MYINFO = 4;
		RPL_BOUNCE = 5; RPL_TRACELINK = 200;
		RPL_TRACECONNECTING = 201; RPL_TRACEHANDSHAKE = 202;
		RPL_TRACEUNKNOWN = 203; RPL_TRACEOPERATOR = 204;
		RPL_TRACEUSER = 205; RPL_TRACESERVER = 206;
		RPL_TRACESERVICE = 207; RPL_TRACENEWTYPE = 208;
		RPL_TRACECLASS = 209; RPL_TRACERECONNECT = 210;
		RPL_STATSLINKINFO = 211; RPL_STATSCOMMANDS = 212;
		RPL_ENDOFSTATS = 219; RPL_UMODEIS = 221;
		RPL_SERVLIST = 234; RPL_SERVLISTEND = 234;
		RPL_STATSUPTIME = 242; RPL_STATSOLINE = 243;
		RPL_LUSERCLIENT = 251; RPL_LUSEROP = 252;
		RPL_LUSERUNKNOWN = 253; RPL_LUSERCHANNELS = 254;
		RPL_LUSERME = 255; RPL_ADMINME = 256;
		RPL_ADMINLOC1 = 257; RPL_ADMINLOC2 = 258;
		RPL_ADMINEMAIL = 259; RPL_TRACELOG = 261;
		RPL_TRACEEND = 262; RPL_TRYAGAIN = 263;
		RPL_AWAY = 301; RPL_USERHOST = 302;
		RPL_ISON = 303; RPL_UNAWAY = 304;
		RPL_NOWAWAY = 305; RPL_WHOISUSER = 311;
		RPL_WHOISSERVER = 312; RPL_WHOISOPERATOR = 313;
		RPL_WHOWASUSER = 314; RPL_ENDOFWHO = 315;
		RPL_WHOISIDLE = 317; RPL_ENDOFWHOIS = 318;
		RPL_WHOISCHANNELS = 319; RPL_LISTSTART = 321;
		RPL_LIST = 322; RPL_LISTEND = 323;
		RPL_CHANNELMODEIS = 324; RPL_UNIQOPIS = 325;
		RPL_NOTOPIC = 331; RPL_TOPIC = 332;
		RPL_INVITING = 341; RPL_SUMMONING = 342;
		RPL_INVITELIST = 346; RPL_ENDOFINVITELIST = 347;
		RPL_EXCEPTLIST = 348; RPL_ENDOFEXCEPTLIST = 349;
		RPL_VERSION = 351; RPL_WHOREPLY = 352;
		RPL_NAMREPLY = 353; RPL_LINKS = 364;
		RPL_ENDOFLINKS = 365; RPL_ENDOFNAMES = 366;
		RPL_BANLIST = 367; RPL_ENDOFBANLIST = 367;
		RPL_ENDOFWHOWAS = 369; RPL_INFO = 371;
		RPL_MOTD = 372; RPL_ENDOFINFO = 374;
		RPL_MOTDSTART = 375; RPL_ENDOFMOTD = 376;
		RPL_YOUREOPER = 381; RPL_REHASHING = 382;
		RPL_YOURESERVICE = 383; RPL_TIME = 391;
		RPL_USERSSTART = 392; RPL_USERS = 393;
		RPL_ENDOFUSERS = 394; RPL_NOUSERS = 395;

instance fromInt IRCErrors where
	fromInt r = case r of
		401 = ERR_NOSUCHNICK; 402 = ERR_NOSUCHSERVER;
		403 = ERR_NOSUCHCHANNEL; 404 = ERR_CANNOTSENDTOCHAN;
		405 = ERR_TOOMANYCHANNELS; 406 = ERR_WASNOSUCHNICK;
		407 = ERR_TOOMANYTARGETS; 408 = ERR_NOSUCHSERVICE;
		409 = ERR_NOORIGIN; 411 = ERR_NORECIPIENT;
		412 = ERR_NOTEXTTOSEND; 413 = ERR_NOTOPLEVEL;
		414 = ERR_WILDTOPLEVEL; 415 = ERR_BADMASK;
		421 = ERR_UNKNOWNCOMMAND; 422 = ERR_NOMOTD;
		423 = ERR_NOADMININFO; 424 = ERR_FILEERROR;
		431 = ERR_NONICKNAMEGIVEN; 432 = ERR_ERRONEUSNICKNAME;
		433 = ERR_NICKNAMEINUSE; 436 = ERR_NICKCOLLISION;
		437 = ERR_UNAVAILRESOURCE; 441 = ERR_USERNOTINCHANNEL;
		442 = ERR_NOTONCHANNEL; 443 = ERR_USERONCHANNEL;
		444 = ERR_NOLOGIN; 445 = ERR_SUMMONDISABLED;
		446 = ERR_USERSDISABLED; 451 = ERR_NOTREGISTERED;
		461 = ERR_NEEDMOREPARAMS; 462 = ERR_ALREADYREGISTRED;
		463 = ERR_NOPERMFORHOST; 464 = ERR_PASSWDMISMATCH;
		465 = ERR_YOUREBANNEDCREEP; 466 = ERR_YOUWILLBEBANNED;
		467 = ERR_KEYSET; 471 = ERR_CHANNELISFULL;
		472 = ERR_UNKNOWNMODE; 473 = ERR_INVITEONLYCHAN;
		474 = ERR_BANNEDFROMCHAN; 475 = ERR_BADCHANNELKEY;
		476 = ERR_BADCHANMASK; 477 = ERR_NOCHANMODES;
		478 = ERR_BANLISTFULL; 481 = ERR_NOPRIVILEGES;
		482 = ERR_CHANOPRIVSNEEDED; 483 = ERR_CANTKILLSERVER;
		484 = ERR_RESTRICTED; 485 = ERR_UNIQOPPRIVSNEEDED;
		491 = ERR_NOOPERHOST; 501 = ERR_UMODEUNKNOWNFLAG;
		502 = ERR_USERSDONTMATCH;

instance toInt IRCErrors where
	toInt r = case r of
		ERR_NOSUCHNICK = 401; ERR_NOSUCHSERVER = 402;
		ERR_NOSUCHCHANNEL = 403; ERR_CANNOTSENDTOCHAN = 404;
		ERR_TOOMANYCHANNELS = 405; ERR_WASNOSUCHNICK = 406;
		ERR_TOOMANYTARGETS = 407; ERR_NOSUCHSERVICE = 408;
		ERR_NOORIGIN = 409; ERR_NORECIPIENT = 411;
		ERR_NOTEXTTOSEND = 412; ERR_NOTOPLEVEL = 413;
		ERR_WILDTOPLEVEL = 414; ERR_BADMASK = 415;
		ERR_UNKNOWNCOMMAND = 421; ERR_NOMOTD = 422;
		ERR_NOADMININFO = 423; ERR_FILEERROR = 424;
		ERR_NONICKNAMEGIVEN = 431; ERR_ERRONEUSNICKNAME = 432;
		ERR_NICKNAMEINUSE = 433; ERR_NICKCOLLISION = 436;
		ERR_UNAVAILRESOURCE = 437; ERR_USERNOTINCHANNEL = 441;
		ERR_NOTONCHANNEL = 442; ERR_USERONCHANNEL = 443;
		ERR_NOLOGIN = 444; ERR_SUMMONDISABLED = 445;
		ERR_USERSDISABLED = 446; ERR_NOTREGISTERED = 451;
		ERR_NEEDMOREPARAMS = 461; ERR_ALREADYREGISTRED = 462;
		ERR_NOPERMFORHOST = 463; ERR_PASSWDMISMATCH = 464;
		ERR_YOUREBANNEDCREEP = 465; ERR_YOUWILLBEBANNED = 466;
		ERR_KEYSET = 467; ERR_CHANNELISFULL = 471;
		ERR_UNKNOWNMODE = 472; ERR_INVITEONLYCHAN = 473;
		ERR_BANNEDFROMCHAN = 474; ERR_BADCHANNELKEY = 475;
		ERR_BADCHANMASK = 476; ERR_NOCHANMODES = 477;
		ERR_BANLISTFULL = 478; ERR_NOPRIVILEGES = 481;
		ERR_CHANOPRIVSNEEDED = 482; ERR_CANTKILLSERVER = 483;
		ERR_RESTRICTED = 484; ERR_UNIQOPPRIVSNEEDED = 485;
		ERR_NOOPERHOST = 491; ERR_UMODEUNKNOWNFLAG = 501;
		ERR_USERSDONTMATCH = 502;

implementation module IRC

import StdList, StdTuple, StdOverloaded, StdFunc, StdString, StdChar, StdBool
import _SystemArray

import GenPrint
import GenIRC

import Control.Applicative
import Control.Monad
import Data.Either
import Data.Maybe
import Data.Tuple
import Text.Parsers.Simple.Chars
import Text.Parsers.Simple.Core

import StdDebug

from Data.Functor import <$>
from Data.Func import $
from StdMisc import undef, abort
from Text import class Text(lpad,trim,rtrim,split,indexOf,concat),
	instance Text String
import qualified Text

jon :== 'Text'.join

derive gPrint IRCErrors, IRCReplies, Maybe, Either, IRCUser, IRCNumReply

Start = (map (fmap toString) msgs, msgs)
where
	msgs =
		[ parseIRCMessage ":clooglebot!~cloogle@dhcp-077-249-221-037.chello.nl QUIT\r\n"
		, parseIRCMessage ":clooglebot!~cloogle QUIT\r\n"
		, parseIRCMessage ":frobnicator!~frobnicat@92.110.128.124 QUIT\r\n"
		, parseIRCMessage ":frobnicator!~frobnicat@92.110.128.124 AWAY test\r\n"
		, parseIRCMessage ":frobnicator!~frobnicat@92.110.128.124 AWAY :test with spaces\r\n"
		, parseIRCMessage ":cherryh.freenode.net NOTICE * :*** Found your hostname\r\n"
		, parseIRCMessage ":cherryh.freenode.net QUIT :hoi hoi\r\n"
		, parseIRCMessage ":cherryh.freenode.net JOIN #cha,#ch-b #twilight\r\n"
		, parseIRCMessage ":cherryh.freenode.net ISON a b c d e f :g h\r\n"
		, parseIRCMessage ":wilhelm.freenode.net 001 clooglebot :Welcome to the freenode Internet Relay Chat Network clooglebot\r\n"
		, parseIRCMessage "PING :orwell.freenode.net\r\n"
		, parseIRCMessage ":ChanServ!ChanServ@services. MODE #cloogle +o frobnicator\r\n"
		]

parseIRCMessage :: String -> Either [Error] IRCMessage
parseIRCMessage s = case runParser parsePrefix (fromString s) of
	// Prefix is parsed
	([(prefix, rest):_], _)
		//Try parsing a numeric reply
		= case parse parseReply rest of
			//Try a normal command
			Left e = case parseCmd rest of
				Left e2 = Left [e2:e]
				Right cmd = Right {IRCMessage | irc_prefix=prefix, irc_command=Right cmd}
			Right repl = Right {IRCMessage | irc_prefix=prefix, irc_command=Left repl}
	// Error parsing prefix
	(_, es) = Left ["Error parsing prefix"]

//Prefix
parsePrefix :: Parser Char (Maybe (Either IRCUser String))
parsePrefix
	= optional (pToken ':' >>| parseEither parseUser parseHost <* pToken ' ')
where
	parseEither :: (Parser a b) (Parser a c) -> Parser a (Either b c)
	parseEither p q = Left <$> p <|> Right <$> q

	parseUser :: Parser Char IRCUser
	parseUser = parseNick
			>>= \nick->optional (pToken '!' >>| parseUsr)
			>>= \muser->optional (pToken '@' >>| parseHost)
			>>= \mhost->pure {IRCUser
				| irc_nick=nick, irc_user=muser, irc_host=mhost}

	parseUsr :: Parser Char String
	parseUsr = toString <$> pSome (pNoneOf [' ', '@':illegal])

	parseNick :: Parser Char String
	parseNick = pAlpha
		>>= \c ->pMany (pAlpha <|> pDigit <|> pOneOf (fromString "-[]\\`^{}"))
		>>= \cs->pure (toString [c:cs])

	parseHost :: Parser Char String
	parseHost = jon "." <$> (pSepBy parseName (pToken '.'))
		>>= \s->optional (pToken '.') >>= pure o maybe s (\p->s+++toString s)
		where
			parseName :: Parser Char String
			parseName = toString <$> pSome (pAlpha <|> pDigit <|> pOneOf ['-'])

//Parse Cmd
parseCmd :: [Char] -> Either Error IRCCommand
parseCmd cs = fst $ gIRCParse{|*|} $ argfun $ split " " $ toString cs
	where
		argfun :: [String] -> [String]
		argfun [] = []
		argfun [x:xs]
		# x = trim x
		| x.[0] == ':' = [jon " " $ [x % (1, size x):map rtrim xs]]
		| otherwise = [x:argfun xs]

//Reply

parseReply :: Parser Char IRCNumReply
parseReply = spaceParser
	>>|       (pMany (pToken '0') >>| pSome pDigit <* spaceParser)
	>>= \rep->(toString <$> pSome (pNoneOf [' ':illegal]) <* spaceParser)
	>>= \rec->(toString <$> pSome (pNoneOf illegal))
	>>= \msg->pure {IRCNumReply
		| irc_reply     = fromInt $ toInt $ toString rep
		, irc_recipient = rec
		, irc_message   = msg % (if (msg.[0] == ':') 1 0, size msg)
		}
	<* pToken '\r' <* pToken '\n'
	where
		spaceParser :: Parser Char [Char]
		spaceParser = pMany $ pToken ' '

//Common parsers
pNoneOf :: [a] -> Parser a a | Eq a
pNoneOf l = pSatisfy (not o flip isMember l)

illegal :: [Char]
illegal = ['\x00','\r','\n']

instance toString IRCNumReply where
	toString m = lpad (toString $ toInt m.irc_reply) 3 '0' <+ " " <+
		m.irc_recipient <+ " " <+ concat (gIRCPrint{|*|} m.irc_message)
instance toString IRCMessage where
	toString m = maybe "" (\s->either ((<+) ":") id s <+ " ") m.irc_prefix
		<+ either toString toString m.irc_command
instance toString IRCUser where
	toString m = m.irc_nick <+ maybe "" ((<+) "!") m.irc_user
		<+ maybe "" ((<+) "@") m.irc_host
instance toString IRCCommand where
	toString m = jon " " (gIRCPrint{|*|} m) +++ "\r\n"
instance toString IRCReplies where toString r = printToString r
instance toString IRCErrors where toString r = printToString r

(<+) infixr 5 :: a b -> String | toString a & toString b
(<+) a b = toString a +++ toString b

instance fromInt IRCReplies where
	fromInt r = case r of
		1 = RPL_WELCOME; 2 = RPL_YOURHOST;
		3 = RPL_CREATED; 4 = RPL_MYINFO;
		5 = RPL_BOUNCE; 200 = RPL_TRACELINK;
		201 = RPL_TRACECONNECTING; 202 = RPL_TRACEHANDSHAKE;
		203 = RPL_TRACEUNKNOWN; 204 = RPL_TRACEOPERATOR;
		205 = RPL_TRACEUSER; 206 = RPL_TRACESERVER;
		207 = RPL_TRACESERVICE; 208 = RPL_TRACENEWTYPE;
		209 = RPL_TRACECLASS; 210 = RPL_TRACERECONNECT;
		211 = RPL_STATSLINKINFO; 212 = RPL_STATSCOMMANDS;
		219 = RPL_ENDOFSTATS; 221 = RPL_UMODEIS;
		234 = RPL_SERVLIST; 235 = RPL_SERVLISTEND;
		242 = RPL_STATSUPTIME; 243 = RPL_STATSOLINE;
		251 = RPL_LUSERCLIENT; 252 = RPL_LUSEROP;
		253 = RPL_LUSERUNKNOWN; 254 = RPL_LUSERCHANNELS;
		255 = RPL_LUSERME; 256 = RPL_ADMINME;
		257 = RPL_ADMINLOC1; 258 = RPL_ADMINLOC2;
		259 = RPL_ADMINEMAIL; 261 = RPL_TRACELOG;
		262 = RPL_TRACEEND; 263 = RPL_TRYAGAIN;
		301 = RPL_AWAY; 302 = RPL_USERHOST;
		303 = RPL_ISON; 304 = RPL_UNAWAY;
		305 = RPL_NOWAWAY; 311 = RPL_WHOISUSER;
		312 = RPL_WHOISSERVER; 313 = RPL_WHOISOPERATOR;
		314 = RPL_WHOWASUSER; 315 = RPL_ENDOFWHO;
		317 = RPL_WHOISIDLE; 318 = RPL_ENDOFWHOIS;
		319 = RPL_WHOISCHANNELS; 321 = RPL_LISTSTART;
		322 = RPL_LIST; 323 = RPL_LISTEND;
		324 = RPL_CHANNELMODEIS; 325 = RPL_UNIQOPIS;
		331 = RPL_NOTOPIC; 332 = RPL_TOPIC;
		341 = RPL_INVITING; 342 = RPL_SUMMONING;
		346 = RPL_INVITELIST; 347 = RPL_ENDOFINVITELIST;
		348 = RPL_EXCEPTLIST; 349 = RPL_ENDOFEXCEPTLIST;
		351 = RPL_VERSION; 352 = RPL_WHOREPLY;
		353 = RPL_NAMREPLY; 364 = RPL_LINKS;
		365 = RPL_ENDOFLINKS; 366 = RPL_ENDOFNAMES;
		367 = RPL_BANLIST; 368 = RPL_ENDOFBANLIST;
		369 = RPL_ENDOFWHOWAS; 371 = RPL_INFO;
		372 = RPL_MOTD; 374 = RPL_ENDOFINFO;
		375 = RPL_MOTDSTART; 376 = RPL_ENDOFMOTD;
		381 = RPL_YOUREOPER; 382 = RPL_REHASHING;
		383 = RPL_YOURESERVICE; 391 = RPL_TIME;
		392 = RPL_USERSSTART; 393 = RPL_USERS;
		394 = RPL_ENDOFUSERS; 395 = RPL_NOUSERS;
		_ = abort $ "fromInt IRCReplies: " +++ toString r +++ " undef\n"

instance toInt IRCReplies where
	toInt r = case r of
		RPL_WELCOME = 1; RPL_YOURHOST = 2;
		RPL_CREATED = 3; RPL_MYINFO = 4;
		RPL_BOUNCE = 5; RPL_TRACELINK = 200;
		RPL_TRACECONNECTING = 201; RPL_TRACEHANDSHAKE = 202;
		RPL_TRACEUNKNOWN = 203; RPL_TRACEOPERATOR = 204;
		RPL_TRACEUSER = 205; RPL_TRACESERVER = 206;
		RPL_TRACESERVICE = 207; RPL_TRACENEWTYPE = 208;
		RPL_TRACECLASS = 209; RPL_TRACERECONNECT = 210;
		RPL_STATSLINKINFO = 211; RPL_STATSCOMMANDS = 212;
		RPL_ENDOFSTATS = 219; RPL_UMODEIS = 221;
		RPL_SERVLIST = 234; RPL_SERVLISTEND = 234;
		RPL_STATSUPTIME = 242; RPL_STATSOLINE = 243;
		RPL_LUSERCLIENT = 251; RPL_LUSEROP = 252;
		RPL_LUSERUNKNOWN = 253; RPL_LUSERCHANNELS = 254;
		RPL_LUSERME = 255; RPL_ADMINME = 256;
		RPL_ADMINLOC1 = 257; RPL_ADMINLOC2 = 258;
		RPL_ADMINEMAIL = 259; RPL_TRACELOG = 261;
		RPL_TRACEEND = 262; RPL_TRYAGAIN = 263;
		RPL_AWAY = 301; RPL_USERHOST = 302;
		RPL_ISON = 303; RPL_UNAWAY = 304;
		RPL_NOWAWAY = 305; RPL_WHOISUSER = 311;
		RPL_WHOISSERVER = 312; RPL_WHOISOPERATOR = 313;
		RPL_WHOWASUSER = 314; RPL_ENDOFWHO = 315;
		RPL_WHOISIDLE = 317; RPL_ENDOFWHOIS = 318;
		RPL_WHOISCHANNELS = 319; RPL_LISTSTART = 321;
		RPL_LIST = 322; RPL_LISTEND = 323;
		RPL_CHANNELMODEIS = 324; RPL_UNIQOPIS = 325;
		RPL_NOTOPIC = 331; RPL_TOPIC = 332;
		RPL_INVITING = 341; RPL_SUMMONING = 342;
		RPL_INVITELIST = 346; RPL_ENDOFINVITELIST = 347;
		RPL_EXCEPTLIST = 348; RPL_ENDOFEXCEPTLIST = 349;
		RPL_VERSION = 351; RPL_WHOREPLY = 352;
		RPL_NAMREPLY = 353; RPL_LINKS = 364;
		RPL_ENDOFLINKS = 365; RPL_ENDOFNAMES = 366;
		RPL_BANLIST = 367; RPL_ENDOFBANLIST = 367;
		RPL_ENDOFWHOWAS = 369; RPL_INFO = 371;
		RPL_MOTD = 372; RPL_ENDOFINFO = 374;
		RPL_MOTDSTART = 375; RPL_ENDOFMOTD = 376;
		RPL_YOUREOPER = 381; RPL_REHASHING = 382;
		RPL_YOURESERVICE = 383; RPL_TIME = 391;
		RPL_USERSSTART = 392; RPL_USERS = 393;
		RPL_ENDOFUSERS = 394; RPL_NOUSERS = 395;

instance fromInt IRCErrors where
	fromInt r = case r of
		401 = ERR_NOSUCHNICK; 402 = ERR_NOSUCHSERVER;
		403 = ERR_NOSUCHCHANNEL; 404 = ERR_CANNOTSENDTOCHAN;
		405 = ERR_TOOMANYCHANNELS; 406 = ERR_WASNOSUCHNICK;
		407 = ERR_TOOMANYTARGETS; 408 = ERR_NOSUCHSERVICE;
		409 = ERR_NOORIGIN; 411 = ERR_NORECIPIENT;
		412 = ERR_NOTEXTTOSEND; 413 = ERR_NOTOPLEVEL;
		414 = ERR_WILDTOPLEVEL; 415 = ERR_BADMASK;
		421 = ERR_UNKNOWNCOMMAND; 422 = ERR_NOMOTD;
		423 = ERR_NOADMININFO; 424 = ERR_FILEERROR;
		431 = ERR_NONICKNAMEGIVEN; 432 = ERR_ERRONEUSNICKNAME;
		433 = ERR_NICKNAMEINUSE; 436 = ERR_NICKCOLLISION;
		437 = ERR_UNAVAILRESOURCE; 441 = ERR_USERNOTINCHANNEL;
		442 = ERR_NOTONCHANNEL; 443 = ERR_USERONCHANNEL;
		444 = ERR_NOLOGIN; 445 = ERR_SUMMONDISABLED;
		446 = ERR_USERSDISABLED; 451 = ERR_NOTREGISTERED;
		461 = ERR_NEEDMOREPARAMS; 462 = ERR_ALREADYREGISTRED;
		463 = ERR_NOPERMFORHOST; 464 = ERR_PASSWDMISMATCH;
		465 = ERR_YOUREBANNEDCREEP; 466 = ERR_YOUWILLBEBANNED;
		467 = ERR_KEYSET; 471 = ERR_CHANNELISFULL;
		472 = ERR_UNKNOWNMODE; 473 = ERR_INVITEONLYCHAN;
		474 = ERR_BANNEDFROMCHAN; 475 = ERR_BADCHANNELKEY;
		476 = ERR_BADCHANMASK; 477 = ERR_NOCHANMODES;
		478 = ERR_BANLISTFULL; 481 = ERR_NOPRIVILEGES;
		482 = ERR_CHANOPRIVSNEEDED; 483 = ERR_CANTKILLSERVER;
		484 = ERR_RESTRICTED; 485 = ERR_UNIQOPPRIVSNEEDED;
		491 = ERR_NOOPERHOST; 501 = ERR_UMODEUNKNOWNFLAG;
		502 = ERR_USERSDONTMATCH;

instance toInt IRCErrors where
	toInt r = case r of
		ERR_NOSUCHNICK = 401; ERR_NOSUCHSERVER = 402;
		ERR_NOSUCHCHANNEL = 403; ERR_CANNOTSENDTOCHAN = 404;
		ERR_TOOMANYCHANNELS = 405; ERR_WASNOSUCHNICK = 406;
		ERR_TOOMANYTARGETS = 407; ERR_NOSUCHSERVICE = 408;
		ERR_NOORIGIN = 409; ERR_NORECIPIENT = 411;
		ERR_NOTEXTTOSEND = 412; ERR_NOTOPLEVEL = 413;
		ERR_WILDTOPLEVEL = 414; ERR_BADMASK = 415;
		ERR_UNKNOWNCOMMAND = 421; ERR_NOMOTD = 422;
		ERR_NOADMININFO = 423; ERR_FILEERROR = 424;
		ERR_NONICKNAMEGIVEN = 431; ERR_ERRONEUSNICKNAME = 432;
		ERR_NICKNAMEINUSE = 433; ERR_NICKCOLLISION = 436;
		ERR_UNAVAILRESOURCE = 437; ERR_USERNOTINCHANNEL = 441;
		ERR_NOTONCHANNEL = 442; ERR_USERONCHANNEL = 443;
		ERR_NOLOGIN = 444; ERR_SUMMONDISABLED = 445;
		ERR_USERSDISABLED = 446; ERR_NOTREGISTERED = 451;
		ERR_NEEDMOREPARAMS = 461; ERR_ALREADYREGISTRED = 462;
		ERR_NOPERMFORHOST = 463; ERR_PASSWDMISMATCH = 464;
		ERR_YOUREBANNEDCREEP = 465; ERR_YOUWILLBEBANNED = 466;
		ERR_KEYSET = 467; ERR_CHANNELISFULL = 471;
		ERR_UNKNOWNMODE = 472; ERR_INVITEONLYCHAN = 473;
		ERR_BANNEDFROMCHAN = 474; ERR_BADCHANNELKEY = 475;
		ERR_BADCHANMASK = 476; ERR_NOCHANMODES = 477;
		ERR_BANLISTFULL = 478; ERR_NOPRIVILEGES = 481;
		ERR_CHANOPRIVSNEEDED = 482; ERR_CANTKILLSERVER = 483;
		ERR_RESTRICTED = 484; ERR_UNIQOPPRIVSNEEDED = 485;
		ERR_NOOPERHOST = 491; ERR_UMODEUNKNOWNFLAG = 501;
		ERR_USERSDONTMATCH = 502;