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

import System.Time
21

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

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

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

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

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

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

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

Camil Staps's avatar
Camil Staps committed
70
:: ClassResult :== (BasicResult, ClassResultExtras)
71 72 73
:: ClassResultExtras = { class_name      :: String
                       , class_heading   :: String
                       , class_funs      :: [String]
Camil Staps's avatar
Camil Staps committed
74
                       , class_instances :: [(String, [(String,String,Maybe Int)])]
Camil Staps's avatar
Camil Staps committed
75 76
                       }

Camil Staps's avatar
Camil Staps committed
77
:: MacroResult :== (BasicResult, MacroResultExtras)
78
:: MacroResultExtras = { macro_name           :: String
Camil Staps's avatar
Camil Staps committed
79 80 81
                       , macro_representation :: String
                       }

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

Mart Lubbers's avatar
Mart Lubbers committed
84
:: ErrorResult = MaybeError Int String
Camil Staps's avatar
Camil Staps committed
85

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

Camil Staps's avatar
Camil Staps committed
88
derive JSONEncode Request, Response, Result, ShortClassResult, BasicResult,
Camil Staps's avatar
Camil Staps committed
89
	FunctionResultExtras, TypeResultExtras, ClassResultExtras, MacroResultExtras
Camil Staps's avatar
Camil Staps committed
90
derive JSONDecode Request, Response, Result, ShortClassResult, BasicResult,
Camil Staps's avatar
Camil Staps committed
91
	FunctionResultExtras, TypeResultExtras, ClassResultExtras, MacroResultExtras
92

Camil Staps's avatar
Camil Staps committed
93 94
instance zero Request
where
Camil Staps's avatar
Camil Staps committed
95 96 97
	zero = { unify     = Nothing
	       , name      = Nothing
	       , className = Nothing
Camil Staps's avatar
Camil Staps committed
98
	       , typeName  = Nothing
Camil Staps's avatar
Camil Staps committed
99
	       , modules   = Nothing
Camil Staps's avatar
Camil Staps committed
100
	       , libraries = Nothing
Camil Staps's avatar
Camil Staps committed
101
	       , page      = Nothing
Camil Staps's avatar
Camil Staps committed
102 103
	       }

104
instance toString Response where toString r = toString (toJSON r) + "\n"
Camil Staps's avatar
Camil Staps committed
105
instance toString Request where toString r = toString $ toJSON r
106

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

Camil Staps's avatar
Camil Staps committed
109 110 111 112 113 114 115
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
116 117 118
		basic (TypeResult     (br,_)) = br
		basic (ClassResult    (br,_)) = br
		basic (MacroResult    (br,_)) = br
119 120

err :: Int String -> Response
Camil Staps's avatar
Camil Staps committed
121 122 123 124 125 126
err c m = { return         = c
          , data           = []
          , msg            = m
          , more_available = Nothing
          , suggestions    = Nothing
          }
127

128
E_NORESULTS    :== 127
Camil Staps's avatar
Camil Staps committed
129
E_INVALIDINPUT :== 128
130 131
E_INVALIDNAME  :== 129
E_INVALIDTYPE  :== 130
Camil Staps's avatar
Camil Staps committed
132

133
MAX_RESULTS    :== 15
134

135 136 137 138 139 140 141 142 143
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"
144
#! db = fromJust db
Camil Staps's avatar
Camil Staps committed
145
= serve (handle db) (Just log) port w
146
where
Camil Staps's avatar
Camil Staps committed
147 148 149 150 151
	help :: *File *World -> *World
	help io w
	# io = io <<< "Usage: ./CloogleServer <port>\n"
	= snd $ fclose io w

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

192
	suggs :: !(Maybe String) !Type !TypeDB -> Maybe [(Request, Int)]
193
	suggs n (Func is r cc) db
194 195
		| length is < 3
			= Just [let t` = concat $ print False $ Func is` r cc in
196 197
			        let request = {zero & name=n, unify=Just t`} in
			        (request, length $ search request db)
198
			        \\ is` <- permutations is | is` <> is]
199
	suggs _ _ _ = Nothing
Camil Staps's avatar
Camil Staps committed
200

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

252
	makeClassResult :: (Location, [TypeVar], ClassContext, [(Name,ExtendedType)])
Camil Staps's avatar
Camil Staps committed
253
		TypeDB -> Result
254
	makeClassResult (Location lib mod line cls, vars, cc, funs) db
Camil Staps's avatar
Camil Staps committed
255 256 257
		= ClassResult
		  ( { library  = lib
		    , filename = modToFilename mod
Camil Staps's avatar
Camil Staps committed
258
		    , dcl_line = line
Camil Staps's avatar
Camil Staps committed
259
		    , modul    = mod
260
		    , distance = -100
Camil Staps's avatar
Camil Staps committed
261
		    , builtin  = Nothing
Camil Staps's avatar
Camil Staps committed
262 263
		    }
		  , { class_name = cls
264
		    , class_heading = foldl ((+) o (flip (+) " ")) cls vars +
Camil Staps's avatar
Camil Staps committed
265
		        if (isEmpty cc) "" " " + concat (print False cc)
266
		    , class_funs = [print_fun fun \\ fun <- funs]
Camil Staps's avatar
Camil Staps committed
267
		    , class_instances
Camil Staps's avatar
Camil Staps committed
268 269
		        = sortBy (\(a,_) (b,_) -> a < b)
		            [(concat (print False t), map loc ls) \\ (t,ls) <- getInstances cls db]
Camil Staps's avatar
Camil Staps committed
270 271
		    }
		  )
272 273 274 275
	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
276

277 278
	makeTypeResult :: (Maybe String) Location TypeDef -> Result
	makeTypeResult mbName (Location lib mod line t) td
Camil Staps's avatar
Camil Staps committed
279 280 281
		= TypeResult
		  ( { library  = lib
		    , filename = modToFilename mod
Camil Staps's avatar
Camil Staps committed
282
		    , dcl_line = line
Camil Staps's avatar
Camil Staps committed
283
		    , modul    = mod
Camil Staps's avatar
Camil Staps committed
284
		    , distance
285
		        = if (isNothing mbName) -100 (levenshtein` t (fromJust mbName))
Camil Staps's avatar
Camil Staps committed
286 287 288 289
		    , builtin  = Nothing
		    }
		  , { type = concat $ print False td }
		  )
290
	makeTypeResult mbName (Builtin t) td
Camil Staps's avatar
Camil Staps committed
291 292 293
		= TypeResult
		  ( { library  = ""
		    , filename = ""
Camil Staps's avatar
Camil Staps committed
294
		    , dcl_line = Nothing
Camil Staps's avatar
Camil Staps committed
295 296 297 298
		    , modul    = ""
		    , distance
		        = if (isNothing mbName) -100 (levenshtein` t (fromJust mbName))
		    , builtin  = Just True
Camil Staps's avatar
Camil Staps committed
299
		    }
300
		  , { type = concat $ print False td }
Camil Staps's avatar
Camil Staps committed
301 302
		  )

303 304
	makeMacroResult :: (Maybe String) Location Macro -> Result
	makeMacroResult mbName (Location lib mod line m) mac
Camil Staps's avatar
Camil Staps committed
305 306 307
		= MacroResult
		  ( { library  = lib
		    , filename = modToFilename mod
Camil Staps's avatar
Camil Staps committed
308
		    , dcl_line = line
Camil Staps's avatar
Camil Staps committed
309 310
		    , modul    = mod
		    , distance
Camil Staps's avatar
Camil Staps committed
311
		        = if (isNothing mbName) -100 (levenshtein` (fromJust mbName) m)
Camil Staps's avatar
Camil Staps committed
312
		    , builtin  = Nothing
Camil Staps's avatar
Camil Staps committed
313 314 315 316 317 318
		    }
		  , { macro_name = m
		    , macro_representation = mac.macro_as_string
		    }
		  )

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

354 355
		toStrUnifier :: Unifier -> StrUnifier
		toStrUnifier (tvas1, tvas2) = (map toStr tvas1, map toStr tvas2)
356
		where toStr (var, type) = (var, concat $ print False type)
357

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

Camil Staps's avatar
Camil Staps committed
361
		distance
Camil Staps's avatar
Camil Staps committed
362
			| isNothing orgsearch || fromJust orgsearch == ""
Camil Staps's avatar
Camil Staps committed
363 364
				| isNothing orgsearchtype = 0
				# orgsearchtype = fromJust orgsearchtype
365 366
				# (Just (ass1, ass2)) = finish_unification <$>
					unify [] orgsearchtype (prepare_unification False type)
367
				= penalty + toInt (sum [typeComplexity t \\ (_,t)<-ass1 ++ ass2 | not (isVar t)])
368
			# orgsearch = fromJust orgsearch
369
			= penalty + levenshtein` orgsearch fname
370
		where
371 372 373 374 375
			penalty
			| tes.te_isrecordfield = 2
			| tes.te_isconstructor = 1
			| otherwise            = 0

376 377 378 379 380 381
			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
382

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

Camil Staps's avatar
Camil Staps committed
386 387
	modToFilename :: String -> String
	modToFilename mod = (toString $ reverse $ takeWhile ((<>)'.')
388
	                              $ reverse $ fromString mod) + ".dcl"
Camil Staps's avatar
Camil Staps committed
389

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

393 394 395
	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
396
		= n1 == "" || indexOf n1 n2 <> -1 || levenshtein [c \\ c <-: n1] [c \\ c <-: n2] <= maxdist
Camil Staps's avatar
Camil Staps committed
397

398 399
	isModMatch :: ![String] Location -> Bool
	isModMatch mods (Location _ mod _ _) = isMember mod mods
Camil Staps's avatar
Camil Staps committed
400
	isModMatch _    (Builtin _)          = False
Camil Staps's avatar
Camil Staps committed
401

402
	isLibMatch :: (![String], !Bool) Location -> Bool
403
	isLibMatch (libs,_) (Location lib _ _ _) = any (\l -> indexOf l lib == 0) libs
404
	isLibMatch (_,blti) (Builtin _)          = blti
Camil Staps's avatar
Camil Staps committed
405

Camil Staps's avatar
Camil Staps committed
406 407 408
	loc :: Location -> (String, String, Maybe Int)
	loc (Location lib mod ln _) = (lib, mod, ln)

Camil Staps's avatar
Camil Staps committed
409
	log :: (LogMessage (Maybe Request) Response) IPAddress *World
410
		-> *(IPAddress, *World)
Camil Staps's avatar
Camil Staps committed
411
	log msg s w
Camil Staps's avatar
Camil Staps committed
412 413
	| not needslog = (newS msg s, w)
	# (tm,w) = localTime w
Camil Staps's avatar
Camil Staps committed
414
	# (io,w) = stdio w
Camil Staps's avatar
Camil Staps committed
415
	# io = io <<< trim (toString tm) <<< " " <<< msgToString msg s
Camil Staps's avatar
Camil Staps committed
416
	= (newS msg s, snd (fclose io w))
Camil Staps's avatar
Camil Staps committed
417 418
	where
		needslog = case msg of (Received _) = True; (Sent _) = True; _ = False
Camil Staps's avatar
Camil Staps committed
419

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

Camil Staps's avatar
Camil Staps committed
423
	msgToString :: (LogMessage (Maybe Request) Response) IPAddress -> String
Camil Staps's avatar
Camil Staps committed
424
	msgToString (Received Nothing) ip
425
		= toString ip + " <-- Nothing\n"
Camil Staps's avatar
Camil Staps committed
426
	msgToString (Received (Just a)) ip
427
		= toString ip + " <-- " + toString a + "\n"
Camil Staps's avatar
Camil Staps committed
428
	msgToString (Sent {return,data,msg,more_available}) ip
429 430 431
		= 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
432
	msgToString _ _ = ""