CloogleServer.icl 17.1 KB
Newer Older
1 2
module CloogleServer

3 4 5 6 7 8 9 10
import StdArray
import StdBool
import StdFile
import StdList
import StdOrdList
import StdOverloaded
import StdString
import StdTuple
11
from StdFunc import const, flip, id, o, seq
12
from StdMisc import abort, undef
13

14
from TCPIP import :: IPAddress, :: Port, instance toString IPAddress
15 16

from Data.Func import $
Camil Staps's avatar
Camil Staps committed
17
import Data.List
18
import Data.Tuple
19 20 21 22
import Data.Maybe
import System.CommandLine
import Data.Functor
import Control.Applicative
23
import Control.Monad
24
from Text import class Text(concat,trim,indexOf,toLowerCase,split),
25
	instance Text String, instance + String
26
import Text.JSON
Camil Staps's avatar
Camil Staps committed
27 28

import System.Time
29

30 31
from SimpleTCPServer import :: LogMessage{..}, serve, :: Logger
import qualified SimpleTCPServer
32 33
import TypeDB
import Type
34
import Cache
35
import Cloogle
Camil Staps's avatar
Camil Staps committed
36

37
MAX_RESULTS    :== 15
Camil Staps's avatar
Camil Staps committed
38
CACHE_PREFETCH :== 5
39

40 41 42
DEFAULT_INCLUDE_BUILTINS :== True
DEFAULT_INCLUDE_CORE :== False

43
:: RequestCacheKey
Camil Staps's avatar
Camil Staps committed
44 45 46 47 48 49 50
	= { 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
51
	  , c_include_core     :: Bool
Camil Staps's avatar
Camil Staps committed
52
	  , c_page             :: Int
53 54 55 56 57 58 59 60
	  }

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

toRequestCacheKey :: Request -> RequestCacheKey
toRequestCacheKey r =
Camil Staps's avatar
Camil Staps committed
61 62 63 64 65 66
	{ 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
67 68
	, c_include_builtins = fromJust (r.include_builtins <|> Just DEFAULT_INCLUDE_BUILTINS)
	, c_include_core     = fromJust (r.include_core <|> Just DEFAULT_INCLUDE_CORE)
Camil Staps's avatar
Camil Staps committed
69
	, c_page             = fromJust (r.page <|> Just 0)
70 71
	}

72 73 74 75 76 77 78 79 80
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"
81
#! db = fromJust db
Camil Staps's avatar
Camil Staps committed
82
= serve (handle db) (Just log) port w
83
where
Camil Staps's avatar
Camil Staps committed
84 85 86 87 88
	help :: *File *World -> *World
	help io w
	# io = io <<< "Usage: ./CloogleServer <port>\n"
	= snd $ fclose io w

Camil Staps's avatar
Camil Staps committed
89
	handle :: !TypeDB !(Maybe Request) !*World -> *(!Response, CacheKey, !*World)
90
	handle _ Nothing w = (err CLOOGLE_E_INVALIDINPUT "Couldn't parse input", "", w)
Camil Staps's avatar
Camil Staps committed
91
	handle db (Just request=:{unify,name,page}) w
92
		//Check cache
Camil Staps's avatar
Camil Staps committed
93
		# (mbResponse, w) = readCache key w
94 95
		| isJust mbResponse
			# r = fromJust mbResponse
Camil Staps's avatar
Camil Staps committed
96
			= ({r & return = if (r.return == 0) 1 r.return}, cacheKey key, w)
97
		| isJust name && size (fromJust name) > 40
98
			= respond (err CLOOGLE_E_INVALIDNAME "Function name too long") w
Camil Staps's avatar
Camil Staps committed
99
		| isJust name && any isSpace (fromString $ fromJust name)
100
			= respond (err CLOOGLE_E_INVALIDNAME "Name cannot contain spaces") w
Camil Staps's avatar
Camil Staps committed
101
		| isJust unify && isNothing (parseType $ fromString $ fromJust unify)
102
			= respond (err CLOOGLE_E_INVALIDTYPE "Couldn't parse type") w
Camil Staps's avatar
Camil Staps committed
103 104
		// Results
		# drop_n = fromJust (page <|> pure 0) * MAX_RESULTS
Camil Staps's avatar
oops  
Camil Staps committed
105
		# results = drop drop_n $ sort $ search request db
Camil Staps's avatar
Camil Staps committed
106 107
		# more = max 0 (length results - MAX_RESULTS)
		// Suggestions
108
		# mbType = unify >>= parseType o fromString
Camil Staps's avatar
Camil Staps committed
109 110 111 112 113 114
		# suggestions = mbType >>= flip (suggs name) db
		# w = seq [cachePages
				(toRequestCacheKey req) CACHE_PREFETCH 0 zero suggs
				\\ (req,suggs) <- mb2list suggestions] w
			with
				mb2list Nothing = []; mb2list (Just xs) = xs
Camil Staps's avatar
Camil Staps committed
115
		# suggestions
116
			= sortBy (\a b -> snd a > snd b) <$>
Camil Staps's avatar
Camil Staps committed
117 118
			  filter ((<) (length results) o snd) <$>
			  map (appSnd length) <$> suggestions
Camil Staps's avatar
Camil Staps committed
119
		# (results,nextpages) = splitAt MAX_RESULTS results
Camil Staps's avatar
Camil Staps committed
120
		// Response
121
		# response = if (isEmpty results)
122
			(err CLOOGLE_E_NORESULTS "No results")
Camil Staps's avatar
Camil Staps committed
123 124
			{ zero
		    & data           = results
Camil Staps's avatar
Camil Staps committed
125 126
		    , more_available = Just more
		    , suggestions    = suggestions
127
		    }
Camil Staps's avatar
Camil Staps committed
128
		// Save page prefetches
Camil Staps's avatar
Camil Staps committed
129
		# w = cachePages key CACHE_PREFETCH 1 response nextpages w
130
		// Save cache file
131 132
		= respond response w
	where
133 134
		key = toRequestCacheKey request

Camil Staps's avatar
Camil Staps committed
135
		respond :: Response *World -> *(Response, CacheKey, *World)
136
		respond r w = (r, cacheKey key, writeCache LongTerm key r w)
Camil Staps's avatar
Camil Staps committed
137

Camil Staps's avatar
Camil Staps committed
138 139 140 141
		cachePages :: RequestCacheKey Int Int Response [Result] *World -> *World
		cachePages key _ _  _ [] w = w
		cachePages key 0 _  _ _  w = w
		cachePages key npages i response results w
Camil Staps's avatar
Camil Staps committed
142
		# w = writeCache Brief req` resp` w
Camil Staps's avatar
Camil Staps committed
143
		= cachePages key (npages - 1) (i + 1) response keep w
Camil Staps's avatar
Camil Staps committed
144
		where
Camil Staps's avatar
Camil Staps committed
145
			req` = { key & c_page = key.c_page + i }
Camil Staps's avatar
Camil Staps committed
146 147 148 149 150 151
			resp` =
				{ response
				& more_available = Just $ max 0 (length results - MAX_RESULTS)
				, data = give
				}
			(give,keep) = splitAt MAX_RESULTS results
Mart Lubbers's avatar
Mart Lubbers committed
152

Camil Staps's avatar
Camil Staps committed
153
	suggs :: !(Maybe String) !Type !TypeDB -> Maybe [(Request, [Result])]
154
	suggs n (Func is r cc) db
155 156
		| length is < 3
			= Just [let t` = concat $ print False $ Func is` r cc in
157
			        let request = {zero & name=n, unify=Just t`} in
Camil Staps's avatar
Camil Staps committed
158
			        (request, search request db)
159
			        \\ is` <- permutations is | is` <> is]
160
	suggs _ _ _ = Nothing
Camil Staps's avatar
Camil Staps committed
161

162
	search :: !Request !TypeDB -> [Result]
163 164 165
	search {unify,name,className,typeName,modules,libraries,page,include_builtins,include_core} db
		# include_builtins = fromJust (include_builtins <|> Just DEFAULT_INCLUDE_BUILTINS)
		# include_core = fromJust (include_core <|> Just DEFAULT_INCLUDE_CORE)
Camil Staps's avatar
Camil Staps committed
166
		# db = case libraries of
167
			(Just ls) = filterLocations (isLibMatch ls) db
Camil Staps's avatar
Camil Staps committed
168
			Nothing   = db
169 170 171
		# db = case modules of
			(Just ms) = filterLocations (isModMatch ms) db
			Nothing   = db
172 173 174 175 176 177 178 179
		# db = if include_builtins id (filterLocations (not o isBuiltin)) db
		# db = if include_core id (filterLocations (not o isCore)) db
			with
				isCore :: Location -> Bool
				isCore (Builtin _) = False
				isCore (Location lib mod _ _ _) = case getModule lib mod db of
					Nothing  = False
					(Just b) = b.is_core
Camil Staps's avatar
Camil Staps committed
180 181 182 183
		| isJust className
			# className = fromJust className
			# classes = findClass className db
			= map (flip makeClassResult db) classes
Camil Staps's avatar
Camil Staps committed
184 185 186
		| isJust typeName
			# typeName = fromJust typeName
			# types = findType typeName db
187
			= [makeTypeResult (Just typeName) l td db \\ (l,td) <- types]
188
		# mbType = prepare_unification True <$> (unify >>= parseType o fromString)
Camil Staps's avatar
Camil Staps committed
189
		// Search normal functions
190
		# filts = catMaybes [ (\t _ -> isUnifiable t) <$> mbType
Camil Staps's avatar
Camil Staps committed
191
		                    , (\n loc _ -> isNameMatch (size n*2/3) n $ getName loc) <$> name
192
		                    ]
193
		# funs = map (\f -> makeFunctionResult name mbType Nothing f db) $ findFunction`` filts db
Camil Staps's avatar
Camil Staps committed
194
		// Search macros
195
		# macros = case (isNothing mbType,name) of
Camil Staps's avatar
Camil Staps committed
196
			(True,Just n) = findMacro` (\loc _ -> isNameMatch (size n*2/3) n $ getName loc) db
197
			_             = []
Camil Staps's avatar
Camil Staps committed
198
		# macros = map (\(lhs,rhs) -> makeMacroResult name lhs rhs) macros
Camil Staps's avatar
Camil Staps committed
199
		// Search class members
Camil Staps's avatar
Camil Staps committed
200
		# filts = catMaybes [ (\t _ _ _ _->isUnifiable t) <$> mbType
201
		                    , (\n (Location lib mod _ _ _) _ _ f _ -> isNameMatch
Camil Staps's avatar
Camil Staps committed
202
		                      (size n*2/3) n f) <$> name
203
		                    ]
Camil Staps's avatar
Camil Staps committed
204
		# members = findClassMembers`` filts db
205 206
		# members = map (\(Location lib mod line iclline cls,vs,_,f,et) -> makeFunctionResult name mbType
			(Just {cls_name=cls,cls_vars=vs}) (Location lib mod line iclline f,et) db) members
Camil Staps's avatar
Camil Staps committed
207
		// Search types
208
		# lcName = if (isJust mbType && isType (fromJust mbType))
Camil Staps's avatar
Camil Staps committed
209 210
			(let (Type name _) = fromJust mbType in Just $ toLowerCase name)
			(toLowerCase <$> name)
211 212 213
		# types = case (isNothing mbType,lcName) of
			(True,Just n) = findType` (\loc _ -> toLowerCase (getName loc) == n) db
			_             = []
214
		# types = map (\(tl,td) -> makeTypeResult name tl td db) types
215 216
		// Search classes
		# classes = case (isNothing mbType, toLowerCase <$> name) of
Camil Staps's avatar
Camil Staps committed
217
			(True, Just c) = findClass` (\loc _ _ _ -> toLowerCase (getName loc) == c) db
Camil Staps's avatar
Camil Staps committed
218 219
			_              = []
		# classes = map (flip makeClassResult db) classes
Camil Staps's avatar
Camil Staps committed
220 221
		// Search modules
		# modules = case (mbType, name) of
222
			(Nothing, Just n) = findModule` (\_ m _ -> isModNameMatch (size n*2/3) n m) db
Camil Staps's avatar
Camil Staps committed
223 224
			_                 = []
		# modules = map (makeModuleResult name) modules
Camil Staps's avatar
Camil Staps committed
225
		// Merge results
Camil Staps's avatar
Camil Staps committed
226 227 228 229 230
		= sort $ funs ++ members ++ types ++ classes ++ macros ++ modules

	makeModuleResult :: (Maybe String) (Library, Module, ModuleInfo) -> Result
	makeModuleResult mbName (lib, mod, info)
		= ModuleResult
231 232
		  ( { library  = lib
		    , modul    = mod
Camil Staps's avatar
Camil Staps committed
233 234 235
		    , filename = modToFilename mod
		    , dcl_line = Nothing
		    , icl_line = Nothing
236
		    , distance = modLevenshtein (fromJust mbName) mod
Camil Staps's avatar
Camil Staps committed
237 238 239 240 241
		    , builtin  = Nothing
		    }
		  , { module_is_core = info.is_core
		    }
		  )
Camil Staps's avatar
Camil Staps committed
242

243
	makeClassResult :: (Location, [TypeVar], ClassContext, [(Name,ExtendedType)])
Camil Staps's avatar
Camil Staps committed
244
		TypeDB -> Result
Camil Staps's avatar
Camil Staps committed
245 246 247 248 249
	makeClassResult rec=:(Builtin _, _, _, _) db
		= ClassResult
		  ( { library  = ""
		    , filename = ""
		    , dcl_line = Nothing
250
		    , icl_line = Nothing
Camil Staps's avatar
Camil Staps committed
251 252 253 254 255 256
		    , modul    = ""
		    , distance = -100
		    , builtin  = Just True
		    }
		  , makeClassResultExtras rec db
		  )
257
	makeClassResult rec=:(Location lib mod line iclline cls, vars, cc, funs) db
Camil Staps's avatar
Camil Staps committed
258 259 260
		= ClassResult
		  ( { library  = lib
		    , filename = modToFilename mod
Camil Staps's avatar
Camil Staps committed
261
		    , dcl_line = line
262
		    , icl_line = iclline
Camil Staps's avatar
Camil Staps committed
263
		    , modul    = mod
264
		    , distance = -100
Camil Staps's avatar
Camil Staps committed
265
		    , builtin  = Nothing
Camil Staps's avatar
Camil Staps committed
266
		    }
Camil Staps's avatar
Camil Staps committed
267
		  , makeClassResultExtras rec db
Camil Staps's avatar
Camil Staps committed
268
		  )
Camil Staps's avatar
Camil Staps committed
269 270 271 272 273
	makeClassResultExtras :: (Location, [TypeVar], ClassContext, [(Name,ExtendedType)])
		TypeDB -> ClassResultExtras
	makeClassResultExtras (l, vars, cc, funs) db
		= { class_name = cls
		  , class_heading = foldl ((+) o (flip (+) " ")) cls vars +
274
		      if (isEmpty cc) "" " | " + concat (print False cc)
Camil Staps's avatar
Camil Staps committed
275 276 277
		  , class_funs = [print_fun fun \\ fun <- funs]
		  , class_instances
		      = sortBy (\(a,_) (b,_) -> a < b)
278
		          [(map snd ts, map loc ls) \\ (ts,ls) <- getInstances cls db]
Camil Staps's avatar
Camil Staps committed
279
		  }
280
	where
Camil Staps's avatar
Camil Staps committed
281 282
		cls = case l of
			Builtin c = c
283
			Location _ _ _ _ c = c
Camil Staps's avatar
Camil Staps committed
284

285 286 287
		print_fun :: (Name,ExtendedType) -> String
		print_fun f=:(_,ET _ et) = fromJust $
			et.te_representation <|> (pure $ concat $ print False f)
Camil Staps's avatar
Camil Staps committed
288

289
	makeTypeResult :: (Maybe String) Location TypeDef TypeDB -> Result
290
	makeTypeResult mbName (Location lib mod line iclline t) td db
Camil Staps's avatar
Camil Staps committed
291 292 293
		= TypeResult
		  ( { library  = lib
		    , filename = modToFilename mod
Camil Staps's avatar
Camil Staps committed
294
		    , dcl_line = line
295
		    , icl_line = iclline
Camil Staps's avatar
Camil Staps committed
296
		    , modul    = mod
Camil Staps's avatar
Camil Staps committed
297
		    , distance
298
		        = if (isNothing mbName) -100 (levenshtein` t (fromJust mbName))
Camil Staps's avatar
Camil Staps committed
299 300
		    , builtin  = Nothing
		    }
301
		  , { type             = concat $ print False td
302
		    , type_instances   = map (appSnd3 (map snd)) $
303
		        map (appThd3 (map loc)) $ getTypeInstances t db
304 305
		    , type_derivations = map (appSnd (map loc)) $ getTypeDerivations t db
		    }
Camil Staps's avatar
Camil Staps committed
306
		  )
307
	makeTypeResult mbName (Builtin t) td db
Camil Staps's avatar
Camil Staps committed
308 309 310
		= TypeResult
		  ( { library  = ""
		    , filename = ""
Camil Staps's avatar
Camil Staps committed
311
		    , dcl_line = Nothing
312
		    , icl_line = Nothing
Camil Staps's avatar
Camil Staps committed
313 314 315 316
		    , modul    = ""
		    , distance
		        = if (isNothing mbName) -100 (levenshtein` t (fromJust mbName))
		    , builtin  = Just True
Camil Staps's avatar
Camil Staps committed
317
		    }
318
		  , { type             = concat $ print False td
319
		    , type_instances   = map (appSnd3 (map snd)) $
320
		        map (appThd3 (map loc)) $ getTypeInstances t db
321 322
		    , type_derivations = map (appSnd (map loc)) $ getTypeDerivations t db
		    }
Camil Staps's avatar
Camil Staps committed
323 324
		  )

325
	makeMacroResult :: (Maybe String) Location Macro -> Result
326
	makeMacroResult mbName (Location lib mod line iclline m) mac
Camil Staps's avatar
Camil Staps committed
327 328 329
		= MacroResult
		  ( { library  = lib
		    , filename = modToFilename mod
Camil Staps's avatar
Camil Staps committed
330
		    , dcl_line = line
331
		    , icl_line = iclline
Camil Staps's avatar
Camil Staps committed
332 333
		    , modul    = mod
		    , distance
Camil Staps's avatar
Camil Staps committed
334
		        = if (isNothing mbName) -100 (levenshtein` (fromJust mbName) m)
Camil Staps's avatar
Camil Staps committed
335
		    , builtin  = Nothing
Camil Staps's avatar
Camil Staps committed
336 337 338 339 340 341
		    }
		  , { macro_name = m
		    , macro_representation = mac.macro_as_string
		    }
		  )

Camil Staps's avatar
Camil Staps committed
342
	makeFunctionResult :: (Maybe String) (Maybe Type) (Maybe ShortClassResult)
343
		(Location, ExtendedType) TypeDB -> Result
Camil Staps's avatar
Camil Staps committed
344
	makeFunctionResult
Camil Staps's avatar
Camil Staps committed
345
		orgsearch orgsearchtype mbCls (fl, et=:(ET type tes)) db
Camil Staps's avatar
Camil Staps committed
346 347
		= FunctionResult
		  ( { library  = lib
Camil Staps's avatar
Camil Staps committed
348
		    , filename = modToFilename mod
Camil Staps's avatar
Camil Staps committed
349
		    , dcl_line = line
350
		    , icl_line = iclline
Camil Staps's avatar
Camil Staps committed
351 352
		    , modul    = mod
		    , distance = distance
Camil Staps's avatar
Camil Staps committed
353
		    , builtin  = builtin
Camil Staps's avatar
Camil Staps committed
354
		    }
355 356
		  , { func     = fromJust (tes.te_representation <|>
		                           (pure $ concat $ print False (fname,et)))
357 358
		    , unifier  = toStrUnifier <$> finish_unification <$>
		        (orgsearchtype >>= unify [] (prepare_unification False type))
Camil Staps's avatar
Camil Staps committed
359
		    , cls      = mbCls
360
		    , constructor_of = if tes.te_isconstructor
Camil Staps's avatar
Camil Staps committed
361 362
		        (let (Func _ r _) = type in Just $ concat $ print False r)
		        Nothing
363
		    , recordfield_of = if tes.te_isrecordfield
Camil Staps's avatar
Camil Staps committed
364 365
		        (let (Func [t:_] _ _) = type in Just $ concat $ print False t)
		        Nothing
366 367
		    , generic_derivations
		        = let derivs = getDerivations fname db in
Camil Staps's avatar
Camil Staps committed
368
		          const (sortBy (\(a,_) (b,_) -> a < b)
369
				    [(s, map loc ls) \\ (_,s,ls) <- derivs]) <$>
Camil Staps's avatar
Camil Staps committed
370
		          tes.te_generic_vars
Camil Staps's avatar
Camil Staps committed
371 372
		    }
		  )
Camil Staps's avatar
Camil Staps committed
373
	where
374 375 376
		(lib,mod,fname,line,iclline,builtin) = case fl of
			(Location l m ln iln f) = (l,  m,  f, ln,      iln,     Nothing)
			(Builtin f)             = ("", "", f, Nothing, Nothing, Just True)
Camil Staps's avatar
Camil Staps committed
377

378 379
		toStrUnifier :: Unifier -> StrUnifier
		toStrUnifier (tvas1, tvas2) = (map toStr tvas1, map toStr tvas2)
380
		where toStr (var, type) = (var, concat $ print False type)
381

Camil Staps's avatar
Camil Staps committed
382
		toStrPriority :: (Maybe Priority) -> String
383
		toStrPriority p = case print False p of [] = ""; ss = concat [" ":ss]
Camil Staps's avatar
Camil Staps committed
384

Camil Staps's avatar
Camil Staps committed
385
		distance
Camil Staps's avatar
Camil Staps committed
386
			| isNothing orgsearch || fromJust orgsearch == ""
Camil Staps's avatar
Camil Staps committed
387 388
				| isNothing orgsearchtype = 0
				# orgsearchtype = fromJust orgsearchtype
389 390
				# (Just (ass1, ass2)) = finish_unification <$>
					unify [] orgsearchtype (prepare_unification False type)
391
				= penalty + toInt (sum [typeComplexity t \\ (_,t)<-ass1 ++ ass2 | not (isVar t)])
392
			# orgsearch = fromJust orgsearch
393
			= penalty + levenshtein` orgsearch fname
394
		where
395 396 397 398 399
			penalty
			| tes.te_isrecordfield = 2
			| tes.te_isconstructor = 1
			| otherwise            = 0

400 401 402 403 404 405
			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
Camil Staps's avatar
Camil Staps committed
406

Camil Staps's avatar
Camil Staps committed
407
	levenshtein` :: String String -> Int
408 409 410 411
	levenshtein` a b = if (indexOf a b == -1) 0 -100 +
		levenshtein [c \\ c <-: a] [c \\ c <-: b]

	modLevenshtein :: String Module -> Int
Camil Staps's avatar
Camil Staps committed
412 413 414 415 416
	modLevenshtein s mod
	| s == mod        = -100
	| isMember s path = length path
	| otherwise       = levenshtein` s mod
	where path = split "." mod
Camil Staps's avatar
Camil Staps committed
417

Camil Staps's avatar
Camil Staps committed
418 419
	modToFilename :: String -> String
	modToFilename mod = (toString $ reverse $ takeWhile ((<>)'.')
420
	                              $ reverse $ fromString mod) + ".dcl"
Camil Staps's avatar
Camil Staps committed
421

Camil Staps's avatar
Camil Staps committed
422
	isUnifiable :: Type ExtendedType -> Bool
423
	isUnifiable t1 (ET t2 _) = isJust (unify [] t1 (prepare_unification False t2))
Camil Staps's avatar
Camil Staps committed
424

Camil Staps's avatar
Camil Staps committed
425 426 427
	isNameMatch :: !Int !String !String -> Bool
	isNameMatch maxdist n1 name
		# (n1, n2) = ({toLower c \\ c <-: n1}, {toLower c \\ c <-: name})
Camil Staps's avatar
Camil Staps committed
428
		= n1 == "" || indexOf n1 n2 <> -1 || levenshtein [c \\ c <-: n1] [c \\ c <-: n2] <= maxdist
Camil Staps's avatar
Camil Staps committed
429

430 431
	isModNameMatch :: !Int !String !Module -> Bool
	isModNameMatch maxdist name mod
Camil Staps's avatar
Camil Staps committed
432
		= isNameMatch maxdist name mod || isMember name (split "." mod)
433

434
	isModMatch :: ![String] Location -> Bool
435 436
	isModMatch mods (Location _ mod _ _ _) = isMember mod mods
	isModMatch _    (Builtin _)            = False
Camil Staps's avatar
Camil Staps committed
437

438 439 440
	isLibMatch :: ![String] Location -> Bool
	isLibMatch libs (Location lib _ _ _ _) = any (\l -> indexOf l lib == 0) libs
	isLibMatch _    (Builtin _)            = True
Camil Staps's avatar
Camil Staps committed
441

442
	loc :: Location -> LocationResult
443
	loc (Location lib mod ln iln _) = (lib, mod, ln, iln)
Camil Staps's avatar
Camil Staps committed
444

445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506
:: LogMemory =
	{ mem_ip         :: IPAddress
	, mem_time_start :: Tm
	, mem_time_end   :: Tm
	, mem_request    :: 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       :: 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 <<< msgToString 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 (Just 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)

	msgToString :: LogMessage` LogMemory -> String
	msgToString (Sent response ck) mem
		= toString $ toJSON
			{ ip            = toString mem.mem_ip
			, time_start    = (toString mem.mem_time_start, toInt $ mkTime mem.mem_time_start)
			, time_end      = (toString mem.mem_time_end, toInt $ mkTime mem.mem_time_end)
			, request       = mem.mem_request
			, cachekey      = ck
			, response_code = response.return
			, results       = length response.data
			}