CloogleServer.icl 13.7 KB
Newer Older
1 2
module CloogleServer

3 4 5 6 7 8 9 10
import StdArray
import StdBool
import StdFile
import StdList
import StdOrdList
import StdOverloaded
import StdString
import StdTuple
Camil Staps's avatar
Camil Staps committed
11
from StdFunc import o, flip, const
12
from StdMisc import abort
13

14
from TCPIP import :: IPAddress, :: Port, instance toString IPAddress
15 16

from Data.Func import $
Camil Staps's avatar
Camil Staps committed
17
import Data.List
18
import Data.Tuple
19 20 21 22
import Data.Maybe
import System.CommandLine
import Data.Functor
import Control.Applicative
23
import Control.Monad
Camil Staps's avatar
Camil Staps committed
24
from Text import class Text(concat,trim,indexOf,toLowerCase),
25
	instance Text String, instance + String
Camil Staps's avatar
Camil Staps committed
26 27

import System.Time
28

29 30
from SimpleTCPServer import :: LogMessage{..}, serve, :: Logger
import qualified SimpleTCPServer
31 32
import TypeDB
import Type
33
import Cache
34
import Cloogle
Camil Staps's avatar
Camil Staps committed
35

36
MAX_RESULTS    :== 15
Camil Staps's avatar
Camil Staps committed
37
CACHE_PREFETCH :== 5
38

39 40 41 42 43 44 45 46 47
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"
48
#! db = fromJust db
Camil Staps's avatar
Camil Staps committed
49
= serve (handle db) (Just log) port w
50
where
Camil Staps's avatar
Camil Staps committed
51 52 53 54 55
	help :: *File *World -> *World
	help io w
	# io = io <<< "Usage: ./CloogleServer <port>\n"
	= snd $ fclose io w

Camil Staps's avatar
Camil Staps committed
56
	handle :: !TypeDB !(Maybe Request) !*World -> *(!Response, CacheKey, !*World)
57
	handle _ Nothing w = (err CLOOGLE_E_INVALIDINPUT "Couldn't parse input", "", w)
Camil Staps's avatar
Camil Staps committed
58
	handle db (Just request=:{unify,name,page}) w
59
		//Check cache
60 61 62
		# (mbResponse, w) = readCache request w
		| isJust mbResponse
			# r = fromJust mbResponse
Camil Staps's avatar
Camil Staps committed
63
			= ({r & return = if (r.return == 0) 1 r.return}, cacheKey request, w)
64
		| isJust name && size (fromJust name) > 40
65
			= respond (err CLOOGLE_E_INVALIDNAME "Function name too long") w
Camil Staps's avatar
Camil Staps committed
66
		| isJust name && any isSpace (fromString $ fromJust name)
67
			= respond (err CLOOGLE_E_INVALIDNAME "Name cannot contain spaces") w
Camil Staps's avatar
Camil Staps committed
68
		| isJust unify && isNothing (parseType $ fromString $ fromJust unify)
69
			= respond (err CLOOGLE_E_INVALIDTYPE "Couldn't parse type") w
Camil Staps's avatar
Camil Staps committed
70 71
		// Results
		# drop_n = fromJust (page <|> pure 0) * MAX_RESULTS
Camil Staps's avatar
oops  
Camil Staps committed
72
		# results = drop drop_n $ sort $ search request db
Camil Staps's avatar
Camil Staps committed
73 74
		# more = max 0 (length results - MAX_RESULTS)
		// Suggestions
75
		# mbType = unify >>= parseType o fromString
Camil Staps's avatar
Camil Staps committed
76
		# suggestions
77 78
			= sortBy (\a b -> snd a > snd b) <$>
			  filter ((<)(length results) o snd) <$>
79
			  (mbType >>= \t -> suggs name t db)
Camil Staps's avatar
Camil Staps committed
80
		# (results,nextpages) = splitAt MAX_RESULTS results
Camil Staps's avatar
Camil Staps committed
81
		// Response
82
		# response = if (isEmpty results)
83
			(err CLOOGLE_E_NORESULTS "No results")
84
			{ return = 0
Camil Staps's avatar
Camil Staps committed
85 86 87 88
		    , msg = "Success"
		    , data           = results
		    , more_available = Just more
		    , suggestions    = suggestions
89
		    }
Camil Staps's avatar
Camil Staps committed
90 91
		// Save page prefetches
		# w = cachePages CACHE_PREFETCH 1 response nextpages w
92
		// Save cache file
93 94
		= respond response w
	where
Camil Staps's avatar
Camil Staps committed
95 96
		respond :: Response *World -> *(Response, CacheKey, *World)
		respond r w = (r, cacheKey request, writeCache LongTerm request r w)
Camil Staps's avatar
Camil Staps committed
97 98 99 100 101 102 103 104

		cachePages :: Int Int Response [Result] *World -> *World
		cachePages _ _  _ [] w = w
		cachePages 0 _  _ _  w = w
		cachePages npages i response results w
		# w = writeCache Brief req` resp` w
		= cachePages (npages - 1) (i + 1) response keep w
		where
105
			req` = { request & page = ((+) i) <$> (request.page <|> pure 0) }
Camil Staps's avatar
Camil Staps committed
106 107 108 109 110 111
			resp` =
				{ response
				& more_available = Just $ max 0 (length results - MAX_RESULTS)
				, data = give
				}
			(give,keep) = splitAt MAX_RESULTS results
Mart Lubbers's avatar
Mart Lubbers committed
112

113
	suggs :: !(Maybe String) !Type !TypeDB -> Maybe [(Request, Int)]
114
	suggs n (Func is r cc) db
115 116
		| length is < 3
			= Just [let t` = concat $ print False $ Func is` r cc in
117 118
			        let request = {zero & name=n, unify=Just t`} in
			        (request, length $ search request db)
119
			        \\ is` <- permutations is | is` <> is]
120
	suggs _ _ _ = Nothing
Camil Staps's avatar
Camil Staps committed
121

122
	search :: !Request !TypeDB -> [Result]
Camil Staps's avatar
Camil Staps committed
123 124 125 126
	search {unify,name,className,typeName,modules,libraries,page} db
		# db = case libraries of
			(Just ls) = filterLocations (isLibMatch ls) db
			Nothing   = db
127 128 129
		# db = case modules of
			(Just ms) = filterLocations (isModMatch ms) db
			Nothing   = db
Camil Staps's avatar
Camil Staps committed
130 131 132 133
		| isJust className
			# className = fromJust className
			# classes = findClass className db
			= map (flip makeClassResult db) classes
Camil Staps's avatar
Camil Staps committed
134 135 136
		| isJust typeName
			# typeName = fromJust typeName
			# types = findType typeName db
137
			= [makeTypeResult (Just typeName) l td db \\ (l,td) <- types]
138
		# mbType = prepare_unification True <$> (unify >>= parseType o fromString)
Camil Staps's avatar
Camil Staps committed
139
		// Search normal functions
140
		# filts = catMaybes [ (\t _ -> isUnifiable t) <$> mbType
141
		                    , (\n loc _ -> isNameMatch (size n*2/3) n loc) <$> name
142
		                    ]
143
		# funs = map (\f -> makeFunctionResult name mbType Nothing f db) $ findFunction`` filts db
Camil Staps's avatar
Camil Staps committed
144
		// Search macros
145
		# macros = case (isNothing mbType,name) of
146
			(True,Just n) = findMacro` (\loc _ -> isNameMatch (size n*2/3) n loc) db
147
			_             = []
Camil Staps's avatar
Camil Staps committed
148
		# macros = map (\(lhs,rhs) -> makeMacroResult name lhs rhs) macros
Camil Staps's avatar
Camil Staps committed
149
		// Search class members
Camil Staps's avatar
Camil Staps committed
150
		# filts = catMaybes [ (\t _ _ _ _->isUnifiable t) <$> mbType
151 152
		                    , (\n (Location lib mod _ _ _) _ _ f _ -> isNameMatch
		                      (size n*2/3) n (Location lib mod Nothing Nothing f)) <$> name
153
		                    ]
Camil Staps's avatar
Camil Staps committed
154
		# members = findClassMembers`` filts db
155 156
		# members = map (\(Location lib mod line iclline cls,vs,_,f,et) -> makeFunctionResult name mbType
			(Just {cls_name=cls,cls_vars=vs}) (Location lib mod line iclline f,et) db) members
Camil Staps's avatar
Camil Staps committed
157
		// Search types
158
		# lcName = if (isJust mbType && isType (fromJust mbType))
Camil Staps's avatar
Camil Staps committed
159 160
			(let (Type name _) = fromJust mbType in Just $ toLowerCase name)
			(toLowerCase <$> name)
161 162 163
		# types = case (isNothing mbType,lcName) of
			(True,Just n) = findType` (\loc _ -> toLowerCase (getName loc) == n) db
			_             = []
164
		# types = map (\(tl,td) -> makeTypeResult name tl td db) types
165 166
		// Search classes
		# classes = case (isNothing mbType, toLowerCase <$> name) of
Camil Staps's avatar
Camil Staps committed
167
			(True, Just c) = findClass` (\loc _ _ _ -> toLowerCase (getName loc) == c) db
Camil Staps's avatar
Camil Staps committed
168 169
			_              = []
		# classes = map (flip makeClassResult db) classes
Camil Staps's avatar
Camil Staps committed
170
		// Merge results
Camil Staps's avatar
Camil Staps committed
171
		= sort $ funs ++ members ++ types ++ classes ++ macros
Camil Staps's avatar
Camil Staps committed
172

173
	makeClassResult :: (Location, [TypeVar], ClassContext, [(Name,ExtendedType)])
Camil Staps's avatar
Camil Staps committed
174
		TypeDB -> Result
Camil Staps's avatar
Camil Staps committed
175 176 177 178 179
	makeClassResult rec=:(Builtin _, _, _, _) db
		= ClassResult
		  ( { library  = ""
		    , filename = ""
		    , dcl_line = Nothing
180
		    , icl_line = Nothing
Camil Staps's avatar
Camil Staps committed
181 182 183 184 185 186
		    , modul    = ""
		    , distance = -100
		    , builtin  = Just True
		    }
		  , makeClassResultExtras rec db
		  )
187
	makeClassResult rec=:(Location lib mod line iclline cls, vars, cc, funs) db
Camil Staps's avatar
Camil Staps committed
188 189 190
		= ClassResult
		  ( { library  = lib
		    , filename = modToFilename mod
Camil Staps's avatar
Camil Staps committed
191
		    , dcl_line = line
192
		    , icl_line = iclline
Camil Staps's avatar
Camil Staps committed
193
		    , modul    = mod
194
		    , distance = -100
Camil Staps's avatar
Camil Staps committed
195
		    , builtin  = Nothing
Camil Staps's avatar
Camil Staps committed
196
		    }
Camil Staps's avatar
Camil Staps committed
197
		  , makeClassResultExtras rec db
Camil Staps's avatar
Camil Staps committed
198
		  )
Camil Staps's avatar
Camil Staps committed
199 200 201 202 203
	makeClassResultExtras :: (Location, [TypeVar], ClassContext, [(Name,ExtendedType)])
		TypeDB -> ClassResultExtras
	makeClassResultExtras (l, vars, cc, funs) db
		= { class_name = cls
		  , class_heading = foldl ((+) o (flip (+) " ")) cls vars +
204
		      if (isEmpty cc) "" " | " + concat (print False cc)
Camil Staps's avatar
Camil Staps committed
205 206 207 208 209 210
		  , class_funs = [print_fun fun \\ fun <- funs]
		  , class_instances
		      = sortBy (\(a,_) (b,_) -> a < b)
		          [([concat (print False t) \\ t <- ts], map loc ls)
		          \\ (ts,ls) <- getInstances cls db]
		  }
211
	where
Camil Staps's avatar
Camil Staps committed
212 213
		cls = case l of
			Builtin c = c
214
			Location _ _ _ _ c = c
Camil Staps's avatar
Camil Staps committed
215

216 217 218
		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
219

220
	makeTypeResult :: (Maybe String) Location TypeDef TypeDB -> Result
221
	makeTypeResult mbName (Location lib mod line iclline t) td db
Camil Staps's avatar
Camil Staps committed
222 223 224
		= TypeResult
		  ( { library  = lib
		    , filename = modToFilename mod
Camil Staps's avatar
Camil Staps committed
225
		    , dcl_line = line
226
		    , icl_line = iclline
Camil Staps's avatar
Camil Staps committed
227
		    , modul    = mod
Camil Staps's avatar
Camil Staps committed
228
		    , distance
229
		        = if (isNothing mbName) -100 (levenshtein` t (fromJust mbName))
Camil Staps's avatar
Camil Staps committed
230 231
		    , builtin  = Nothing
		    }
232
		  , { type             = concat $ print False td
233 234
		    , type_instances   = map (appSnd3 (map (concat o (print False)))) $
		        map (appThd3 (map loc)) $ getTypeInstances t db
235 236
		    , type_derivations = map (appSnd (map loc)) $ getTypeDerivations t db
		    }
Camil Staps's avatar
Camil Staps committed
237
		  )
238
	makeTypeResult mbName (Builtin t) td db
Camil Staps's avatar
Camil Staps committed
239 240 241
		= TypeResult
		  ( { library  = ""
		    , filename = ""
Camil Staps's avatar
Camil Staps committed
242
		    , dcl_line = Nothing
243
		    , icl_line = Nothing
Camil Staps's avatar
Camil Staps committed
244 245 246 247
		    , modul    = ""
		    , distance
		        = if (isNothing mbName) -100 (levenshtein` t (fromJust mbName))
		    , builtin  = Just True
Camil Staps's avatar
Camil Staps committed
248
		    }
249
		  , { type             = concat $ print False td
250 251
		    , type_instances   = map (appSnd3 (map (concat o (print False)))) $
		        map (appThd3 (map loc)) $ getTypeInstances t db
252 253
		    , type_derivations = map (appSnd (map loc)) $ getTypeDerivations t db
		    }
Camil Staps's avatar
Camil Staps committed
254 255
		  )

256
	makeMacroResult :: (Maybe String) Location Macro -> Result
257
	makeMacroResult mbName (Location lib mod line iclline m) mac
Camil Staps's avatar
Camil Staps committed
258 259 260
		= MacroResult
		  ( { library  = lib
		    , filename = modToFilename mod
Camil Staps's avatar
Camil Staps committed
261
		    , dcl_line = line
262
		    , icl_line = iclline
Camil Staps's avatar
Camil Staps committed
263 264
		    , modul    = mod
		    , distance
Camil Staps's avatar
Camil Staps committed
265
		        = if (isNothing mbName) -100 (levenshtein` (fromJust mbName) m)
Camil Staps's avatar
Camil Staps committed
266
		    , builtin  = Nothing
Camil Staps's avatar
Camil Staps committed
267 268 269 270 271 272
		    }
		  , { macro_name = m
		    , macro_representation = mac.macro_as_string
		    }
		  )

Camil Staps's avatar
Camil Staps committed
273
	makeFunctionResult :: (Maybe String) (Maybe Type) (Maybe ShortClassResult)
274
		(Location, ExtendedType) TypeDB -> Result
Camil Staps's avatar
Camil Staps committed
275
	makeFunctionResult
Camil Staps's avatar
Camil Staps committed
276
		orgsearch orgsearchtype mbCls (fl, et=:(ET type tes)) db
Camil Staps's avatar
Camil Staps committed
277 278
		= FunctionResult
		  ( { library  = lib
Camil Staps's avatar
Camil Staps committed
279
		    , filename = modToFilename mod
Camil Staps's avatar
Camil Staps committed
280
		    , dcl_line = line
281
		    , icl_line = iclline
Camil Staps's avatar
Camil Staps committed
282 283
		    , modul    = mod
		    , distance = distance
Camil Staps's avatar
Camil Staps committed
284
		    , builtin  = builtin
Camil Staps's avatar
Camil Staps committed
285
		    }
286 287
		  , { func     = fromJust (tes.te_representation <|>
		                           (pure $ concat $ print False (fname,et)))
288 289
		    , unifier  = toStrUnifier <$> finish_unification <$>
		        (orgsearchtype >>= unify [] (prepare_unification False type))
Camil Staps's avatar
Camil Staps committed
290
		    , cls      = mbCls
291
		    , constructor_of = if tes.te_isconstructor
Camil Staps's avatar
Camil Staps committed
292 293
		        (let (Func _ r _) = type in Just $ concat $ print False r)
		        Nothing
294
		    , recordfield_of = if tes.te_isrecordfield
Camil Staps's avatar
Camil Staps committed
295 296
		        (let (Func [t:_] _ _) = type in Just $ concat $ print False t)
		        Nothing
297 298
		    , generic_derivations
		        = let derivs = getDerivations fname db in
Camil Staps's avatar
Camil Staps committed
299 300
		          const (sortBy (\(a,_) (b,_) -> a < b)
				    [(concat $ print False d, map loc ls) \\ (d,ls) <- derivs]) <$>
Camil Staps's avatar
Camil Staps committed
301
		          tes.te_generic_vars
Camil Staps's avatar
Camil Staps committed
302 303
		    }
		  )
Camil Staps's avatar
Camil Staps committed
304
	where
305 306 307
		(lib,mod,fname,line,iclline,builtin) = case fl of
			(Location l m ln iln f) = (l,  m,  f, ln,      iln,     Nothing)
			(Builtin f)             = ("", "", f, Nothing, Nothing, Just True)
Camil Staps's avatar
Camil Staps committed
308

309 310
		toStrUnifier :: Unifier -> StrUnifier
		toStrUnifier (tvas1, tvas2) = (map toStr tvas1, map toStr tvas2)
311
		where toStr (var, type) = (var, concat $ print False type)
312

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

Camil Staps's avatar
Camil Staps committed
316
		distance
Camil Staps's avatar
Camil Staps committed
317
			| isNothing orgsearch || fromJust orgsearch == ""
Camil Staps's avatar
Camil Staps committed
318 319
				| isNothing orgsearchtype = 0
				# orgsearchtype = fromJust orgsearchtype
320 321
				# (Just (ass1, ass2)) = finish_unification <$>
					unify [] orgsearchtype (prepare_unification False type)
322
				= penalty + toInt (sum [typeComplexity t \\ (_,t)<-ass1 ++ ass2 | not (isVar t)])
323
			# orgsearch = fromJust orgsearch
324
			= penalty + levenshtein` orgsearch fname
325
		where
326 327 328 329 330
			penalty
			| tes.te_isrecordfield = 2
			| tes.te_isconstructor = 1
			| otherwise            = 0

331 332 333 334 335 336
			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
337

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

Camil Staps's avatar
Camil Staps committed
341 342
	modToFilename :: String -> String
	modToFilename mod = (toString $ reverse $ takeWhile ((<>)'.')
343
	                              $ reverse $ fromString mod) + ".dcl"
Camil Staps's avatar
Camil Staps committed
344

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

348 349 350
	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
351
		= n1 == "" || indexOf n1 n2 <> -1 || levenshtein [c \\ c <-: n1] [c \\ c <-: n2] <= maxdist
Camil Staps's avatar
Camil Staps committed
352

353
	isModMatch :: ![String] Location -> Bool
354 355
	isModMatch mods (Location _ mod _ _ _) = isMember mod mods
	isModMatch _    (Builtin _)            = False
Camil Staps's avatar
Camil Staps committed
356

357
	isLibMatch :: (![String], !Bool) Location -> Bool
358 359
	isLibMatch (libs,_) (Location lib _ _ _ _) = any (\l -> indexOf l lib == 0) libs
	isLibMatch (_,blti) (Builtin _)            = blti
Camil Staps's avatar
Camil Staps committed
360

361
	loc :: Location -> LocationResult
362
	loc (Location lib mod ln iln _) = (lib, mod, ln, iln)
Camil Staps's avatar
Camil Staps committed
363

Camil Staps's avatar
Camil Staps committed
364
	log :: (LogMessage (Maybe Request) Response CacheKey) IPAddress *World
365
		-> *(IPAddress, *World)
Camil Staps's avatar
Camil Staps committed
366
	log msg s w
Camil Staps's avatar
Camil Staps committed
367 368
	| not needslog = (newS msg s, w)
	# (tm,w) = localTime w
Camil Staps's avatar
Camil Staps committed
369
	# (io,w) = stdio w
Camil Staps's avatar
Camil Staps committed
370
	# io = io <<< trim (toString tm) <<< " " <<< msgToString msg s
Camil Staps's avatar
Camil Staps committed
371
	= (newS msg s, snd (fclose io w))
Camil Staps's avatar
Camil Staps committed
372
	where
Camil Staps's avatar
Camil Staps committed
373
		needslog = case msg of (Received _) = True; (Sent _ _) = True; _ = False
Camil Staps's avatar
Camil Staps committed
374

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

Camil Staps's avatar
Camil Staps committed
378
	msgToString :: (LogMessage (Maybe Request) Response CacheKey) IPAddress -> String
Camil Staps's avatar
Camil Staps committed
379
	msgToString (Received Nothing) ip
380
		= toString ip + " <-- Nothing\n"
Camil Staps's avatar
Camil Staps committed
381
	msgToString (Received (Just a)) ip
382
		= toString ip + " <-- " + toString a + "\n"
Camil Staps's avatar
Camil Staps committed
383
	msgToString (Sent {return,data,msg,more_available} ck) ip
384
		= toString ip + " --> " + toString (length data)
Camil Staps's avatar
Camil Staps committed
385 386 387
			+ " results (" + toString return + "; " + msg
			+ if (isJust more_available) ("; " + toString (fromJust more_available) + " more") ""
			+ "; cache: " + ck + ")\n"
Camil Staps's avatar
Camil Staps committed
388
	msgToString _ _ = ""