CloogleServer.icl 15.1 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 156 157
		//Check cache
		# (mr, w) = readCache request w
		| isJust mr = let m = fromJust mr in ({m & return = 1}, w)
158
		| isJust name && size (fromJust name) > 40
Camil Staps's avatar
Camil Staps committed
159 160 161
			= (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
162 163
		| isJust unify && isNothing (parseType $ fromString $ fromJust unify)
			= (err E_INVALIDTYPE "couldn't parse type", w)
Camil Staps's avatar
Camil Staps committed
164 165
		// Results
		# drop_n = fromJust (page <|> pure 0) * MAX_RESULTS
Camil Staps's avatar
oops  
Camil Staps committed
166
		# results = drop drop_n $ sort $ search request db
Camil Staps's avatar
Camil Staps committed
167 168
		# more = max 0 (length results - MAX_RESULTS)
		// Suggestions
169
		# mbType = unify >>= parseType o fromString
Camil Staps's avatar
Camil Staps committed
170
		# suggestions
171 172
			= sortBy (\a b -> snd a > snd b) <$>
			  filter ((<)(length results) o snd) <$>
173 174
			  (mbType >>= \t -> suggs name t db)
		# results = take MAX_RESULTS results
Camil Staps's avatar
Camil Staps committed
175
		// Response
176 177 178
		# response = if (isEmpty results)
			(err E_NORESULTS "No results")
			{ return = 0
Camil Staps's avatar
Camil Staps committed
179 180 181 182
		    , msg = "Success"
		    , data           = results
		    , more_available = Just more
		    , suggestions    = suggestions
183 184 185
		    }
		// Save cache file
		= (response, writeCache request response w)
Mart Lubbers's avatar
Mart Lubbers committed
186

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

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

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

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

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

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

349 350
		toStrUnifier :: Unifier -> StrUnifier
		toStrUnifier (tvas1, tvas2) = (map toStr tvas1, map toStr tvas2)
351
		where toStr (var, type) = (var, concat $ print False type)
352

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

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

371 372 373 374 375 376
			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
377

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

Camil Staps's avatar
Camil Staps committed
381 382
	modToFilename :: String -> String
	modToFilename mod = (toString $ reverse $ takeWhile ((<>)'.')
383
	                              $ reverse $ fromString mod) + ".dcl"
Camil Staps's avatar
Camil Staps committed
384

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

388 389 390
	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
391
		= n1 == "" || indexOf n1 n2 <> -1 || levenshtein [c \\ c <-: n1] [c \\ c <-: n2] <= maxdist
Camil Staps's avatar
Camil Staps committed
392

393 394
	isModMatch :: ![String] Location -> Bool
	isModMatch mods (Location _ mod _ _) = isMember mod mods
Camil Staps's avatar
Camil Staps committed
395
	isModMatch _    (Builtin _)          = False
Camil Staps's avatar
Camil Staps committed
396

397
	isLibMatch :: (![String], !Bool) Location -> Bool
398
	isLibMatch (libs,_) (Location lib _ _ _) = any (\l -> indexOf l lib == 0) libs
399
	isLibMatch (_,blti) (Builtin _)          = blti
Camil Staps's avatar
Camil Staps committed
400

Camil Staps's avatar
Camil Staps committed
401 402 403
	loc :: Location -> (String, String, Maybe Int)
	loc (Location lib mod ln _) = (lib, mod, ln)

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

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

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