CloogleServer.icl 15 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 176
		// Response
		| isEmpty results = (err E_NORESULTS "No results", w)
177
		// Save cache file
178
		= writeCache request {return = 0
Camil Staps's avatar
Camil Staps committed
179 180 181 182
		    , msg = "Success"
		    , data           = results
		    , more_available = Just more
		    , suggestions    = suggestions
Mart Lubbers's avatar
Mart Lubbers committed
183 184
		    } w

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

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

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

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

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

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

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

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

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

369 370 371 372 373 374
			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
375

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

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

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

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

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

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

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

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

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

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