CloogleServer.icl 17.4 KB
Newer Older
1 2
module CloogleServer

3
import StdArray, StdBool, StdFile, StdList, StdOrdList, StdOverloaded, StdTuple
Camil Staps's avatar
Camil Staps committed
4
from StdFunc import o, flip, const
5
from StdMisc import abort
6

7
from TCPIP import :: IPAddress, :: Port, instance toString IPAddress
8 9

from Data.Func import $
Camil Staps's avatar
Camil Staps committed
10
import Data.List
11
import Data.Tuple
12 13 14 15 16
import Data.Maybe
import System.CommandLine
import Text.JSON
import Data.Functor
import Control.Applicative
17
import Control.Monad
Camil Staps's avatar
Camil Staps committed
18
from Text import class Text(concat,trim,indexOf,toLowerCase),
19
	instance Text String, instance + String
Camil Staps's avatar
Camil Staps committed
20 21

import System.Time
22

23 24
from SimpleTCPServer import :: LogMessage{..}, serve, :: Logger
import qualified SimpleTCPServer
25 26
import TypeDB
import Type
27
import Cache
Mart Lubbers's avatar
Mart Lubbers committed
28

Camil Staps's avatar
Camil Staps committed
29 30 31
:: Request = { unify     :: Maybe String
             , name      :: Maybe String
             , className :: Maybe String
Camil Staps's avatar
Camil Staps committed
32
             , typeName  :: Maybe String
Camil Staps's avatar
Camil Staps committed
33
             , modules   :: Maybe [String]
34
             , libraries :: Maybe ([String], Bool)
Camil Staps's avatar
Camil Staps committed
35
             , page      :: Maybe Int
36 37
             }

Camil Staps's avatar
Camil Staps committed
38 39 40
:: Response = { return         :: Int
              , data           :: [Result]
              , msg            :: String
Camil Staps's avatar
Camil Staps committed
41
              , more_available :: Maybe Int
42
              , suggestions    :: Maybe [(Request, Int)]
43 44
              }

Camil Staps's avatar
Camil Staps committed
45
:: Result = FunctionResult FunctionResult
Camil Staps's avatar
Camil Staps committed
46
          | TypeResult TypeResult
Camil Staps's avatar
Camil Staps committed
47
          | ClassResult ClassResult
Camil Staps's avatar
Camil Staps committed
48
          | MacroResult MacroResult
Camil Staps's avatar
Camil Staps committed
49 50 51 52

:: BasicResult = { library  :: String
                 , filename :: String
                 , modul    :: String
Camil Staps's avatar
Camil Staps committed
53
                 , dcl_line :: Maybe Int
54
                 , icl_line :: Maybe Int
Camil Staps's avatar
Camil Staps committed
55
                 , distance :: Int
Camil Staps's avatar
Camil Staps committed
56
                 , builtin  :: Maybe Bool
Camil Staps's avatar
Camil Staps committed
57 58
                 }

Camil Staps's avatar
Camil Staps committed
59
:: FunctionResult :== (BasicResult, FunctionResultExtras)
Camil Staps's avatar
Camil Staps committed
60 61 62 63 64
:: FunctionResultExtras = { func                :: String
                          , unifier             :: Maybe StrUnifier
                          , cls                 :: Maybe ShortClassResult
                          , constructor_of      :: Maybe String
                          , recordfield_of      :: Maybe String
65
                          , generic_derivations :: Maybe [(String, [LocationResult])]
Camil Staps's avatar
Camil Staps committed
66 67 68
                          }

:: TypeResult :== (BasicResult, TypeResultExtras)
69
:: TypeResultExtras = { type             :: String
70
                      , type_instances   :: [(String, [String], [LocationResult])]
71
                      , type_derivations :: [(String, [LocationResult])]
Camil Staps's avatar
Camil Staps committed
72
                      }
73

Camil Staps's avatar
Camil Staps committed
74
:: ClassResult :== (BasicResult, ClassResultExtras)
75 76 77
:: ClassResultExtras = { class_name      :: String
                       , class_heading   :: String
                       , class_funs      :: [String]
78
                       , class_instances :: [([String], [LocationResult])]
Camil Staps's avatar
Camil Staps committed
79 80
                       }

Camil Staps's avatar
Camil Staps committed
81
:: MacroResult :== (BasicResult, MacroResultExtras)
82
:: MacroResultExtras = { macro_name           :: String
Camil Staps's avatar
Camil Staps committed
83 84 85
                       , macro_representation :: String
                       }

86
:: LocationResult :== (String, String, Maybe Int, Maybe Int)
87

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

Mart Lubbers's avatar
Mart Lubbers committed
90
:: ErrorResult = MaybeError Int String
Camil Staps's avatar
Camil Staps committed
91

Camil Staps's avatar
Camil Staps committed
92
:: ShortClassResult = { cls_name :: String, cls_vars :: [String] }
Camil Staps's avatar
Camil Staps committed
93

Camil Staps's avatar
Camil Staps committed
94
derive JSONEncode Request, Response, Result, ShortClassResult, BasicResult,
Camil Staps's avatar
Camil Staps committed
95
	FunctionResultExtras, TypeResultExtras, ClassResultExtras, MacroResultExtras
Camil Staps's avatar
Camil Staps committed
96
derive JSONDecode Request, Response, Result, ShortClassResult, BasicResult,
Camil Staps's avatar
Camil Staps committed
97
	FunctionResultExtras, TypeResultExtras, ClassResultExtras, MacroResultExtras
98

Camil Staps's avatar
Camil Staps committed
99 100
instance zero Request
where
Camil Staps's avatar
Camil Staps committed
101 102 103
	zero = { unify     = Nothing
	       , name      = Nothing
	       , className = Nothing
Camil Staps's avatar
Camil Staps committed
104
	       , typeName  = Nothing
Camil Staps's avatar
Camil Staps committed
105
	       , modules   = Nothing
Camil Staps's avatar
Camil Staps committed
106
	       , libraries = Nothing
Camil Staps's avatar
Camil Staps committed
107
	       , page      = Nothing
Camil Staps's avatar
Camil Staps committed
108 109
	       }

110
instance toString Response where toString r = toString (toJSON r) + "\n"
Camil Staps's avatar
Camil Staps committed
111
instance toString Request where toString r = toString $ toJSON r
112

Camil Staps's avatar
Camil Staps committed
113
instance fromString (Maybe Request) where fromString s = fromJSON $ fromString s
114

Camil Staps's avatar
Camil Staps committed
115 116 117 118 119 120 121
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
122 123 124
		basic (TypeResult     (br,_)) = br
		basic (ClassResult    (br,_)) = br
		basic (MacroResult    (br,_)) = br
125 126

err :: Int String -> Response
Camil Staps's avatar
Camil Staps committed
127 128 129 130 131 132
err c m = { return         = c
          , data           = []
          , msg            = m
          , more_available = Nothing
          , suggestions    = Nothing
          }
133

134
E_NORESULTS    :== 127
Camil Staps's avatar
Camil Staps committed
135
E_INVALIDINPUT :== 128
136 137
E_INVALIDNAME  :== 129
E_INVALIDTYPE  :== 130
Camil Staps's avatar
Camil Staps committed
138

139
MAX_RESULTS    :== 15
Camil Staps's avatar
Camil Staps committed
140
CACHE_PREFETCH :== 5
141

142 143 144 145 146 147 148 149 150
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"
151
#! db = fromJust db
Camil Staps's avatar
Camil Staps committed
152
= serve (handle db) (Just log) port w
153
where
Camil Staps's avatar
Camil Staps committed
154 155 156 157 158
	help :: *File *World -> *World
	help io w
	# io = io <<< "Usage: ./CloogleServer <port>\n"
	= snd $ fclose io w

Camil Staps's avatar
Camil Staps committed
159 160
	handle :: !TypeDB !(Maybe Request) !*World -> *(!Response, CacheKey, !*World)
	handle _ Nothing w = (err E_INVALIDINPUT "Couldn't parse input", "", w)
Camil Staps's avatar
Camil Staps committed
161
	handle db (Just request=:{unify,name,page}) w
162
		//Check cache
163 164 165
		# (mbResponse, w) = readCache request w
		| isJust mbResponse
			# r = fromJust mbResponse
Camil Staps's avatar
Camil Staps committed
166
			= ({r & return = if (r.return == 0) 1 r.return}, cacheKey request, w)
167
		| isJust name && size (fromJust name) > 40
168
			= respond (err E_INVALIDNAME "Function name too long") w
Camil Staps's avatar
Camil Staps committed
169
		| isJust name && any isSpace (fromString $ fromJust name)
170
			= respond (err E_INVALIDNAME "Name cannot contain spaces") w
Camil Staps's avatar
Camil Staps committed
171
		| isJust unify && isNothing (parseType $ fromString $ fromJust unify)
172
			= respond (err E_INVALIDTYPE "Couldn't parse type") w
Camil Staps's avatar
Camil Staps committed
173 174
		// Results
		# drop_n = fromJust (page <|> pure 0) * MAX_RESULTS
Camil Staps's avatar
oops  
Camil Staps committed
175
		# results = drop drop_n $ sort $ search request db
Camil Staps's avatar
Camil Staps committed
176 177
		# more = max 0 (length results - MAX_RESULTS)
		// Suggestions
178
		# mbType = unify >>= parseType o fromString
Camil Staps's avatar
Camil Staps committed
179
		# suggestions
180 181
			= sortBy (\a b -> snd a > snd b) <$>
			  filter ((<)(length results) o snd) <$>
182
			  (mbType >>= \t -> suggs name t db)
Camil Staps's avatar
Camil Staps committed
183
		# (results,nextpages) = splitAt MAX_RESULTS results
Camil Staps's avatar
Camil Staps committed
184
		// Response
185 186 187
		# response = if (isEmpty results)
			(err E_NORESULTS "No results")
			{ return = 0
Camil Staps's avatar
Camil Staps committed
188 189 190 191
		    , msg = "Success"
		    , data           = results
		    , more_available = Just more
		    , suggestions    = suggestions
192
		    }
Camil Staps's avatar
Camil Staps committed
193 194
		// Save page prefetches
		# w = cachePages CACHE_PREFETCH 1 response nextpages w
195
		// Save cache file
196 197
		= respond response w
	where
Camil Staps's avatar
Camil Staps committed
198 199
		respond :: Response *World -> *(Response, CacheKey, *World)
		respond r w = (r, cacheKey request, writeCache LongTerm request r w)
Camil Staps's avatar
Camil Staps committed
200 201 202 203 204 205 206 207

		cachePages :: Int Int Response [Result] *World -> *World
		cachePages _ _  _ [] w = w
		cachePages 0 _  _ _  w = w
		cachePages npages i response results w
		# w = writeCache Brief req` resp` w
		= cachePages (npages - 1) (i + 1) response keep w
		where
208
			req` = { request & page = ((+) i) <$> (request.page <|> pure 0) }
Camil Staps's avatar
Camil Staps committed
209 210 211 212 213 214
			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
215

216
	suggs :: !(Maybe String) !Type !TypeDB -> Maybe [(Request, Int)]
217
	suggs n (Func is r cc) db
218 219
		| length is < 3
			= Just [let t` = concat $ print False $ Func is` r cc in
220 221
			        let request = {zero & name=n, unify=Just t`} in
			        (request, length $ search request db)
222
			        \\ is` <- permutations is | is` <> is]
223
	suggs _ _ _ = Nothing
Camil Staps's avatar
Camil Staps committed
224

225
	search :: !Request !TypeDB -> [Result]
Camil Staps's avatar
Camil Staps committed
226 227 228 229
	search {unify,name,className,typeName,modules,libraries,page} db
		# db = case libraries of
			(Just ls) = filterLocations (isLibMatch ls) db
			Nothing   = db
230 231 232
		# db = case modules of
			(Just ms) = filterLocations (isModMatch ms) db
			Nothing   = db
Camil Staps's avatar
Camil Staps committed
233 234 235 236
		| isJust className
			# className = fromJust className
			# classes = findClass className db
			= map (flip makeClassResult db) classes
Camil Staps's avatar
Camil Staps committed
237 238 239
		| isJust typeName
			# typeName = fromJust typeName
			# types = findType typeName db
240
			= [makeTypeResult (Just typeName) l td db \\ (l,td) <- types]
241
		# mbType = prepare_unification True <$> (unify >>= parseType o fromString)
Camil Staps's avatar
Camil Staps committed
242
		// Search normal functions
243
		# filts = catMaybes [ (\t _ -> isUnifiable t) <$> mbType
244
		                    , (\n loc _ -> isNameMatch (size n*2/3) n loc) <$> name
245
		                    ]
246
		# funs = map (\f -> makeFunctionResult name mbType Nothing f db) $ findFunction`` filts db
Camil Staps's avatar
Camil Staps committed
247
		// Search macros
248
		# macros = case (isNothing mbType,name) of
249
			(True,Just n) = findMacro` (\loc _ -> isNameMatch (size n*2/3) n loc) db
250
			_             = []
Camil Staps's avatar
Camil Staps committed
251
		# macros = map (\(lhs,rhs) -> makeMacroResult name lhs rhs) macros
Camil Staps's avatar
Camil Staps committed
252
		// Search class members
Camil Staps's avatar
Camil Staps committed
253
		# filts = catMaybes [ (\t _ _ _ _->isUnifiable t) <$> mbType
254 255
		                    , (\n (Location lib mod _ _ _) _ _ f _ -> isNameMatch
		                      (size n*2/3) n (Location lib mod Nothing Nothing f)) <$> name
256
		                    ]
Camil Staps's avatar
Camil Staps committed
257
		# members = findClassMembers`` filts db
258 259
		# 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
260
		// Search types
261
		# lcName = if (isJust mbType && isType (fromJust mbType))
Camil Staps's avatar
Camil Staps committed
262 263
			(let (Type name _) = fromJust mbType in Just $ toLowerCase name)
			(toLowerCase <$> name)
264 265 266
		# types = case (isNothing mbType,lcName) of
			(True,Just n) = findType` (\loc _ -> toLowerCase (getName loc) == n) db
			_             = []
267
		# types = map (\(tl,td) -> makeTypeResult name tl td db) types
268 269
		// Search classes
		# classes = case (isNothing mbType, toLowerCase <$> name) of
Camil Staps's avatar
Camil Staps committed
270
			(True, Just c) = findClass` (\loc _ _ _ -> toLowerCase (getName loc) == c) db
Camil Staps's avatar
Camil Staps committed
271 272
			_              = []
		# classes = map (flip makeClassResult db) classes
Camil Staps's avatar
Camil Staps committed
273
		// Merge results
Camil Staps's avatar
Camil Staps committed
274
		= sort $ funs ++ members ++ types ++ classes ++ macros
Camil Staps's avatar
Camil Staps committed
275

276
	makeClassResult :: (Location, [TypeVar], ClassContext, [(Name,ExtendedType)])
Camil Staps's avatar
Camil Staps committed
277
		TypeDB -> Result
Camil Staps's avatar
Camil Staps committed
278 279 280 281 282
	makeClassResult rec=:(Builtin _, _, _, _) db
		= ClassResult
		  ( { library  = ""
		    , filename = ""
		    , dcl_line = Nothing
283
		    , icl_line = Nothing
Camil Staps's avatar
Camil Staps committed
284 285 286 287 288 289
		    , modul    = ""
		    , distance = -100
		    , builtin  = Just True
		    }
		  , makeClassResultExtras rec db
		  )
290
	makeClassResult rec=:(Location lib mod line iclline cls, vars, cc, funs) db
Camil Staps's avatar
Camil Staps committed
291 292 293
		= ClassResult
		  ( { 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
297
		    , distance = -100
Camil Staps's avatar
Camil Staps committed
298
		    , builtin  = Nothing
Camil Staps's avatar
Camil Staps committed
299
		    }
Camil Staps's avatar
Camil Staps committed
300
		  , makeClassResultExtras rec db
Camil Staps's avatar
Camil Staps committed
301
		  )
Camil Staps's avatar
Camil Staps committed
302 303 304 305 306
	makeClassResultExtras :: (Location, [TypeVar], ClassContext, [(Name,ExtendedType)])
		TypeDB -> ClassResultExtras
	makeClassResultExtras (l, vars, cc, funs) db
		= { class_name = cls
		  , class_heading = foldl ((+) o (flip (+) " ")) cls vars +
307
		      if (isEmpty cc) "" " | " + concat (print False cc)
Camil Staps's avatar
Camil Staps committed
308 309 310 311 312 313
		  , class_funs = [print_fun fun \\ fun <- funs]
		  , class_instances
		      = sortBy (\(a,_) (b,_) -> a < b)
		          [([concat (print False t) \\ t <- ts], map loc ls)
		          \\ (ts,ls) <- getInstances cls db]
		  }
314
	where
Camil Staps's avatar
Camil Staps committed
315 316
		cls = case l of
			Builtin c = c
317
			Location _ _ _ _ c = c
Camil Staps's avatar
Camil Staps committed
318

319 320 321
		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
322

323
	makeTypeResult :: (Maybe String) Location TypeDef TypeDB -> Result
324
	makeTypeResult mbName (Location lib mod line iclline t) td db
Camil Staps's avatar
Camil Staps committed
325 326 327
		= TypeResult
		  ( { library  = lib
		    , filename = modToFilename mod
Camil Staps's avatar
Camil Staps committed
328
		    , dcl_line = line
329
		    , icl_line = iclline
Camil Staps's avatar
Camil Staps committed
330
		    , modul    = mod
Camil Staps's avatar
Camil Staps committed
331
		    , distance
332
		        = if (isNothing mbName) -100 (levenshtein` t (fromJust mbName))
Camil Staps's avatar
Camil Staps committed
333 334
		    , builtin  = Nothing
		    }
335
		  , { type             = concat $ print False td
336 337
		    , type_instances   = map (appSnd3 (map (concat o (print False)))) $
		        map (appThd3 (map loc)) $ getTypeInstances t db
338 339
		    , type_derivations = map (appSnd (map loc)) $ getTypeDerivations t db
		    }
Camil Staps's avatar
Camil Staps committed
340
		  )
341
	makeTypeResult mbName (Builtin t) td db
Camil Staps's avatar
Camil Staps committed
342 343 344
		= TypeResult
		  ( { library  = ""
		    , filename = ""
Camil Staps's avatar
Camil Staps committed
345
		    , dcl_line = Nothing
346
		    , icl_line = Nothing
Camil Staps's avatar
Camil Staps committed
347 348 349 350
		    , modul    = ""
		    , distance
		        = if (isNothing mbName) -100 (levenshtein` t (fromJust mbName))
		    , builtin  = Just True
Camil Staps's avatar
Camil Staps committed
351
		    }
352
		  , { type             = concat $ print False td
353 354
		    , type_instances   = map (appSnd3 (map (concat o (print False)))) $
		        map (appThd3 (map loc)) $ getTypeInstances t db
355 356
		    , type_derivations = map (appSnd (map loc)) $ getTypeDerivations t db
		    }
Camil Staps's avatar
Camil Staps committed
357 358
		  )

359
	makeMacroResult :: (Maybe String) Location Macro -> Result
360
	makeMacroResult mbName (Location lib mod line iclline m) mac
Camil Staps's avatar
Camil Staps committed
361 362 363
		= MacroResult
		  ( { library  = lib
		    , filename = modToFilename mod
Camil Staps's avatar
Camil Staps committed
364
		    , dcl_line = line
365
		    , icl_line = iclline
Camil Staps's avatar
Camil Staps committed
366 367
		    , modul    = mod
		    , distance
Camil Staps's avatar
Camil Staps committed
368
		        = if (isNothing mbName) -100 (levenshtein` (fromJust mbName) m)
Camil Staps's avatar
Camil Staps committed
369
		    , builtin  = Nothing
Camil Staps's avatar
Camil Staps committed
370 371 372 373 374 375
		    }
		  , { macro_name = m
		    , macro_representation = mac.macro_as_string
		    }
		  )

Camil Staps's avatar
Camil Staps committed
376
	makeFunctionResult :: (Maybe String) (Maybe Type) (Maybe ShortClassResult)
377
		(Location, ExtendedType) TypeDB -> Result
Camil Staps's avatar
Camil Staps committed
378
	makeFunctionResult
Camil Staps's avatar
Camil Staps committed
379
		orgsearch orgsearchtype mbCls (fl, et=:(ET type tes)) db
Camil Staps's avatar
Camil Staps committed
380 381
		= FunctionResult
		  ( { library  = lib
Camil Staps's avatar
Camil Staps committed
382
		    , filename = modToFilename mod
Camil Staps's avatar
Camil Staps committed
383
		    , dcl_line = line
384
		    , icl_line = iclline
Camil Staps's avatar
Camil Staps committed
385 386
		    , modul    = mod
		    , distance = distance
Camil Staps's avatar
Camil Staps committed
387
		    , builtin  = builtin
Camil Staps's avatar
Camil Staps committed
388
		    }
389 390
		  , { func     = fromJust (tes.te_representation <|>
		                           (pure $ concat $ print False (fname,et)))
391 392
		    , unifier  = toStrUnifier <$> finish_unification <$>
		        (orgsearchtype >>= unify [] (prepare_unification False type))
Camil Staps's avatar
Camil Staps committed
393
		    , cls      = mbCls
394
		    , constructor_of = if tes.te_isconstructor
Camil Staps's avatar
Camil Staps committed
395 396
		        (let (Func _ r _) = type in Just $ concat $ print False r)
		        Nothing
397
		    , recordfield_of = if tes.te_isrecordfield
Camil Staps's avatar
Camil Staps committed
398 399
		        (let (Func [t:_] _ _) = type in Just $ concat $ print False t)
		        Nothing
400 401
		    , generic_derivations
		        = let derivs = getDerivations fname db in
Camil Staps's avatar
Camil Staps committed
402 403
		          const (sortBy (\(a,_) (b,_) -> a < b)
				    [(concat $ print False d, map loc ls) \\ (d,ls) <- derivs]) <$>
Camil Staps's avatar
Camil Staps committed
404
		          tes.te_generic_vars
Camil Staps's avatar
Camil Staps committed
405 406
		    }
		  )
Camil Staps's avatar
Camil Staps committed
407
	where
408 409 410
		(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
411

412 413
		toStrUnifier :: Unifier -> StrUnifier
		toStrUnifier (tvas1, tvas2) = (map toStr tvas1, map toStr tvas2)
414
		where toStr (var, type) = (var, concat $ print False type)
415

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

Camil Staps's avatar
Camil Staps committed
419
		distance
Camil Staps's avatar
Camil Staps committed
420
			| isNothing orgsearch || fromJust orgsearch == ""
Camil Staps's avatar
Camil Staps committed
421 422
				| isNothing orgsearchtype = 0
				# orgsearchtype = fromJust orgsearchtype
423 424
				# (Just (ass1, ass2)) = finish_unification <$>
					unify [] orgsearchtype (prepare_unification False type)
425
				= penalty + toInt (sum [typeComplexity t \\ (_,t)<-ass1 ++ ass2 | not (isVar t)])
426
			# orgsearch = fromJust orgsearch
427
			= penalty + levenshtein` orgsearch fname
428
		where
429 430 431 432 433
			penalty
			| tes.te_isrecordfield = 2
			| tes.te_isconstructor = 1
			| otherwise            = 0

434 435 436 437 438 439
			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
440

Camil Staps's avatar
Camil Staps committed
441
	levenshtein` :: String String -> Int
Camil Staps's avatar
Camil Staps committed
442
	levenshtein` a b = if (indexOf a b == -1) 0 -100 + levenshtein [c \\ c <-: a] [c \\ c <-: b]
Camil Staps's avatar
Camil Staps committed
443

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

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

451 452 453
	isNameMatch :: !Int !String Location -> Bool
	isNameMatch maxdist n1 loc
		# (n1, n2) = ({toLower c \\ c <-: n1}, {toLower c \\ c <-: getName loc})
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
	isModMatch :: ![String] Location -> Bool
457 458
	isModMatch mods (Location _ mod _ _ _) = isMember mod mods
	isModMatch _    (Builtin _)            = False
Camil Staps's avatar
Camil Staps committed
459

460
	isLibMatch :: (![String], !Bool) Location -> Bool
461 462
	isLibMatch (libs,_) (Location lib _ _ _ _) = any (\l -> indexOf l lib == 0) libs
	isLibMatch (_,blti) (Builtin _)            = blti
Camil Staps's avatar
Camil Staps committed
463

464
	loc :: Location -> LocationResult
465
	loc (Location lib mod ln iln _) = (lib, mod, ln, iln)
Camil Staps's avatar
Camil Staps committed
466

Camil Staps's avatar
Camil Staps committed
467
	log :: (LogMessage (Maybe Request) Response CacheKey) IPAddress *World
468
		-> *(IPAddress, *World)
Camil Staps's avatar
Camil Staps committed
469
	log msg s w
Camil Staps's avatar
Camil Staps committed
470 471
	| not needslog = (newS msg s, w)
	# (tm,w) = localTime w
Camil Staps's avatar
Camil Staps committed
472
	# (io,w) = stdio w
Camil Staps's avatar
Camil Staps committed
473
	# io = io <<< trim (toString tm) <<< " " <<< msgToString msg s
Camil Staps's avatar
Camil Staps committed
474
	= (newS msg s, snd (fclose io w))
Camil Staps's avatar
Camil Staps committed
475
	where
Camil Staps's avatar
Camil Staps committed
476
		needslog = case msg of (Received _) = True; (Sent _ _) = True; _ = False
Camil Staps's avatar
Camil Staps committed
477

Camil Staps's avatar
Camil Staps committed
478
	newS :: (LogMessage (Maybe Request) Response CacheKey) IPAddress -> IPAddress
Camil Staps's avatar
Camil Staps committed
479 480
	newS m s = case m of (Connected ip) = ip; _ = s

Camil Staps's avatar
Camil Staps committed
481
	msgToString :: (LogMessage (Maybe Request) Response CacheKey) IPAddress -> String
Camil Staps's avatar
Camil Staps committed
482
	msgToString (Received Nothing) ip
483
		= toString ip + " <-- Nothing\n"
Camil Staps's avatar
Camil Staps committed
484
	msgToString (Received (Just a)) ip
485
		= toString ip + " <-- " + toString a + "\n"
Camil Staps's avatar
Camil Staps committed
486
	msgToString (Sent {return,data,msg,more_available} ck) ip
487
		= toString ip + " --> " + toString (length data)
Camil Staps's avatar
Camil Staps committed
488 489 490
			+ " results (" + toString return + "; " + msg
			+ if (isJust more_available) ("; " + toString (fromJust more_available) + " more") ""
			+ "; cache: " + ck + ")\n"
Camil Staps's avatar
Camil Staps committed
491
	msgToString _ _ = ""