CloogleServer.icl 18.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 17 18 19
import Control.Applicative
import Control.Monad
import qualified Data.Foldable as Foldable
from Data.Foldable import class Foldable, instance Foldable Maybe
20
from Data.Func import $
21
import Data.Functor
Camil Staps's avatar
Camil Staps committed
22
import Data.List
23
import Data.Maybe
24
import Data.Tuple
25
import System.CommandLine
26
from Text import class Text(concat,trim,indexOf,toLowerCase,split),
27
	instance Text String, instance + String
28
import Text.JSON
Camil Staps's avatar
Camil Staps committed
29 30

import System.Time
31

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

39
MAX_RESULTS    :== 15
Camil Staps's avatar
Camil Staps committed
40
CACHE_PREFETCH :== 5
41

42 43 44
DEFAULT_INCLUDE_BUILTINS :== True
DEFAULT_INCLUDE_CORE :== False

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

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
63 64 65 66 67 68
	{ 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
69 70
	, 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
71
	, c_page             = fromJust (r.page <|> Just 0)
72 73
	}

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

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

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

Camil Staps's avatar
Camil Staps committed
140 141 142 143
		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
144
		# w = writeCache Brief req` resp` w
Camil Staps's avatar
Camil Staps committed
145
		= cachePages key (npages - 1) (i + 1) response keep w
Camil Staps's avatar
Camil Staps committed
146
		where
Camil Staps's avatar
Camil Staps committed
147
			req` = { key & c_page = key.c_page + i }
Camil Staps's avatar
Camil Staps committed
148 149 150 151 152 153
			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
154

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

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

	makeModuleResult :: (Maybe String) (Library, Module, ModuleInfo) -> Result
	makeModuleResult mbName (lib, mod, info)
		= ModuleResult
238 239
		  ( { library  = lib
		    , modul    = mod
Camil Staps's avatar
Camil Staps committed
240 241 242
		    , filename = modToFilename mod
		    , dcl_line = Nothing
		    , icl_line = Nothing
243
		    , distance = modLevenshtein (fromJust mbName) mod
Camil Staps's avatar
Camil Staps committed
244 245 246 247 248
		    , builtin  = Nothing
		    }
		  , { module_is_core = info.is_core
		    }
		  )
Camil Staps's avatar
Camil Staps committed
249

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

292 293 294
		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
295

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

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

349
	makeFunctionResult :: (Maybe String) (Maybe Type) [TypeDef] (Maybe ShortClassResult)
350
		(Location, ExtendedType) TypeDB -> Result
Camil Staps's avatar
Camil Staps committed
351
	makeFunctionResult
352
		orgsearch orgsearchtype usedsynonyms mbCls (fl, et=:(ET type tes)) db
Camil Staps's avatar
Camil Staps committed
353 354
		= FunctionResult
		  ( { library  = lib
Camil Staps's avatar
Camil Staps committed
355
		    , filename = modToFilename mod
Camil Staps's avatar
Camil Staps committed
356
		    , dcl_line = line
357
		    , icl_line = iclline
Camil Staps's avatar
Camil Staps committed
358 359
		    , modul    = mod
		    , distance = distance
Camil Staps's avatar
Camil Staps committed
360
		    , builtin  = builtin
Camil Staps's avatar
Camil Staps committed
361
		    }
362 363
		  , { func     = fromJust (tes.te_representation <|>
		                           (pure $ concat $ print False (fname,et)))
364
		    , unifier  = toStrUnifier <$> finish_unification (unisyns ++ usedsynonyms) <$>
365
		        (orgsearchtype >>= unify [] unitype)
Camil Staps's avatar
Camil Staps committed
366
		    , cls      = mbCls
367
		    , constructor_of = if tes.te_isconstructor
Camil Staps's avatar
Camil Staps committed
368 369
		        (let (Func _ r _) = type in Just $ concat $ print False r)
		        Nothing
370
		    , recordfield_of = if tes.te_isrecordfield
Camil Staps's avatar
Camil Staps committed
371 372
		        (let (Func [t:_] _ _) = type in Just $ concat $ print False t)
		        Nothing
373 374
		    , generic_derivations
		        = let derivs = getDerivations fname db in
Camil Staps's avatar
Camil Staps committed
375
		          const (sortBy (\(a,_) (b,_) -> a < b)
376
				    [(s, map loc ls) \\ (_,s,ls) <- derivs]) <$>
Camil Staps's avatar
Camil Staps committed
377
		          tes.te_generic_vars
Camil Staps's avatar
Camil Staps committed
378 379
		    }
		  )
Camil Staps's avatar
Camil Staps committed
380
	where
381 382 383
		(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
384

385
		(unisyns, unitype) = prepare_unification` False db type
Camil Staps's avatar
Camil Staps committed
386

387
		toStrUnifier :: Unifier -> StrUnifier
388 389 390 391
		toStrUnifier unif =
			{ StrUnifier
			| left_to_right = map toStr unif.Unifier.left_to_right
			, right_to_left = map toStr unif.Unifier.right_to_left
392 393 394 395
			, used_synonyms = [
				( concat $ [td.td_name," ":intersperse " " $ print False td.td_args]
				, concat $ print False s)
				\\ td=:{td_rhs=TDRSynonym s} <- unif.Unifier.used_synonyms]
396 397 398
			}
		where
			toStr (var, type) = (var, concat $ print False type)
399

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

Camil Staps's avatar
Camil Staps committed
403
		distance
Camil Staps's avatar
Camil Staps committed
404
			| isNothing orgsearch || fromJust orgsearch == ""
Camil Staps's avatar
Camil Staps committed
405 406
				| isNothing orgsearchtype = 0
				# orgsearchtype = fromJust orgsearchtype
407 408 409
				# (syns, t) = prepare_unification` False db type
				# (Just unif) = finish_unification syns <$> unify [] orgsearchtype t
				= penalty + toInt (sum [typeComplexity t \\ (_,t) <- allTvas unif | not (isVar t)])
410
			# orgsearch = fromJust orgsearch
411
			= penalty + levenshtein` orgsearch fname
412
		where
413 414 415 416 417
			penalty
			| tes.te_isrecordfield = 2
			| tes.te_isconstructor = 1
			| otherwise            = 0

418 419 420
			allTvas :: Unifier -> [TVAssignment]
			allTvas unif = unif.Unifier.left_to_right ++ unif.Unifier.right_to_left

421 422 423 424 425 426
			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
427

428 429
	prepare_unification` :: !Bool !TypeDB -> Type -> ([TypeDef], Type)
	prepare_unification` b db = prepare_unification b (allTypes db)
430

Camil Staps's avatar
Camil Staps committed
431
	levenshtein` :: String String -> Int
432 433 434 435
	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
436 437 438 439 440
	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
441

Camil Staps's avatar
Camil Staps committed
442 443
	modToFilename :: String -> String
	modToFilename mod = (toString $ reverse $ takeWhile ((<>)'.')
444
	                              $ reverse $ fromString mod) + ".dcl"
Camil Staps's avatar
Camil Staps committed
445

446 447 448
	isUnifiable :: !Type !TypeDB !ExtendedType -> Bool
	isUnifiable t1 db (ET t2 _) = isJust $ unify [] t1 t2`
	where
449
		(_, t2`) = (prepare_unification` False db t2)
Camil Staps's avatar
Camil Staps committed
450

Camil Staps's avatar
Camil Staps committed
451 452 453
	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
454
		= n1 == "" || indexOf n1 n2 <> -1 || levenshtein [c \\ c <-: n1] [c \\ c <-: n2] <= maxdist
Camil Staps's avatar
Camil Staps committed
455

456 457
	isModNameMatch :: !Int !String !Module -> Bool
	isModNameMatch maxdist name mod
Camil Staps's avatar
Camil Staps committed
458
		= isNameMatch maxdist name mod || isMember name (split "." mod)
459

460
	isModMatch :: ![String] Location -> Bool
461 462
	isModMatch mods (Location _ mod _ _ _) = isMember mod mods
	isModMatch _    (Builtin _)            = False
Camil Staps's avatar
Camil Staps committed
463

464 465 466
	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
467

468
	loc :: Location -> LocationResult
469
	loc (Location lib mod ln iln _) = (lib, mod, ln, iln)
Camil Staps's avatar
Camil Staps committed
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
Camil Staps's avatar
Camil Staps committed
507
# io      = io <<< toString (toJSON $ makeLogEntry msg mem) <<< "\n"
508 509 510 511 512 513 514 515 516 517 518 519 520 521
= (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)

Camil Staps's avatar
Camil Staps committed
522 523 524 525 526 527 528 529 530 531
	makeLogEntry :: LogMessage` LogMemory -> LogEntry
	makeLogEntry (Sent response ck) mem =
		{ 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
		}