CloogleServer.icl 13.9 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
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 24
import qualified StdMaybe as OldMaybe
from SimpleTCPServer import :: LogMessage{..}, serve, :: Logger
import qualified SimpleTCPServer
25 26 27 28
import TypeDB
import Type
import Levenshtein

29 30
:: OldMaybe a :== 'SimpleTCPServer'.Maybe a

Camil Staps's avatar
Camil Staps committed
31 32 33
:: Request = { unify     :: Maybe String
             , name      :: Maybe String
             , className :: Maybe String
Camil Staps's avatar
Camil Staps committed
34
             , typeName  :: Maybe String
Camil Staps's avatar
Camil Staps committed
35 36
             , modules   :: Maybe [String]
             , page      :: Maybe Int
37 38
             }

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

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

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

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

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

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

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

84 85
:: StrUnifier :== ([(String,String)], [(String,String)])

Camil Staps's avatar
Camil Staps committed
86 87
:: ErrorResult = Error Int String

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

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

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

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

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

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

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

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

134
MAX_RESULTS    :== 15
135

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

153
	handle :: !TypeDB !(Maybe Request) !*World -> *(!Response, !*World)
Camil Staps's avatar
Camil Staps committed
154
	handle _ Nothing w = (err E_INVALIDINPUT "Couldn't parse input", w)
Camil Staps's avatar
Camil Staps committed
155
	handle db (Just request=:{unify,name,modules,page}) w
156
		| isJust name && size (fromJust name) > 40
Camil Staps's avatar
Camil Staps committed
157 158 159
			= (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
160 161
		| isJust unify && isNothing (parseType $ fromString $ fromJust unify)
			= (err E_INVALIDTYPE "couldn't parse type", w)
Camil Staps's avatar
Camil Staps committed
162 163
		// Results
		# drop_n = fromJust (page <|> pure 0) * MAX_RESULTS
Camil Staps's avatar
oops  
Camil Staps committed
164
		# results = drop drop_n $ sort $ search request db
Camil Staps's avatar
Camil Staps committed
165 166
		# more = max 0 (length results - MAX_RESULTS)
		// Suggestions
167
		# mbType = unify >>= parseType o fromString
Camil Staps's avatar
Camil Staps committed
168
		# suggestions
169 170
			= sortBy (\a b -> snd a > snd b) <$>
			  filter ((<)(length results) o snd) <$>
171 172
			  (mbType >>= \t -> suggs name t db)
		# results = take MAX_RESULTS results
Camil Staps's avatar
Camil Staps committed
173 174 175 176 177 178 179 180 181 182
		// Response
		| isEmpty results = (err E_NORESULTS "No results", w)
		= ( { return = 0
		    , msg = "Success"
		    , data           = results
		    , more_available = Just more
		    , suggestions    = suggestions
		    }
		  , w)

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

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

240
	makeClassResult :: (Location, [TypeVar], ClassContext, [(Name,ExtendedType)])
Camil Staps's avatar
Camil Staps committed
241
		TypeDB -> Result
242
	makeClassResult (Location lib mod line cls, vars, cc, funs) db
Camil Staps's avatar
Camil Staps committed
243 244 245
		= ClassResult
		  ( { library  = lib
		    , filename = modToFilename mod
Camil Staps's avatar
Camil Staps committed
246
		    , dcl_line = line
Camil Staps's avatar
Camil Staps committed
247
		    , modul    = mod
248
		    , distance = -100
Camil Staps's avatar
Camil Staps committed
249
		    , builtin  = Nothing
Camil Staps's avatar
Camil Staps committed
250 251
		    }
		  , { class_name = cls
252
		    , class_heading = foldl ((+) o (flip (+) " ")) cls vars +
Camil Staps's avatar
Camil Staps committed
253
		        if (isEmpty cc) "" " " + concat (print False cc)
254
		    , class_funs = [concat $ print False fun \\ fun <- funs]
Camil Staps's avatar
Camil Staps committed
255 256 257 258 259
		    , class_instances
		        = sort [concat (print False t) \\ t <- getInstances cls db]
		    }
		  )

260 261
	makeTypeResult :: (Maybe String) Location TypeDef -> Result
	makeTypeResult mbName (Location lib mod line t) td
Camil Staps's avatar
Camil Staps committed
262 263 264
		= TypeResult
		  ( { library  = lib
		    , filename = modToFilename mod
Camil Staps's avatar
Camil Staps committed
265
		    , dcl_line = line
Camil Staps's avatar
Camil Staps committed
266
		    , modul    = mod
Camil Staps's avatar
Camil Staps committed
267
		    , distance
268
		        = if (isNothing mbName) -100 (levenshtein` t (fromJust mbName))
Camil Staps's avatar
Camil Staps committed
269 270 271 272
		    , builtin  = Nothing
		    }
		  , { type = concat $ print False td }
		  )
273
	makeTypeResult mbName (Builtin t) td
Camil Staps's avatar
Camil Staps committed
274 275 276
		= TypeResult
		  ( { library  = ""
		    , filename = ""
Camil Staps's avatar
Camil Staps committed
277
		    , dcl_line = Nothing
Camil Staps's avatar
Camil Staps committed
278 279 280 281
		    , modul    = ""
		    , distance
		        = if (isNothing mbName) -100 (levenshtein` t (fromJust mbName))
		    , builtin  = Just True
Camil Staps's avatar
Camil Staps committed
282
		    }
283
		  , { type = concat $ print False td }
Camil Staps's avatar
Camil Staps committed
284 285
		  )

286 287
	makeMacroResult :: (Maybe String) Location Macro -> Result
	makeMacroResult mbName (Location lib mod line m) mac
Camil Staps's avatar
Camil Staps committed
288 289 290
		= MacroResult
		  ( { library  = lib
		    , filename = modToFilename mod
Camil Staps's avatar
Camil Staps committed
291
		    , dcl_line = line
Camil Staps's avatar
Camil Staps committed
292 293
		    , modul    = mod
		    , distance
Camil Staps's avatar
Camil Staps committed
294
		        = if (isNothing mbName) -100 (levenshtein` (fromJust mbName) m)
Camil Staps's avatar
Camil Staps committed
295
		    , builtin  = Nothing
Camil Staps's avatar
Camil Staps committed
296 297 298 299 300 301
		    }
		  , { macro_name = m
		    , macro_representation = mac.macro_as_string
		    }
		  )

Camil Staps's avatar
Camil Staps committed
302
	makeFunctionResult :: (Maybe String) (Maybe Type) (Maybe ShortClassResult)
303
		(Location, ExtendedType) TypeDB -> Result
Camil Staps's avatar
Camil Staps committed
304
	makeFunctionResult
Camil Staps's avatar
Camil Staps committed
305
		orgsearch orgsearchtype mbCls (fl, et=:(ET type tes)) db
Camil Staps's avatar
Camil Staps committed
306 307
		= FunctionResult
		  ( { library  = lib
Camil Staps's avatar
Camil Staps committed
308
		    , filename = modToFilename mod
Camil Staps's avatar
Camil Staps committed
309
		    , dcl_line = line
Camil Staps's avatar
Camil Staps committed
310 311
		    , modul    = mod
		    , distance = distance
Camil Staps's avatar
Camil Staps committed
312
		    , builtin  = builtin
Camil Staps's avatar
Camil Staps committed
313
		    }
314
		  , { func     = concat $ print False (fname,et)
315 316
		    , unifier  = toStrUnifier <$> finish_unification <$>
		        (orgsearchtype >>= unify [] (prepare_unification False type))
Camil Staps's avatar
Camil Staps committed
317
		    , cls      = mbCls
Camil Staps's avatar
Camil Staps committed
318 319 320
		    , constructor_of = if (tes.te_isconstructor)
		        (let (Func _ r _) = type in Just $ concat $ print False r)
		        Nothing
Camil Staps's avatar
Camil Staps committed
321 322 323
		    , recordfield_of = if (tes.te_isrecordfield)
		        (let (Func [t:_] _ _) = type in Just $ concat $ print False t)
		        Nothing
324 325
		    , generic_derivations
		        = let derivs = getDerivations fname db in
Camil Staps's avatar
Camil Staps committed
326 327
		          (\_ -> [concat $ print False d \\ d <-derivs]) <$>
		          tes.te_generic_vars
Camil Staps's avatar
Camil Staps committed
328 329
		    }
		  )
Camil Staps's avatar
Camil Staps committed
330
	where
Camil Staps's avatar
Camil Staps committed
331
		(lib,mod,fname,line,builtin) = case fl of
332 333
			(Location l m ln f) = (l,  m,  f, ln,      Nothing)
			(Builtin f)         = ("", "", f, Nothing, Just True)
Camil Staps's avatar
Camil Staps committed
334

335 336
		toStrUnifier :: Unifier -> StrUnifier
		toStrUnifier (tvas1, tvas2) = (map toStr tvas1, map toStr tvas2)
337
		where toStr (var, type) = (var, concat $ print False type)
338

Camil Staps's avatar
Camil Staps committed
339
		toStrPriority :: (Maybe TE_Priority) -> String
340
		toStrPriority p = case print False p of [] = ""; ss = concat [" ":ss]
Camil Staps's avatar
Camil Staps committed
341

Camil Staps's avatar
Camil Staps committed
342
		distance
Camil Staps's avatar
Camil Staps committed
343
			| isNothing orgsearch || fromJust orgsearch == ""
Camil Staps's avatar
Camil Staps committed
344 345
				| isNothing orgsearchtype = 0
				# orgsearchtype = fromJust orgsearchtype
346 347 348
				# (Just (ass1, ass2)) = finish_unification <$>
					unify [] orgsearchtype (prepare_unification False type)
				= toInt $ sum [typeComplexity t \\ (_,t)<-ass1 ++ ass2 | not (isVar t)]
349
			# orgsearch = fromJust orgsearch
Camil Staps's avatar
Camil Staps committed
350
			= levenshtein` orgsearch fname
351
		where
352 353 354 355 356 357
			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
358

Camil Staps's avatar
Camil Staps committed
359 360 361
	levenshtein` :: String String -> Int
	levenshtein` a b = if (indexOf a b == -1) 0 -100 + levenshtein a b

Camil Staps's avatar
Camil Staps committed
362 363
	modToFilename :: String -> String
	modToFilename mod = (toString $ reverse $ takeWhile ((<>)'.')
364
	                              $ reverse $ fromString mod) + ".dcl"
Camil Staps's avatar
Camil Staps committed
365

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

369 370 371
	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
372
		= n1 == "" || indexOf n1 n2 <> -1 || levenshtein n1 n2 <= maxdist
Camil Staps's avatar
Camil Staps committed
373

374 375
	isModMatch :: ![String] Location -> Bool
	isModMatch mods (Location _ mod _ _) = isMember mod mods
Camil Staps's avatar
Camil Staps committed
376
	isModMatch _    (Builtin _)          = False
Camil Staps's avatar
Camil Staps committed
377 378

	log :: (LogMessage (Maybe Request) Response) IPAddress *World
379
		-> *(IPAddress, *World)
Camil Staps's avatar
Camil Staps committed
380
	log msg s w
Camil Staps's avatar
Camil Staps committed
381 382
	| not needslog = (newS msg s, w)
	# (tm,w) = localTime w
Camil Staps's avatar
Camil Staps committed
383
	# (io,w) = stdio w
Camil Staps's avatar
Camil Staps committed
384
	# io = io <<< trim (toString tm) <<< " " <<< msgToString msg s
Camil Staps's avatar
Camil Staps committed
385
	= (newS msg s, snd (fclose io w))
Camil Staps's avatar
Camil Staps committed
386 387
	where
		needslog = case msg of (Received _) = True; (Sent _) = True; _ = False
Camil Staps's avatar
Camil Staps committed
388

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

Camil Staps's avatar
Camil Staps committed
392
	msgToString :: (LogMessage (Maybe Request) Response) IPAddress -> String
Camil Staps's avatar
Camil Staps committed
393
	msgToString (Received Nothing) ip
394
		= toString ip + " <-- Nothing\n"
Camil Staps's avatar
Camil Staps committed
395
	msgToString (Received (Just a)) ip
396
		= toString ip + " <-- " + toString a + "\n"
Camil Staps's avatar
Camil Staps committed
397
	msgToString (Sent {return,data,msg,more_available}) ip
398 399 400
		= 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
401
	msgToString _ _ = ""