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.JSON

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.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 <$> 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
	}

:: 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.JSON

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.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
          }

Fix cache reloading

Fix cache reloading


implementation module IRCBot

from Data.Func import $
import Data.Either
import Data.Error
import Data.Maybe
import IRC
import TCPIP

from Text import class Text(split,join), instance Text String

import StdList
import StdBool

TIMEOUT :== Just 1000

bot :: (String, Int) [IRCMessage] [IRCMessage] .a (IRCMessage .a *World -> .(Maybe [IRCMessage], .a, *World)) *World -> *(Maybe String, .a, *World)
bot (host, port) start end state bot w
//Lookup hostname
# (ip, w) = lookupIPAddress host w
| isNothing ip
	= (Error $ "DNS lookup for " +++ host +++ " failed", state, w)
//Connect
# (rpt,chan,w) = connectTCP_MT TIMEOUT (fromJust ip, port) w
| rpt == TR_Expired
	= (Error $ "Connection to " +++ host +++ " timed out", state, w)
| rpt == TR_NoSuccess
	= (Error $ "Could not connect to " +++ host, state, w)
// Send startup commands
# (merr, chan, w) = send (map toString start) (fromJust chan) w
| isError merr = (Error $ fromError merr, state, w)
//Start processing function
# (mer, chan, state, w) = process chan "" state bot w
| isError mer = (Error $ fromError mer, state, w)
// Send shutdown commands
# (merr, {rChannel,sChannel}, w) = send (map toString end) chan w
| isError merr = (Error $ fromError merr, state, w)
//Close channels
= (Ok state, state, closeChannel sChannel (closeRChannel rChannel w))

process :: TCP_DuplexChannel String .a (IRCMessage .a *World -> *(Maybe [IRCMessage], .a, *World)) *World -> *(MaybeErrorString (), TCP_DuplexChannel, .a, *World)
process chan acc state bot w
//See if we have a message
= case split "\r\n" acc of
	//We only have one message that is not complete
	[m]
		//Receive
		# (merr_resp, chan, w) = recv chan w
		| isError merr_resp = (Error (fromError merr_resp), chan, state, w)
		# (Ok mresp) = merr_resp
		| isNothing mresp = process chan acc state bot w
		= process chan (m +++ fromJust mresp) state bot w
	//We have a successfull split and therefore we process at least one message
	[m:xs]
		# acc = join "\r\n" xs
		= case parseIRCMessage $ m +++ "\r\n" of
			(Left err) = (Error $ "IRC Parsing error: " +++ join "\n" err, chan, state, w)
			(Right msg)
			# (mircc, state, w) = bot msg state w
			| isNothing mircc = (Ok (), chan, state, w) // Bot asks to quit
			//Possible send the commands
			# (merr, chan, w) = send (map toString $ fromJust mircc) chan w
			| isError merr = (Error $ fromError merr, chan, state, w)
			//Recurse
			= process chan acc state bot w

send :: ![String] !TCP_DuplexChannel !*World -> (!MaybeErrorString (), !TCP_DuplexChannel, !*World)
send [] chan w = (Ok (), chan, w)
send [msg:msgs] {sChannel,rChannel} w
# (rpt,i,sChannel,w) = send_MT TIMEOUT (toByteSeq msg) sChannel w
| rpt <> TR_Success = (Error "Could not send message", {sChannel=sChannel,rChannel=rChannel}, w)
# (_, w) = sleep 500000 w
= send msgs {sChannel=sChannel,rChannel=rChannel} w
	where
		sleep :: !Int !*World -> (!Int, *World)
		sleep i w = code {
				ccall usleep "I:I:A"
			}

recv :: TCP_DuplexChannel *World -> (MaybeErrorString (Maybe String), TCP_DuplexChannel, *World)
recv {sChannel,rChannel} w
# (rpt, resp, rChannel, w) = receive_MT TIMEOUT rChannel w
| rpt == TR_Expired = (Ok Nothing, {sChannel=sChannel,rChannel=rChannel}, w)
| rpt == TR_NoSuccess || isNothing resp = (Error "Timeout recv fail", {sChannel=sChannel,rChannel=rChannel}, w)
= (Ok $ Just $ toString $ fromJust resp, {sChannel=sChannel,rChannel=rChannel}, w)

implementation module IRCBot

from Data.Func import $
import Data.Either
import Data.Error
import Data.Maybe
import IRC
import TCPIP

from Text import class Text(split,join), instance Text String

import StdList
import StdBool

TIMEOUT :== Just 1000

bot :: (String, Int) [IRCMessage] [IRCMessage] .a (IRCMessage .a *World -> *(Maybe [IRCMessage], .a, *World)) *World -> *(Maybe String, .a, *World)
bot (host, port) start end state bot w
//Lookup hostname
# (ip, w) = lookupIPAddress host w
| isNothing ip
	= (Just $ "DNS lookup for " +++ host +++ " failed", state, w)
//Connect
# (rpt,chan,w) = connectTCP_MT TIMEOUT (fromJust ip, port) w
| rpt == TR_Expired
	= (Just $ "Connection to " +++ host +++ " timed out", state, w)
| rpt == TR_NoSuccess
	= (Just $ "Could not connect to " +++ host, state, w)
// Send startup commands
# (merr, chan, w) = send (map toString start) (fromJust chan) w
| isError merr = (Just $ fromError merr, state, w)
//Start processing function
# (mer, chan, state, w) = process chan "" state bot w
| isError mer = (Just $ fromError mer, state, w)
// Send shutdown commands
# (merr, {rChannel,sChannel}, w) = send (map toString end) chan w
| isError merr = (Just $ fromError merr, state, w)
//Close channels
= (Nothing, state, closeChannel sChannel (closeRChannel rChannel w))

process :: TCP_DuplexChannel String .a (IRCMessage .a *World -> *(Maybe [IRCMessage], .a, *World)) *World -> *(MaybeErrorString (), TCP_DuplexChannel, .a, *World)
process chan acc state bot w
//See if we have a message
= case split "\r\n" acc of
	//We only have one message that is not complete
	[m]
		//Receive
		# (merr_resp, chan, w) = recv chan w
		| isError merr_resp = (Error (fromError merr_resp), chan, state, w)
		# (Ok mresp) = merr_resp
		| isNothing mresp = process chan acc state bot w
		= process chan (m +++ fromJust mresp) state bot w
	//We have a successfull split and therefore we process at least one message
	[m:xs]
		# acc = join "\r\n" xs
		= case parseIRCMessage $ m +++ "\r\n" of
			(Left err) = (Error $ "IRC Parsing error: " +++ join "\n" err, chan, state, w)
			(Right msg)
			# (mircc, state, w) = bot msg state w
			| isNothing mircc = (Ok (), chan, state, w) // Bot asks to quit
			//Possible send the commands
			# (merr, chan, w) = send (map toString $ fromJust mircc) chan w
			| isError merr = (Error $ fromError merr, chan, state, w)
			//Recurse
			= process chan acc state bot w

send :: ![String] !TCP_DuplexChannel !*World -> (!MaybeErrorString (), !TCP_DuplexChannel, !*World)
send [] chan w = (Ok (), chan, w)
send [msg:msgs] {sChannel,rChannel} w
# (rpt,i,sChannel,w) = send_MT TIMEOUT (toByteSeq msg) sChannel w
| rpt <> TR_Success = (Error "Could not send message", {sChannel=sChannel,rChannel=rChannel}, w)
# (_, w) = sleep 500000 w
= send msgs {sChannel=sChannel,rChannel=rChannel} w
	where
		sleep :: !Int !*World -> (!Int, *World)
		sleep i w = code {
				ccall usleep "I:I:A"
			}

recv :: TCP_DuplexChannel *World -> (MaybeErrorString (Maybe String), TCP_DuplexChannel, *World)
recv {sChannel,rChannel} w
# (rpt, resp, rChannel, w) = receive_MT TIMEOUT rChannel w
| rpt == TR_Expired = (Ok Nothing, {sChannel=sChannel,rChannel=rChannel}, w)
| rpt == TR_NoSuccess || isNothing resp = (Error "Timeout recv fail", {sChannel=sChannel,rChannel=rChannel}, w)
= (Ok $ Just $ toString $ fromJust resp, {sChannel=sChannel,rChannel=rChannel}, w)

fix ircbot code

fix ircbot code


module CloogleServer

import StdArray, StdBool, StdFile, StdList, StdOrdList, StdOverloaded, StdTuple
from StdFunc import o, flip
from StdMisc import abort

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

from Data.Func import $
import Data.List
import Data.Maybe
import System.CommandLine
import Text.JSON
import Data.Functor
import Control.Applicative
import Control.Monad
from Text import class Text(concat,trim,indexOf,toLowerCase),
	instance Text String, instance + String

import System.Time

import qualified StdMaybe as OldMaybe
from SimpleTCPServer import :: LogMessage{..}, serve, :: Logger
import qualified SimpleTCPServer
import TypeDB
import Type
import Levenshtein

:: OldMaybe a :== 'SimpleTCPServer'.Maybe a

:: Request = { unify     :: Maybe String
             , name      :: Maybe String
             , className :: Maybe String
             , typeName  :: Maybe String
             , modules   :: Maybe [String]
             , page      :: Maybe Int
             }

:: Response = { return         :: Int
              , data           :: [Result]
              , msg            :: String
              , more_available :: Maybe Int
              , suggestions    :: Maybe [(Request, Int)]
              }

:: Result = FunctionResult FunctionResult
          | TypeResult TypeResult
          | ClassResult ClassResult
          | MacroResult MacroResult

:: BasicResult = { library  :: String
                 , filename :: String
                 , modul    :: String
                 , distance :: Int
                 }

:: FunctionResult :== (BasicResult, FunctionResultExtras)
:: FunctionResultExtras = { func     :: String
                          , unifier  :: Maybe StrUnifier
                          , cls      :: Maybe ShortClassResult
                          , constructor_of :: Maybe String
                          , generic_derivations :: Maybe [String]
                          }

:: TypeResult :== (BasicResult, TypeResultExtras)
:: TypeResultExtras = { type :: String
                      }

:: ClassResult :== (BasicResult, ClassResultExtras)
:: ClassResultExtras = { class_name :: String
                       , class_heading :: String
                       , class_funs :: [String]
                       , class_instances :: [String]
                       }

:: MacroResult :== (BasicResult, MacroResultExtras)
:: MacroResultExtras = { macro_name :: String
                       , macro_representation :: String
                       }

:: StrUnifier :== ([(String,String)], [(String,String)])

:: ErrorResult = Error Int String

:: ShortClassResult = { cls_name :: String, cls_vars :: [String] }

derive JSONEncode Request, Response, Result, ShortClassResult, BasicResult,
	FunctionResultExtras, TypeResultExtras, ClassResultExtras, MacroResultExtras
derive JSONDecode Request, Response, Result, ShortClassResult, BasicResult,
	FunctionResultExtras, TypeResultExtras, ClassResultExtras, MacroResultExtras

instance zero Request
where
	zero = { unify     = Nothing
	       , name      = Nothing
	       , className = Nothing
	       , typeName  = Nothing
	       , modules   = Nothing
	       , page      = Nothing
	       }

instance toString Response where toString r = toString (toJSON r) + "\n"
instance toString Request where toString r = toString $ toJSON r

instance fromString (Maybe Request) where fromString s = fromJSON $ fromString s

instance < BasicResult where (<) r1 r2 = r1.distance < r2.distance
instance < Result
where
	(<) r1 r2 = basic r1 < basic r2
	where
		basic :: Result -> BasicResult
		basic (FunctionResult (br,_)) = br
		basic (TypeResult (br,_)) = br
		basic (ClassResult (br,_)) = br
		basic (MacroResult (br,_)) = br

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

E_NORESULTS :== 127
E_INVALIDINPUT :== 128
E_INVALIDNAME :== 129
E_INVALIDTYPE :== 130

MAX_RESULTS :== 15

Start w
# (io, w) = stdio w
# (cmdline, w) = getCommandLine w
| length cmdline <> 2 = help io w
# [_,port:_] = cmdline
# port = toInt port
# (db, io) = openDb io
# (_, w) = fclose io w
| isNothing db = abort "stdin does not have a TypeDB\n"
#! db = fromJust db
= serve (handle db) ('OldMaybe'.Just log) port w
where
	help :: *File *World -> *World
	help io w
	# io = io <<< "Usage: ./CloogleServer <port>\n"
	= snd $ fclose io w

	handle :: !TypeDB !(Maybe Request) !*World -> *(!Response, !*World)
	handle _ Nothing w = (err E_INVALIDINPUT "Couldn't parse input", w)
	handle db (Just request=:{unify,name,modules,page}) w
		| isJust name && size (fromJust name) > 40
			= (err E_INVALIDNAME "function name too long", w)
		| isJust name && any isSpace (fromString $ fromJust name)
			= (err E_INVALIDNAME "name cannot contain spaces", w)
		| isJust unify && isNothing (parseType $ fromString $ fromJust unify)
			= (err E_INVALIDTYPE "couldn't parse type", w)
		// Results
		# drop_n = fromJust (page <|> pure 0) * MAX_RESULTS
		# results = drop drop_n $ sort $ search request db
		# more = max 0 (length results - MAX_RESULTS)
		// Suggestions
		# mbType = unify >>= parseType o fromString
		# suggestions
			= sortBy (\a b -> snd a > snd b) <$>
			  filter ((<)(length results) o snd) <$>
			  (mbType >>= \t -> suggs name t db)
		# results = take MAX_RESULTS results
		// Response
		| isEmpty results = (err E_NORESULTS "No results", w)
		= ( { return = 0
		    , msg = "Success"
		    , data           = results
		    , more_available = Just more
		    , suggestions    = suggestions
		    }
		  , w)

	suggs :: !(Maybe String) !Type !TypeDB -> Maybe [(Request, Int)]
	suggs n (Func is r cc) db
		| length is < 3
			= Just [let t` = concat $ print False $ Func is` r cc in
			        let request = {zero & name=n, unify=Just t`} in
			        (request, length $ search request db)
			        \\ is` <- permutations is | is` <> is]
	suggs _ _ _ = Nothing

	search :: !Request !TypeDB -> [Result]
	search {unify,name,className,typeName,modules,page} db
		| isJust className
			# className = fromJust className
			# classes = findClass className db
			= map (flip makeClassResult db) classes
		| isJust typeName
			# typeName = fromJust typeName
			# types = findType typeName db
			= map (uncurry (makeTypeResult (Just typeName))) types
		# mbType = prepare_unification True <$> (unify >>= parseType o fromString)
		// Search normal functions
		# filts = catMaybes [ (\t _ -> isUnifiable t) <$> mbType
		                    , (\n loc _ -> isNameMatch (size n-2) n loc) <$> name
		                    , isModMatchF <$> modules
		                    ]
		# funs = map (\f -> makeFunctionResult name mbType Nothing f db) $ findFunction`` filts db
		// Search macros
		# macros = case name of
			Nothing  = []
			(Just n) = findMacro` (\(ML lib mod m) _ -> isNameMatch (size n-2) n (FL lib mod m)) db
		# macros = map (\(lhs,rhs) -> makeMacroResult name lhs rhs) macros
		// Search class members
		# filts = catMaybes [ (\t _ _ _ _->isUnifiable t) <$> mbType
		                    , (\n (CL lib mod _) _ _ f _ -> isNameMatch
		                      (size n-2) n (FL lib mod f)) <$> name
		                    , isModMatchC <$> modules
		                    ]
		# members = findClassMembers`` filts db
		# members = map (\(CL lib mod cls,vs,_,f,et) -> makeFunctionResult name mbType
			(Just {cls_name=cls,cls_vars=vs}) (FL lib mod f,et) db) members
		// Search types
		# lcTypeName = if (isJust mbType && isType (fromJust mbType))
			(let (Type name _) = fromJust mbType in Just $ toLowerCase name)
			(toLowerCase <$> name)
		# types = case lcTypeName of
			(Just n) = findType` (\(TL _ _ t) _ -> toLowerCase t == n) db
			Nothing  = []
		# types = map (\(tl,td) -> makeTypeResult name tl td) types
		// Search classes
		# classes = case (isNothing mbType, toLowerCase <$> name) of
			(True, Just c) = map (flip makeClassResult db) $
				findClass` (\(CL _ _ c`) _ _ _ -> toLowerCase c` == c) db
			_ = []
		// Merge results
		= sort $ funs ++ members ++ types ++ classes ++ macros

	makeClassResult :: (ClassLocation, [TypeVar], ClassContext, [(FunctionName,ExtendedType)])
		TypeDB -> Result
	makeClassResult (CL lib mod cls, vars, cc, funs) db
		= ClassResult
		  ( { library  = lib
		    , filename = modToFilename mod
		    , modul    = mod
		    , distance = -100
		    }
		  , { class_name = cls
		    , class_heading = foldl ((+) o (flip (+) " ")) cls vars +
			    if (isEmpty cc) "" " " + concat (print False cc)
		    , class_funs = [concat $ print False fun \\ fun <- funs]
		    , class_instances
		        = sort [concat (print False t) \\ t <- getInstances cls db]
		    }
		  )

	makeTypeResult :: (Maybe String) TypeLocation TypeDef -> Result
	makeTypeResult mbName (TL lib mod t) td
		= TypeResult
		  ( { library  = lib
		    , filename = modToFilename mod
		    , modul    = mod
		    , distance
		        = if (isNothing mbName) -100 (levenshtein` t (fromJust mbName))
		    }
		  , { type = concat $ print False td }
		  )

	makeMacroResult :: (Maybe String) MacroLocation Macro -> Result
	makeMacroResult mbName (ML lib mod m) mac
		= MacroResult
		  ( { library  = lib
		    , filename = modToFilename mod
		    , modul    = mod
		    , distance
		        = if (isNothing mbName) -100 (levenshtein` m (fromJust mbName))
		    }
		  , { macro_name = m
		    , macro_representation = mac.macro_as_string
		    }
		  )

	makeFunctionResult :: (Maybe String) (Maybe Type) (Maybe ShortClassResult)
	              (FunctionLocation, ExtendedType) TypeDB -> Result
	makeFunctionResult
		orgsearch orgsearchtype mbCls (FL lib mod fname, et=:(ET type tes)) db
		= FunctionResult
		  ( { library  = lib
		    , filename = modToFilename mod
		    , modul    = mod
		    , distance = distance
		    }
		  , { func     = concat $ print False (fname,et)
		    , unifier  = toStrUnifier <$> finish_unification <$>
		        (orgsearchtype >>= unify [] (prepare_unification False type))
		    , cls      = mbCls
			, constructor_of = if (tes.te_isconstructor)
				(let (Func _ r _) = type in Just $ concat $ print False r)
				Nothing
		    , generic_derivations
		        = let derivs = getDerivations fname db in
			      (\_ -> [concat $ print False d \\ d <-derivs]) <$>
			      tes.te_generic_vars
		    }
		  )
	where
		toStrUnifier :: Unifier -> StrUnifier
		toStrUnifier (tvas1, tvas2) = (map toStr tvas1, map toStr tvas2)
		where toStr (var, type) = (var, concat $ print False type)

		toStrPriority :: (Maybe TE_Priority) -> String
		toStrPriority p = case print False p of [] = ""; ss = concat [" ":ss]

		distance
			| isNothing orgsearch || fromJust orgsearch == ""
				| isNothing orgsearchtype = 0
				# orgsearchtype = fromJust orgsearchtype
				# (Just (ass1, ass2)) = finish_unification <$>
					unify [] orgsearchtype (prepare_unification False type)
				= toInt $ sum [typeComplexity t \\ (_,t)<-ass1 ++ ass2 | not (isVar t)]
			# orgsearch = fromJust orgsearch
			= levenshtein` orgsearch fname
		where
			typeComplexity :: Type -> Real
			typeComplexity (Type _ ts) = 1.2 * foldr ((+) o typeComplexity) 1.0 ts
			typeComplexity (Func is r _) = 2.0 * foldr ((+) o typeComplexity) 1.0 [r:is]
			typeComplexity (Var _) = 1.0
			typeComplexity (Cons _ ts) = 1.2 * foldr ((+) o typeComplexity) 1.0 ts
			typeComplexity (Uniq t) = 3.0 + typeComplexity t

	levenshtein` :: String String -> Int
	levenshtein` a b = if (indexOf a b == -1) 0 -100 + levenshtein a b

	modToFilename :: String -> String
	modToFilename mod = (toString $ reverse $ takeWhile ((<>)'.')
	                              $ reverse $ fromString mod) + ".dcl"

	isUnifiable :: Type ExtendedType -> Bool
	isUnifiable t1 (ET t2 _) = isJust (unify [] t1 (prepare_unification False t2))

	isNameMatch :: !Int !String FunctionLocation -> Bool
	isNameMatch maxdist n1 (FL _ _ n2)
		# (n1, n2) = ({toLower c \\ c <-: n1}, {toLower c \\ c <-: n2})
		= n1 == "" || indexOf n1 n2 <> -1 || levenshtein n1 n2 <= maxdist

	isModMatchF :: ![String] FunctionLocation ExtendedType -> Bool
	isModMatchF mods (FL _ mod _) _ = isMember mod mods

	isModMatchC :: ![String] ClassLocation [TypeVar] ClassContext FunctionName ExtendedType -> Bool
	isModMatchC mods (CL _ mod _) _ _ _ _ = isMember mod mods

	log :: (LogMessage (Maybe Request) Response) IPAddress *World
	       -> *(IPAddress, *World)
	log msg s w
	| not needslog = (newS msg s, w)
	# (tm,w) = localTime w
	# (io,w) = stdio w
	# io = io <<< trim (toString tm) <<< " " <<< msgToString msg s
	= (newS msg s, snd (fclose io w))
	where
		needslog = case msg of (Received _) = True; (Sent _) = True; _ = False

	newS :: (LogMessage (Maybe Request) Response) IPAddress -> IPAddress
	newS m s = case m of (Connected ip) = ip; _ = s

	msgToString :: (LogMessage (Maybe Request) Response) IPAddress -> String
	msgToString (Received Nothing) ip
		= toString ip + " <-- Nothing\n"
	msgToString (Received (Just a)) ip
		= toString ip + " <-- " + toString a + "\n"
	msgToString (Sent {return,data,msg,more_available}) ip
		= toString ip + " --> " + toString (length data)
			+ " results (" + toString return + "; " + msg +
			if (isJust more_available) ("; " + toString (fromJust more_available) + " more") "" + ")\n"
	msgToString _ _ = ""

module CloogleServer

import StdArray, StdBool, StdFile, StdList, StdOrdList, StdOverloaded, StdTuple
from StdFunc import o, flip
from StdMisc import abort

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

from Data.Func import $
import Data.List
import Data.Maybe
import System.CommandLine
import Text.JSON
import Data.Functor
import Control.Applicative
import Control.Monad
from Text import class Text(concat,trim,indexOf,toLowerCase),
	instance Text String, instance + String

import System.Time

import qualified StdMaybe as OldMaybe
from SimpleTCPServer import :: LogMessage{..}, serve, :: Logger
import qualified SimpleTCPServer
import TypeDB
import Type
import Levenshtein

:: OldMaybe a :== 'SimpleTCPServer'.Maybe a

:: Request = { unify     :: Maybe String
             , name      :: Maybe String
             , className :: Maybe String
             , typeName  :: Maybe String
             , modules   :: Maybe [String]
             , page      :: Maybe Int
             }

:: Response = { return         :: Int
              , data           :: [Result]
              , msg            :: String
              , more_available :: Maybe Int
              , suggestions    :: Maybe [(Request, Int)]
              }

:: Result = FunctionResult FunctionResult
          | TypeResult TypeResult
          | ClassResult ClassResult
          | MacroResult MacroResult

:: BasicResult = { library  :: String
                 , filename :: String
                 , modul    :: String
                 , distance :: Int
                 }

:: FunctionResult :== (BasicResult, FunctionResultExtras)
:: FunctionResultExtras = { func     :: String
                          , unifier  :: Maybe StrUnifier
                          , cls      :: Maybe ShortClassResult
                          , constructor_of :: Maybe String
                          , generic_derivations :: Maybe [String]
                          }

:: TypeResult :== (BasicResult, TypeResultExtras)
:: TypeResultExtras = { type :: String
                      }

:: ClassResult :== (BasicResult, ClassResultExtras)
:: ClassResultExtras = { class_name :: String
                       , class_heading :: String
                       , class_funs :: [String]
                       , class_instances :: [String]
                       }

:: MacroResult :== (BasicResult, MacroResultExtras)
:: MacroResultExtras = { macro_name :: String
                       , macro_representation :: String
                       }

:: StrUnifier :== ([(String,String)], [(String,String)])

:: ErrorResult = Error Int String

:: ShortClassResult = { cls_name :: String, cls_vars :: [String] }

derive JSONEncode Request, Response, Result, ShortClassResult, BasicResult,
	FunctionResultExtras, TypeResultExtras, ClassResultExtras, MacroResultExtras
derive JSONDecode Request, Response, Result, ShortClassResult, BasicResult,
	FunctionResultExtras, TypeResultExtras, ClassResultExtras, MacroResultExtras

instance zero Request
where
	zero = { unify     = Nothing
	       , name      = Nothing
	       , className = Nothing
	       , typeName  = Nothing
	       , modules   = Nothing
	       , page      = Nothing
	       }

instance toString Response where toString r = toString (toJSON r) + "\n"
instance toString Request where toString r = toString $ toJSON r

instance fromString (Maybe Request) where fromString s = fromJSON $ fromString s

instance < BasicResult where (<) r1 r2 = r1.distance < r2.distance
instance < Result
where
	(<) r1 r2 = basic r1 < basic r2
	where
		basic :: Result -> BasicResult
		basic (FunctionResult (br,_)) = br
		basic (TypeResult (br,_)) = br
		basic (ClassResult (br,_)) = br
		basic (MacroResult (br,_)) = br

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

E_NORESULTS :== 127
E_INVALIDINPUT :== 128
E_INVALIDNAME :== 129
E_INVALIDTYPE :== 130

MAX_RESULTS :== 15

Start w
# (io, w) = stdio w
# (cmdline, w) = getCommandLine w
| length cmdline <> 2 = help io w
# [_,port:_] = cmdline
# port = toInt port
# (db, io) = openDb io
# (_, w) = fclose io w
| isNothing db = abort "stdin does not have a TypeDB\n"
#! db = fromJust db
= serve (handle db) ('OldMaybe'.Just log) port w
where
	help :: *File *World -> *World
	help io w
	# io = io <<< "Usage: ./CloogleServer <port>\n"
	= snd $ fclose io w

	handle :: !TypeDB !(Maybe Request) !*World -> *(!Response, !*World)
	handle _ Nothing w = (err E_INVALIDINPUT "Couldn't parse input", w)
	handle db (Just request=:{unify,name,modules,page}) w
		| isJust name && size (fromJust name) > 40
			= (err E_INVALIDNAME "function name too long", w)
		| isJust name && any isSpace (fromString $ fromJust name)
			= (err E_INVALIDNAME "name cannot contain spaces", w)
		| isJust unify && isNothing (parseType $ fromString $ fromJust unify)
			= (err E_INVALIDTYPE "couldn't parse type", w)
		// Results
		# drop_n = fromJust (page <|> pure 0) * MAX_RESULTS
		# results = drop drop_n $ sort $ search request db
		# more = max 0 (length results - MAX_RESULTS)
		// Suggestions
		# mbType = unify >>= parseType o fromString
		# suggestions
			= sortBy (\a b -> snd a > snd b) <$>
			  filter ((<)(length results) o snd) <$>
			  (mbType >>= \t -> suggs name t db)
		# results = take MAX_RESULTS results
		// Response
		| isEmpty results = (err E_NORESULTS "No results", w)
		= ( { return = 0
		    , msg = "Success"
		    , data           = results
		    , more_available = Just more
		    , suggestions    = suggestions
		    }
		  , w)

	suggs :: !(Maybe String) !Type !TypeDB -> Maybe [(Request, Int)]
	suggs n (Func is r cc) db
		| length is < 3
			= Just [let t` = concat $ print False $ Func is` r cc in
			        let request = {zero & name=n, unify=Just t`} in
			        (request, length $ search request db)
			        \\ is` <- permutations is | is` <> is]
	suggs _ _ _ = Nothing

	search :: !Request !TypeDB -> [Result]
	search {unify,name,className,typeName,modules,page} db
		| isJust className
			# className = fromJust className
			# classes = findClass className db
			= map (flip makeClassResult db) classes
		| isJust typeName
			# typeName = fromJust typeName
			# types = findType typeName db
			= map (uncurry (makeTypeResult (Just typeName))) types
		# mbType = prepare_unification True <$> (unify >>= parseType o fromString)
		// Search normal functions
		# filts = catMaybes [ (\t _ -> isUnifiable t) <$> mbType
		                    , (\n loc _ -> isNameMatch (size n-2) n loc) <$> name
		                    , isModMatchF <$> modules
		                    ]
		# funs = map (\f -> makeFunctionResult name mbType Nothing f db) $ findFunction`` filts db
		// Search macros
		# macros = case name of
			Nothing  = []
			(Just n) = findMacro` (\(ML lib mod m) _ -> isNameMatch (size n-2) n (FL lib mod m)) db
		# macros = map (\(lhs,rhs) -> makeMacroResult name lhs rhs) macros
		// Search class members
		# filts = catMaybes [ (\t _ _ _ _->isUnifiable t) <$> mbType
		                    , (\n (CL lib mod _) _ _ f _ -> isNameMatch
		                      (size n-2) n (FL lib mod f)) <$> name
		                    , isModMatchC <$> modules
		                    ]
		# members = findClassMembers`` filts db
		# members = map (\(CL lib mod cls,vs,_,f,et) -> makeFunctionResult name mbType
			(Just {cls_name=cls,cls_vars=vs}) (FL lib mod f,et) db) members
		// Search types
		# lcTypeName = if (isJust mbType && isType (fromJust mbType))
			(let (Type name _) = fromJust mbType in Just $ toLowerCase name)
			(toLowerCase <$> name)
		# types = case lcTypeName of
			(Just n) = findType` (\(TL _ _ t) _ -> toLowerCase t == n) db
			Nothing  = []
		# types = map (\(tl,td) -> makeTypeResult name tl td) types
		// Search classes
		# classes = case (isNothing mbType, toLowerCase <$> name) of
			(True, Just c) = map (flip makeClassResult db) $
				findClass` (\(CL _ _ c`) _ _ _ -> toLowerCase c` == c) db
			_ = []
		// Merge results
		= sort $ funs ++ members ++ types ++ classes ++ macros

	makeClassResult :: (ClassLocation, [TypeVar], ClassContext, [(FunctionName,ExtendedType)])
		TypeDB -> Result
	makeClassResult (CL lib mod cls, vars, cc, funs) db
		= ClassResult
		  ( { library  = lib
		    , filename = modToFilename mod
		    , modul    = mod
		    , distance = -100
		    }
		  , { class_name = cls
		    , class_heading = foldl ((+) o (flip (+) " ")) cls vars +
			    if (isEmpty cc) "" " " + concat (print False cc)
		    , class_funs = [concat $ print False fun \\ fun <- funs]
		    , class_instances
		        = sort [concat (print False t) \\ t <- getInstances cls db]
		    }
		  )

	makeTypeResult :: (Maybe String) TypeLocation TypeDef -> Result
	makeTypeResult mbName (TL lib mod t) td
		= TypeResult
		  ( { library  = lib
		    , filename = modToFilename mod
		    , modul    = mod
		    , distance
		        = if (isNothing mbName) -100 (levenshtein` t (fromJust mbName))
		    }
		  , { type = concat $ print False td }
		  )

	makeMacroResult :: (Maybe String) MacroLocation Macro -> Result
	makeMacroResult mbName (ML lib mod m) mac
		= MacroResult
		  ( { library  = lib
		    , filename = modToFilename mod
		    , modul    = mod
		    , distance
		        = if (isNothing mbName) -100 (levenshtein` (fromJust mbName) m)
		    }
		  , { macro_name = m
		    , macro_representation = mac.macro_as_string
		    }
		  )

	makeFunctionResult :: (Maybe String) (Maybe Type) (Maybe ShortClassResult)
	              (FunctionLocation, ExtendedType) TypeDB -> Result
	makeFunctionResult
		orgsearch orgsearchtype mbCls (FL lib mod fname, et=:(ET type tes)) db
		= FunctionResult
		  ( { library  = lib
		    , filename = modToFilename mod
		    , modul    = mod
		    , distance = distance
		    }
		  , { func     = concat $ print False (fname,et)
		    , unifier  = toStrUnifier <$> finish_unification <$>
		        (orgsearchtype >>= unify [] (prepare_unification False type))
		    , cls      = mbCls
			, constructor_of = if (tes.te_isconstructor)
				(let (Func _ r _) = type in Just $ concat $ print False r)
				Nothing
		    , generic_derivations
		        = let derivs = getDerivations fname db in
			      (\_ -> [concat $ print False d \\ d <-derivs]) <$>
			      tes.te_generic_vars
		    }
		  )
	where
		toStrUnifier :: Unifier -> StrUnifier
		toStrUnifier (tvas1, tvas2) = (map toStr tvas1, map toStr tvas2)
		where toStr (var, type) = (var, concat $ print False type)

		toStrPriority :: (Maybe TE_Priority) -> String
		toStrPriority p = case print False p of [] = ""; ss = concat [" ":ss]

		distance
			| isNothing orgsearch || fromJust orgsearch == ""
				| isNothing orgsearchtype = 0
				# orgsearchtype = fromJust orgsearchtype
				# (Just (ass1, ass2)) = finish_unification <$>
					unify [] orgsearchtype (prepare_unification False type)
				= toInt $ sum [typeComplexity t \\ (_,t)<-ass1 ++ ass2 | not (isVar t)]
			# orgsearch = fromJust orgsearch
			= levenshtein` orgsearch fname
		where
			typeComplexity :: Type -> Real
			typeComplexity (Type _ ts) = 1.2 * foldr ((+) o typeComplexity) 1.0 ts
			typeComplexity (Func is r _) = 2.0 * foldr ((+) o typeComplexity) 1.0 [r:is]
			typeComplexity (Var _) = 1.0
			typeComplexity (Cons _ ts) = 1.2 * foldr ((+) o typeComplexity) 1.0 ts
			typeComplexity (Uniq t) = 3.0 + typeComplexity t

	levenshtein` :: String String -> Int
	levenshtein` a b = if (indexOf a b == -1) 0 -100 + levenshtein a b

	modToFilename :: String -> String
	modToFilename mod = (toString $ reverse $ takeWhile ((<>)'.')
	                              $ reverse $ fromString mod) + ".dcl"

	isUnifiable :: Type ExtendedType -> Bool
	isUnifiable t1 (ET t2 _) = isJust (unify [] t1 (prepare_unification False t2))

	isNameMatch :: !Int !String FunctionLocation -> Bool
	isNameMatch maxdist n1 (FL _ _ n2)
		# (n1, n2) = ({toLower c \\ c <-: n1}, {toLower c \\ c <-: n2})
		= n1 == "" || indexOf n1 n2 <> -1 || levenshtein n1 n2 <= maxdist

	isModMatchF :: ![String] FunctionLocation ExtendedType -> Bool
	isModMatchF mods (FL _ mod _) _ = isMember mod mods

	isModMatchC :: ![String] ClassLocation [TypeVar] ClassContext FunctionName ExtendedType -> Bool
	isModMatchC mods (CL _ mod _) _ _ _ _ = isMember mod mods

	log :: (LogMessage (Maybe Request) Response) IPAddress *World
	       -> *(IPAddress, *World)
	log msg s w
	| not needslog = (newS msg s, w)
	# (tm,w) = localTime w
	# (io,w) = stdio w
	# io = io <<< trim (toString tm) <<< " " <<< msgToString msg s
	= (newS msg s, snd (fclose io w))
	where
		needslog = case msg of (Received _) = True; (Sent _) = True; _ = False

	newS :: (LogMessage (Maybe Request) Response) IPAddress -> IPAddress
	newS m s = case m of (Connected ip) = ip; _ = s

	msgToString :: (LogMessage (Maybe Request) Response) IPAddress -> String
	msgToString (Received Nothing) ip
		= toString ip + " <-- Nothing\n"
	msgToString (Received (Just a)) ip
		= toString ip + " <-- " + toString a + "\n"
	msgToString (Sent {return,data,msg,more_available}) ip
		= toString ip + " --> " + toString (length data)
			+ " results (" + toString return + "; " + msg +
			if (isJust more_available) ("; " + toString (fromJust more_available) + " more") "" + ")\n"
	msgToString _ _ = ""

Fix distance for macro search

Fix distance for macro search


$!
$!
$!
$ olddir = f$environment( "default" )
$ on control_y then goto End
$ on error then goto End
$!
$ gosub Init
$!
$ man2help sys$input: libssh2.hlp -b 1

LIBSSH2

OpenVMS port of the public domain libssh2 library, which
provides an API to implement client SSH communciation.

License information is available at the copying subtopic.

$!
$ open/append mh libssh2.hlp
$ write mh helpversion
$ close mh
$!
$ man2help -a [-]readme.; libssh2.hlp        -b 2
$ man2help -a [-]authors.; libssh2.hlp       -b 2
$ man2help -a [-]copying.; libssh2.hlp       -b 2
$ man2help -a [-]news.; libssh2.hlp          -b 2
$ man2help -a [-]release-notes.; libssh2.hlp -b 2
$ man2help -a [-]hacking.; libssh2.hlp       -b 2
$ man2help -a [-]todo.; libssh2.hlp          -b 2
$!
$ man2help -a sys$input: libssh2.hlp         -b 2

API_Reference

Reference of all implemented API calls in
libssh2.

$!
$ man2help -a [-.docs]*.3 libssh2.hlp -b 3 -p
$!
$ library/help/create libssh2.hlb libssh2.hlp
$!
$End:
$ set default 'olddir'
$exit
$!
$!-------------------------------------------------------
$!
$Init:
$!
$ thisdir = f$environment( "procedure" )
$ thisdir = f$parse(thisdir,,,"device") + f$parse(thisdir,,,"directory")
$ set default 'thisdir'
$!
$ say = "write sys$output"
$!
$ pipe search [-.include]*.h libssh2_version_major/nohead | (read sys$input l ; l = f$element(2," ",f$edit(l,"trim,compress")) ; -
       define/job majorv &l )
$ pipe search [-.include]*.h libssh2_version_minor/nohead | (read sys$input l ; l = f$element(2," ",f$edit(l,"trim,compress")) ; -
       define/job minorv &l )
$ pipe search [-.include]*.h libssh2_version_patch/nohead | (read sys$input l ; l = f$element(2," ",f$edit(l,"trim,compress")) ; -
       define/job patchv &l )
$!
$ majorv   = f$trnlnm("majorv")
$ minorv   = f$integer(f$trnlnm("minorv"))
$ patchv   = f$integer( f$trnlnm("patchv"))
$!
$ helpversion = "This help library is based on build version ''majorv'.''minorv'.''patchv' of libssh2."
$!
$ deassign/job majorv
$ deassign/job minorv
$ deassign/job patchv
$!
$ if f$search( "man2help.exe" ) .eqs. ""
$ then
$   cc man2help
$   link man2help
$ endif
$!
$ man2help := $'thisdir'man2help.exe
$!
$ if f$search("libssh2.hlp") .nes. ""
$ then
$   delete libssh2.hlp;*
$ endif
$ if f$search("libssh2.hlb") .nes. ""
$ then
$   delete libssh2.hlb;*
$ endif
$return

$!
$!
$!
$ olddir = f$environment( "default" )
$ on control_y then goto End
$ on error then goto End
$!
$ gosub Init
$!
$ man2help sys$input: libssh2.hlp -b 1

LIBSSH2

OpenVMS port of the libssh2 library, which provides an
API to implement client SSH communication.

License information is available at the Copying subtopic.

$!
$ open/append mh libssh2.hlp
$ write mh helpversion
$ close mh
$!
$ man2help -a [-]README.; libssh2.hlp        -b 2
$ man2help -a [-]COPYING.; libssh2.hlp       -b 2
$ man2help -a [-]NEWS.; libssh2.hlp          -b 2
$ man2help -a [-]RELEASE-NOTES.; libssh2.hlp -b 2
$ man2help -a [-.docs]AUTHORS.; libssh2.hlp  -b 2
$ man2help -a [-.docs]BINDINGS.; libssh2.hlp -b 2
$ man2help -a [-.docs]HACKING.; libssh2.hlp  -b 2
$ if f$search("[]HACKING_CRYPTO.") .nes. "" then delete []HACKING_CRYPTO.;*
$ copy [-.docs]HACKING.CRYPTO; []HACKING_CRYPTO.
$ man2help -a []HACKING_CRYPTO.; libssh2.hlp -b 2
$ man2help -a [-.docs]TODO.; libssh2.hlp     -b 2
$!
$ man2help -a sys$input: libssh2.hlp         -b 2

API_Reference

Reference of all implemented API calls in
libssh2.

$!
$ man2help -a [-.docs]*.3 libssh2.hlp -b 3 -p
$!
$ library/help/create libssh2.hlb libssh2.hlp
$!
$End:
$ set default 'olddir'
$exit
$!
$!-------------------------------------------------------
$!
$Init:
$!
$ thisdir = f$environment( "procedure" )
$ thisdir = f$parse(thisdir,,,"device") + f$parse(thisdir,,,"directory")
$ set default 'thisdir'
$!
$ say = "write sys$output"
$!
$ pipe search [-.include]*.h libssh2_version_major/nohead | (read sys$input l ; l = f$element(2," ",f$edit(l,"trim,compress")) ; -
       define/job majorv &l )
$ pipe search [-.include]*.h libssh2_version_minor/nohead | (read sys$input l ; l = f$element(2," ",f$edit(l,"trim,compress")) ; -
       define/job minorv &l )
$ pipe search [-.include]*.h libssh2_version_patch/nohead | (read sys$input l ; l = f$element(2," ",f$edit(l,"trim,compress")) ; -
       define/job patchv &l )
$!
$ majorv   = f$trnlnm("majorv")
$ minorv   = f$integer(f$trnlnm("minorv"))
$ patchv   = f$integer( f$trnlnm("patchv"))
$!
$ helpversion = "This help library is based on build version ''majorv'.''minorv'.''patchv' of libssh2."
$!
$ deassign/job majorv
$ deassign/job minorv
$ deassign/job patchv
$!
$ if f$search( "man2help.exe" ) .eqs. ""
$ then
$   cc man2help
$   link man2help
$ endif
$!
$ man2help := $'thisdir'man2help.exe
$!
$ if f$search("libssh2.hlp") .nes. ""
$ then
$   delete libssh2.hlp;*
$ endif
$ if f$search("libssh2.hlb") .nes. ""
$ then
$   delete libssh2.hlb;*
$ endif
$return

Tweak VMS help file building.

Tweak VMS help file building.

Primarily this is handling cases where top-level files moved into
the docs/ directory.  I also corrected a typo and removed the
claim that libssh2 is public domain.


module CloogleServer

import StdArray
import StdBool
import StdFile
from StdFunc import id, o, seq
from StdMisc import undef
import StdOrdList
import StdOverloaded
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, instance Foldable Maybe
from Data.Func import $
import Data.Functor
import Data.List
import Data.Tuple
import System._Posix
import System.CommandLine
import System.Time
from Text import class Text(concat), instance Text String, <+
import Text.JSON

import Cloogle
import Type
import CloogleDB
import Search

import SimpleTCPServer
import Cache
import Memory

MAX_RESULTS    :== 15
CACHE_PREFETCH :== 5

:: RequestCacheKey
	= { c_unify            :: Maybe Type
	  , c_name             :: Maybe String
	  , c_className        :: Maybe String
	  , c_typeName         :: 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 :: Request -> RequestCacheKey
toRequestCacheKey r =
	{ c_unify            = r.unify >>= parseType o fromString
	, c_name             = r.name
	, c_className        = r.className
	, c_typeName         = r.typeName
	, c_modules          = sort <$> r.modules
	, c_libraries        = sort <$> r.libraries
	, c_include_builtins = fromJust (r.include_builtins <|> Just DEFAULT_INCLUDE_BUILTINS)
	, c_include_core     = fromJust (r.include_core <|> Just DEFAULT_INCLUDE_CORE)
	, c_include_apps     = fromJust (r.include_apps <|> Just DEFAULT_INCLUDE_APPS)
	, c_page             = fromJust (r.page <|> Just 0)
	}
fromRequestCacheKey :: RequestCacheKey -> Request
fromRequestCacheKey k =
	{ unify            = concat <$> print False <$> k.c_unify
	, name             = k.c_name
	, className        = k.c_className
	, typeName         = k.c_typeName
	, 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
	}

:: 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
#! db = eval_all_nodes db
#! w = if opts.reload_cache (reloadCache db) id w
#! (_,w) = fclose f w
= serve
	{ handler           = handle db
	, logger            = Just log
	, port              = opts.Options.port
	, connect_timeout   = Just 3600000 // 1h
	, keepalive_timeout = Just 5000    // 5s
	} 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

	eval_all_nodes :: !.a -> .a // From GraphCopy
	eval_all_nodes g = code {
		push_a 0
		.d 1 0
		jsr	_eval_to_nf
		.o 0 0
	}

	handle :: !CloogleDB !(Maybe Request) !*World -> *(!Response, CacheKey, !*World)
	handle db Nothing w = (err InvalidInput "Couldn't parse input", "", w)
	handle db (Just request=:{unify,name,page}) w
		//Check cache
		#! (mbResponse, w) = readCache key w
		| isJust mbResponse
			# r = fromJust mbResponse
			= respond {r & return = if (r.return == 0) 1 r.return} w
		| isJust name && size (fromJust name) > 40
			= respond (err InvalidName "Function name too long") w
		| isJust name && any isSpace (fromString $ fromJust name)
			= respond (err InvalidName "Name cannot contain spaces") w
		| isJust unify && isNothing (parseType $ fromString $ fromJust unify)
			= respond (err InvalidType "Couldn't parse type") w
		// Results
		#! drop_n = fromJust (page <|> pure 0) * MAX_RESULTS
		#! results = drop drop_n $ sort $ search request db
		#! more = max 0 (length results - MAX_RESULTS)
		// Suggestions
		#! suggestions = unify >>= parseType o fromString >>= flip (suggs name) db
		#! w = seq [cachePages
				(toRequestCacheKey req) CACHE_PREFETCH 0 zero suggs
				\\ (req,suggs) <- 'Foldable'.concat suggestions] 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 response w
	where
		key = toRequestCacheKey request

		respond :: !Response !*World -> *(!Response, !CacheKey, !*World)
		respond r w = (r, cacheKey key, writeCache LongTerm key r 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])]
	suggs n (Func is r cc) db
		| length is < 3
			= Just [let t` = concat $ print False $ Func is` r cc in
			        let request = {zero & name=n, unify=Just t`} in
			        (request, search request db)
			        \\ is` <- permutations is | is` <> is]
	suggs _ _ _ = Nothing

	reloadCache :: !CloogleDB !*World -> *World
	reloadCache db w
	# (keys,w) = allCacheKeys LongTerm w
	# w = search (map fromRequestCacheKey keys) w
	= w
	where
		search :: ![Request] !*World -> *World
		search [] w = w
		search [r:rs] w = search rs $ thd3 $ handle db (Just r) w

:: 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
		}

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

:: LogEntry =
	{ ip            :: String
	, time_start    :: (String, Int)
	, time_end      :: (String, Int)
	, request       :: Maybe Request
	, cachekey      :: 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) 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)
		, 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, seq
from StdMisc import undef
import StdOrdList
import StdOverloaded
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, instance Foldable Maybe
from Data.Func import $, hyperstrict
import Data.Functor
import Data.List
import Data.Tuple
import System._Posix
import System.CommandLine
import System.Time
from Text import class Text(concat), instance Text String, <+
import Text.JSON

import Cloogle
import Type
import CloogleDB
import Search

import SimpleTCPServer
import Cache
import Memory

MAX_RESULTS    :== 15
CACHE_PREFETCH :== 5

:: RequestCacheKey
	= { c_unify            :: Maybe Type
	  , c_name             :: Maybe String
	  , c_className        :: Maybe String
	  , c_typeName         :: 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 :: Request -> RequestCacheKey
toRequestCacheKey r =
	{ c_unify            = r.unify >>= parseType o fromString
	, c_name             = r.name
	, c_className        = r.className
	, c_typeName         = r.typeName
	, c_modules          = sort <$> r.modules
	, c_libraries        = sort <$> r.libraries
	, c_include_builtins = fromJust (r.include_builtins <|> Just DEFAULT_INCLUDE_BUILTINS)
	, c_include_core     = fromJust (r.include_core <|> Just DEFAULT_INCLUDE_CORE)
	, c_include_apps     = fromJust (r.include_apps <|> Just DEFAULT_INCLUDE_APPS)
	, c_page             = fromJust (r.page <|> Just 0)
	}
fromRequestCacheKey :: RequestCacheKey -> Request
fromRequestCacheKey k =
	{ unify            = concat <$> print False <$> k.c_unify
	, name             = k.c_name
	, className        = k.c_className
	, typeName         = k.c_typeName
	, 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
	}

:: 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
#! db = hyperstrict db
#! w = if opts.reload_cache (reloadCache db) id w
#! (_,w) = fclose f w
= serve
	{ handler           = handle db
	, logger            = Just log
	, port              = opts.Options.port
	, connect_timeout   = Just 3600000 // 1h
	, keepalive_timeout = Just 5000    // 5s
	} 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 :: !CloogleDB !(Maybe Request) !*World -> *(!Response, CacheKey, !*World)
	handle db Nothing w = (err InvalidInput "Couldn't parse input", "", w)
	handle db (Just request=:{unify,name,page}) w
		//Check cache
		#! (mbResponse, w) = readCache key w
		| isJust mbResponse
			# r = fromJust mbResponse
			= respond {r & return = if (r.return == 0) 1 r.return} w
		| isJust name && size (fromJust name) > 40
			= respond (err InvalidName "Function name too long") w
		| isJust name && any isSpace (fromString $ fromJust name)
			= respond (err InvalidName "Name cannot contain spaces") w
		| isJust unify && isNothing (parseType $ fromString $ fromJust unify)
			= respond (err InvalidType "Couldn't parse type") w
		// Results
		#! drop_n = fromJust (page <|> pure 0) * MAX_RESULTS
		#! results = drop drop_n $ sort $ search request db
		#! more = max 0 (length results - MAX_RESULTS)
		// Suggestions
		#! suggestions = unify >>= parseType o fromString >>= flip (suggs name) db
		#! w = seq [cachePages
				(toRequestCacheKey req) CACHE_PREFETCH 0 zero suggs
				\\ (req,suggs) <- 'Foldable'.concat suggestions] 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 response w
	where
		key = toRequestCacheKey request

		respond :: !Response !*World -> *(!Response, !CacheKey, !*World)
		respond r w = (r, cacheKey key, writeCache LongTerm key r 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])]
	suggs n (Func is r cc) db
		| length is < 3
			= Just [let t` = concat $ print False $ Func is` r cc in
			        let request = {zero & name=n, unify=Just t`} in
			        (request, search request db)
			        \\ is` <- permutations is | is` <> is]
	suggs _ _ _ = Nothing

	reloadCache :: !CloogleDB !*World -> *World
	reloadCache db w
	# (keys,w) = allCacheKeys LongTerm w
	# w = search (map fromRequestCacheKey keys) w
	= w
	where
		search :: ![Request] !*World -> *World
		search [] w = w
		search [r:rs] w = search rs $ thd3 $ handle db (Just r) w

:: 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
		}

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

:: LogEntry =
	{ ip            :: String
	, time_start    :: (String, Int)
	, time_end      :: (String, Int)
	, request       :: Maybe Request
	, cachekey      :: 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) 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)
		, 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
          }

Use new hyperstrict instead of copied eval_all_nodes