CloogleServer.icl 15.6 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
Mart Lubbers's avatar
Mart Lubbers committed
11 12
import Data.List
import Data.Tuple
13 14 15 16 17
import Data.Maybe
import System.CommandLine
import Text.JSON
import Data.Functor
import Control.Applicative
18
import Control.Monad
19
import Data.Error
Camil Staps's avatar
Camil Staps committed
20
from Text import class Text(concat,trim,indexOf,toLowerCase),
21
	instance Text String, instance + String
Camil Staps's avatar
Camil Staps committed
22 23

import System.Time
Mart Lubbers's avatar
Mart Lubbers committed
24 25 26
import System.FilePath
import System.File
import Crypto.Hash.MD5
27

28 29
from SimpleTCPServer import :: LogMessage{..}, serve, :: Logger
import qualified SimpleTCPServer
30 31 32
import TypeDB
import Type

Mart Lubbers's avatar
Mart Lubbers committed
33 34
CACHEPATH :== "./cache"

Camil Staps's avatar
Camil Staps committed
35 36 37
:: Request = { unify     :: Maybe String
             , name      :: Maybe String
             , className :: Maybe String
Camil Staps's avatar
Camil Staps committed
38
             , typeName  :: Maybe String
Camil Staps's avatar
Camil Staps committed
39
             , modules   :: Maybe [String]
40
             , libraries :: Maybe ([String], Bool)
Camil Staps's avatar
Camil Staps committed
41
             , page      :: Maybe Int
42 43
             }

Camil Staps's avatar
Camil Staps committed
44 45 46
:: Response = { return         :: Int
              , data           :: [Result]
              , msg            :: String
Camil Staps's avatar
Camil Staps committed
47
              , more_available :: Maybe Int
48
              , suggestions    :: Maybe [(Request, Int)]
49 50
              }

Camil Staps's avatar
Camil Staps committed
51
:: Result = FunctionResult FunctionResult
Camil Staps's avatar
Camil Staps committed
52
          | TypeResult TypeResult
Camil Staps's avatar
Camil Staps committed
53
          | ClassResult ClassResult
Camil Staps's avatar
Camil Staps committed
54
          | MacroResult MacroResult
Camil Staps's avatar
Camil Staps committed
55 56 57 58

:: BasicResult = { library  :: String
                 , filename :: String
                 , modul    :: String
Camil Staps's avatar
Camil Staps committed
59
                 , dcl_line :: Maybe Int
Camil Staps's avatar
Camil Staps committed
60
                 , distance :: Int
Camil Staps's avatar
Camil Staps committed
61
                 , builtin  :: Maybe Bool
Camil Staps's avatar
Camil Staps committed
62 63
                 }

Camil Staps's avatar
Camil Staps committed
64
:: FunctionResult :== (BasicResult, FunctionResultExtras)
Camil Staps's avatar
Camil Staps committed
65 66 67 68 69
:: FunctionResultExtras = { func                :: String
                          , unifier             :: Maybe StrUnifier
                          , cls                 :: Maybe ShortClassResult
                          , constructor_of      :: Maybe String
                          , recordfield_of      :: Maybe String
Camil Staps's avatar
Camil Staps committed
70
                          , generic_derivations :: Maybe [(String, [(String,String,Maybe Int)])]
Camil Staps's avatar
Camil Staps committed
71 72 73 74 75
                          }

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

Camil Staps's avatar
Camil Staps committed
77
:: ClassResult :== (BasicResult, ClassResultExtras)
78 79 80
:: ClassResultExtras = { class_name      :: String
                       , class_heading   :: String
                       , class_funs      :: [String]
Camil Staps's avatar
Camil Staps committed
81
                       , class_instances :: [(String, [(String,String,Maybe Int)])]
Camil Staps's avatar
Camil Staps committed
82 83
                       }

Camil Staps's avatar
Camil Staps committed
84
:: MacroResult :== (BasicResult, MacroResultExtras)
85
:: MacroResultExtras = { macro_name           :: String
Camil Staps's avatar
Camil Staps committed
86 87 88
                       , macro_representation :: String
                       }

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

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

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

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

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

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

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

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

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

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

140
MAX_RESULTS    :== 15
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

159
	handle :: !TypeDB !(Maybe Request) !*World -> *(!Response, !*World)
Camil Staps's avatar
Camil Staps committed
160
	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
Mart Lubbers's avatar
Mart Lubbers committed
162 163 164
		# cachefile = CACHEPATH </> (md5 $ toString request)
		# (mr, w) = readCache cachefile w
		| isJust mr = (fromJust mr, w)
165
		| isJust name && size (fromJust name) > 40
Camil Staps's avatar
Camil Staps committed
166 167 168
			= (err E_INVALIDNAME "function name too long", w)
		| isJust name && any isSpace (fromString $ fromJust name)
			= (err E_INVALIDNAME "name cannot contain spaces", w)
Camil Staps's avatar
Camil Staps committed
169 170
		| isJust unify && isNothing (parseType $ fromString $ fromJust unify)
			= (err E_INVALIDTYPE "couldn't parse type", w)
Camil Staps's avatar
Camil Staps committed
171 172
		// Results
		# drop_n = fromJust (page <|> pure 0) * MAX_RESULTS
Camil Staps's avatar
oops  
Camil Staps committed
173
		# results = drop drop_n $ sort $ search request db
Camil Staps's avatar
Camil Staps committed
174 175
		# more = max 0 (length results - MAX_RESULTS)
		// Suggestions
176
		# mbType = unify >>= parseType o fromString
Camil Staps's avatar
Camil Staps committed
177
		# suggestions
178 179
			= sortBy (\a b -> snd a > snd b) <$>
			  filter ((<)(length results) o snd) <$>
180 181
			  (mbType >>= \t -> suggs name t db)
		# results = take MAX_RESULTS results
Camil Staps's avatar
Camil Staps committed
182 183
		// Response
		| isEmpty results = (err E_NORESULTS "No results", w)
184
		// Save cache file
Mart Lubbers's avatar
Mart Lubbers committed
185
		= writeCache cachefile { return = 0
Camil Staps's avatar
Camil Staps committed
186 187 188 189
		    , msg = "Success"
		    , data           = results
		    , more_available = Just more
		    , suggestions    = suggestions
Mart Lubbers's avatar
Mart Lubbers committed
190 191 192 193 194
		    } w

	readCache :: !String !*World -> (Maybe Response, !*World)
	readCache fp w
	= case readFile fp w of
195
		(Error _, w) = (Nothing, w)
Mart Lubbers's avatar
Mart Lubbers committed
196
		(Ok s, w) = case fromJSON $ fromString s of
197 198
			Nothing = (Nothing, w)
			(Just r) = (Just {r & return=1, msg="Success, cache hit"}, w)
Mart Lubbers's avatar
Mart Lubbers committed
199 200

	writeCache :: !String !Response !*World -> (!Response, !*World)
201
	writeCache fp r w = appFst (const r) (writeFile fp (toString $ toJSON r) w)
Camil Staps's avatar
Camil Staps committed
202

203
	suggs :: !(Maybe String) !Type !TypeDB -> Maybe [(Request, Int)]
204
	suggs n (Func is r cc) db
205 206
		| length is < 3
			= Just [let t` = concat $ print False $ Func is` r cc in
207 208
			        let request = {zero & name=n, unify=Just t`} in
			        (request, length $ search request db)
209
			        \\ is` <- permutations is | is` <> is]
210
	suggs _ _ _ = Nothing
Camil Staps's avatar
Camil Staps committed
211

212
	search :: !Request !TypeDB -> [Result]
Camil Staps's avatar
Camil Staps committed
213 214 215 216
	search {unify,name,className,typeName,modules,libraries,page} db
		# db = case libraries of
			(Just ls) = filterLocations (isLibMatch ls) db
			Nothing   = db
217 218 219
		# db = case modules of
			(Just ms) = filterLocations (isModMatch ms) db
			Nothing   = db
Camil Staps's avatar
Camil Staps committed
220 221 222 223
		| isJust className
			# className = fromJust className
			# classes = findClass className db
			= map (flip makeClassResult db) classes
Camil Staps's avatar
Camil Staps committed
224 225 226 227
		| isJust typeName
			# typeName = fromJust typeName
			# types = findType typeName db
			= map (uncurry (makeTypeResult (Just typeName))) types
228
		# mbType = prepare_unification True <$> (unify >>= parseType o fromString)
Camil Staps's avatar
Camil Staps committed
229
		// Search normal functions
230
		# filts = catMaybes [ (\t _ -> isUnifiable t) <$> mbType
231
		                    , (\n loc _ -> isNameMatch (size n*2/3) n loc) <$> name
232
		                    ]
233
		# funs = map (\f -> makeFunctionResult name mbType Nothing f db) $ findFunction`` filts db
Camil Staps's avatar
Camil Staps committed
234
		// Search macros
235
		# macros = case (isNothing mbType,name) of
236
			(True,Just n) = findMacro` (\loc _ -> isNameMatch (size n*2/3) n loc) db
237
			_             = []
Camil Staps's avatar
Camil Staps committed
238
		# macros = map (\(lhs,rhs) -> makeMacroResult name lhs rhs) macros
Camil Staps's avatar
Camil Staps committed
239
		// Search class members
Camil Staps's avatar
Camil Staps committed
240
		# filts = catMaybes [ (\t _ _ _ _->isUnifiable t) <$> mbType
241
		                    , (\n (Location lib mod _ _) _ _ f _ -> isNameMatch
242
		                      (size n*2/3) n (Location lib mod Nothing f)) <$> name
243
		                    ]
Camil Staps's avatar
Camil Staps committed
244
		# members = findClassMembers`` filts db
245 246
		# members = map (\(Location lib mod line cls,vs,_,f,et) -> makeFunctionResult name mbType
			(Just {cls_name=cls,cls_vars=vs}) (Location lib mod line f,et) db) members
Camil Staps's avatar
Camil Staps committed
247
		// Search types
248
		# lcName = if (isJust mbType && isType (fromJust mbType))
Camil Staps's avatar
Camil Staps committed
249 250
			(let (Type name _) = fromJust mbType in Just $ toLowerCase name)
			(toLowerCase <$> name)
251 252 253
		# types = case (isNothing mbType,lcName) of
			(True,Just n) = findType` (\loc _ -> toLowerCase (getName loc) == n) db
			_             = []
Camil Staps's avatar
Camil Staps committed
254
		# types = map (\(tl,td) -> makeTypeResult name tl td) types
255 256
		// Search classes
		# classes = case (isNothing mbType, toLowerCase <$> name) of
257
			(True, Just c) = findClass` (\(Location _ _ _ c`) _ _ _ -> toLowerCase c` == c) db
Camil Staps's avatar
Camil Staps committed
258 259
			_              = []
		# classes = map (flip makeClassResult db) classes
Camil Staps's avatar
Camil Staps committed
260
		// Merge results
Camil Staps's avatar
Camil Staps committed
261
		= sort $ funs ++ members ++ types ++ classes ++ macros
Camil Staps's avatar
Camil Staps committed
262

263
	makeClassResult :: (Location, [TypeVar], ClassContext, [(Name,ExtendedType)])
Camil Staps's avatar
Camil Staps committed
264
		TypeDB -> Result
265
	makeClassResult (Location lib mod line cls, vars, cc, funs) db
Camil Staps's avatar
Camil Staps committed
266 267 268
		= ClassResult
		  ( { library  = lib
		    , filename = modToFilename mod
Camil Staps's avatar
Camil Staps committed
269
		    , dcl_line = line
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 274
		    }
		  , { class_name = cls
275
		    , class_heading = foldl ((+) o (flip (+) " ")) cls vars +
Camil Staps's avatar
Camil Staps committed
276
		        if (isEmpty cc) "" " " + concat (print False cc)
277
		    , class_funs = [print_fun fun \\ fun <- funs]
Camil Staps's avatar
Camil Staps committed
278
		    , class_instances
Camil Staps's avatar
Camil Staps committed
279 280
		        = sortBy (\(a,_) (b,_) -> a < b)
		            [(concat (print False t), map loc ls) \\ (t,ls) <- getInstances cls db]
Camil Staps's avatar
Camil Staps committed
281 282
		    }
		  )
283 284 285 286
	where
		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
287

288 289
	makeTypeResult :: (Maybe String) Location TypeDef -> Result
	makeTypeResult mbName (Location lib mod line t) td
Camil Staps's avatar
Camil Staps committed
290 291 292
		= TypeResult
		  ( { library  = lib
		    , filename = modToFilename mod
Camil Staps's avatar
Camil Staps committed
293
		    , dcl_line = line
Camil Staps's avatar
Camil Staps committed
294
		    , modul    = mod
Camil Staps's avatar
Camil Staps committed
295
		    , distance
296
		        = if (isNothing mbName) -100 (levenshtein` t (fromJust mbName))
Camil Staps's avatar
Camil Staps committed
297 298 299 300
		    , builtin  = Nothing
		    }
		  , { type = concat $ print False td }
		  )
301
	makeTypeResult mbName (Builtin t) td
Camil Staps's avatar
Camil Staps committed
302 303 304
		= TypeResult
		  ( { library  = ""
		    , filename = ""
Camil Staps's avatar
Camil Staps committed
305
		    , dcl_line = Nothing
Camil Staps's avatar
Camil Staps committed
306 307 308 309
		    , modul    = ""
		    , distance
		        = if (isNothing mbName) -100 (levenshtein` t (fromJust mbName))
		    , builtin  = Just True
Camil Staps's avatar
Camil Staps committed
310
		    }
311
		  , { type = concat $ print False td }
Camil Staps's avatar
Camil Staps committed
312 313
		  )

314 315
	makeMacroResult :: (Maybe String) Location Macro -> Result
	makeMacroResult mbName (Location lib mod line m) mac
Camil Staps's avatar
Camil Staps committed
316 317 318
		= MacroResult
		  ( { library  = lib
		    , filename = modToFilename mod
Camil Staps's avatar
Camil Staps committed
319
		    , dcl_line = line
Camil Staps's avatar
Camil Staps committed
320 321
		    , modul    = mod
		    , distance
Camil Staps's avatar
Camil Staps committed
322
		        = if (isNothing mbName) -100 (levenshtein` (fromJust mbName) m)
Camil Staps's avatar
Camil Staps committed
323
		    , builtin  = Nothing
Camil Staps's avatar
Camil Staps committed
324 325 326 327 328 329
		    }
		  , { macro_name = m
		    , macro_representation = mac.macro_as_string
		    }
		  )

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

365 366
		toStrUnifier :: Unifier -> StrUnifier
		toStrUnifier (tvas1, tvas2) = (map toStr tvas1, map toStr tvas2)
367
		where toStr (var, type) = (var, concat $ print False type)
368

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

Camil Staps's avatar
Camil Staps committed
372
		distance
Camil Staps's avatar
Camil Staps committed
373
			| isNothing orgsearch || fromJust orgsearch == ""
Camil Staps's avatar
Camil Staps committed
374 375
				| isNothing orgsearchtype = 0
				# orgsearchtype = fromJust orgsearchtype
376 377
				# (Just (ass1, ass2)) = finish_unification <$>
					unify [] orgsearchtype (prepare_unification False type)
378
				= penalty + toInt (sum [typeComplexity t \\ (_,t)<-ass1 ++ ass2 | not (isVar t)])
379
			# orgsearch = fromJust orgsearch
380
			= penalty + levenshtein` orgsearch fname
381
		where
382 383 384 385 386
			penalty
			| tes.te_isrecordfield = 2
			| tes.te_isconstructor = 1
			| otherwise            = 0

387 388 389 390 391 392
			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
393

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

Camil Staps's avatar
Camil Staps committed
397 398
	modToFilename :: String -> String
	modToFilename mod = (toString $ reverse $ takeWhile ((<>)'.')
399
	                              $ reverse $ fromString mod) + ".dcl"
Camil Staps's avatar
Camil Staps committed
400

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

404 405 406
	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
407
		= n1 == "" || indexOf n1 n2 <> -1 || levenshtein [c \\ c <-: n1] [c \\ c <-: n2] <= maxdist
Camil Staps's avatar
Camil Staps committed
408

409 410
	isModMatch :: ![String] Location -> Bool
	isModMatch mods (Location _ mod _ _) = isMember mod mods
Camil Staps's avatar
Camil Staps committed
411
	isModMatch _    (Builtin _)          = False
Camil Staps's avatar
Camil Staps committed
412

413
	isLibMatch :: (![String], !Bool) Location -> Bool
414
	isLibMatch (libs,_) (Location lib _ _ _) = any (\l -> indexOf l lib == 0) libs
415
	isLibMatch (_,blti) (Builtin _)          = blti
Camil Staps's avatar
Camil Staps committed
416

Camil Staps's avatar
Camil Staps committed
417 418 419
	loc :: Location -> (String, String, Maybe Int)
	loc (Location lib mod ln _) = (lib, mod, ln)

Camil Staps's avatar
Camil Staps committed
420
	log :: (LogMessage (Maybe Request) Response) IPAddress *World
421
		-> *(IPAddress, *World)
Camil Staps's avatar
Camil Staps committed
422
	log msg s w
Camil Staps's avatar
Camil Staps committed
423 424
	| not needslog = (newS msg s, w)
	# (tm,w) = localTime w
Camil Staps's avatar
Camil Staps committed
425
	# (io,w) = stdio w
Camil Staps's avatar
Camil Staps committed
426
	# io = io <<< trim (toString tm) <<< " " <<< msgToString msg s
Camil Staps's avatar
Camil Staps committed
427
	= (newS msg s, snd (fclose io w))
Camil Staps's avatar
Camil Staps committed
428 429
	where
		needslog = case msg of (Received _) = True; (Sent _) = True; _ = False
Camil Staps's avatar
Camil Staps committed
430

Camil Staps's avatar
Camil Staps committed
431
	newS :: (LogMessage (Maybe Request) Response) IPAddress -> IPAddress
Camil Staps's avatar
Camil Staps committed
432 433
	newS m s = case m of (Connected ip) = ip; _ = s

Camil Staps's avatar
Camil Staps committed
434
	msgToString :: (LogMessage (Maybe Request) Response) IPAddress -> String
Camil Staps's avatar
Camil Staps committed
435
	msgToString (Received Nothing) ip
436
		= toString ip + " <-- Nothing\n"
Camil Staps's avatar
Camil Staps committed
437
	msgToString (Received (Just a)) ip
438
		= toString ip + " <-- " + toString a + "\n"
Camil Staps's avatar
Camil Staps committed
439
	msgToString (Sent {return,data,msg,more_available}) ip
440 441 442
		= toString ip + " --> " + toString (length data)
			+ " results (" + toString return + "; " + msg +
			if (isJust more_available) ("; " + toString (fromJust more_available) + " more") "" + ")\n"
Camil Staps's avatar
Camil Staps committed
443
	msgToString _ _ = ""