Verified Commit 10931710 authored by Camil Staps's avatar Camil Staps 🚀

Class member search

parent 24287de7
......@@ -35,12 +35,17 @@ import Levenshtein
:: Result = { library :: String
, filename :: String
, func :: String
, cls :: Maybe ClassResult
, modul :: String
, distance :: Int
}
derive JSONEncode Command, Response, Result
derive JSONDecode Command, Response, Result
:: ErrorResult = Error Int String
:: ClassResult = { cls_name :: String, cls_vars :: [String] }
derive JSONEncode Command, Response, Result, ClassResult
derive JSONDecode Command, Response, Result, ClassResult
instance toString Response where toString r = toString $ toJSON r
instance toString Command where toString r = toString $ toJSON r
......@@ -66,34 +71,45 @@ Start w
# db = fromJust db
= serve (handle db) ('OldMaybe'.Just log) port w
where
help :: *File *World -> *World
help io w
# io = io <<< "Usage: ./CloogleServer <port>\n"
= snd $ fclose io w
handle :: TypeDB (Maybe Command) *World -> *(Response, *World)
handle _ Nothing w = (err 4 "Couldn't parse input", w)
handle db (Just {unify,name}) w
# mbType = parseType (fromString unify)
# filters = catMaybes $ [ isUnifiable <$> mbType
, pure $ isNameMatch (size name - 2) name
]
# results = take MAX_RESULTS $ sort
$ map (makeResult name mbType) $ findType`` filters db
= ({return=0,msg="Success",data=results}, w)
makeResult :: String (Maybe Type) (FunctionLocation, Type) -> Result
makeResult orgsearch orgsearchtype (FL lib mod fname, type)
= { library = lib
, filename = (toString $ reverse $ takeWhile ((<>)'.') $ reverse $ fromString mod) +++ ".dcl"
, modul = mod
, func = fname +++ " :: " +++ concat (stripParens $ print type)
, distance = distance
}
where
help :: *File *World -> *World
help io w
# io = io <<< "Usage: ./CloogleServer <port>\n"
= snd $ fclose io w
handle :: TypeDB (Maybe Command) *World -> *(Response, *World)
handle _ Nothing w = (err 4 "Couldn't parse input", w)
handle db (Just {unify,name}) w
# mbType = parseType (fromString unify)
// Search normal functions
# filts = catMaybes $ [ (\t->(\_ u->isUnifiable t u)) <$> mbType
, pure (\loc _ ->
isNameMatch (size name - 2) name loc)
]
# funcs = map (makeResult name mbType Nothing) $ findType`` filts db
// Search class members
# filts = catMaybes $ [ (\t->(\_ _ _ u->isUnifiable t u)) <$> mbType
, pure (\(CL lib mod _) _ f _ ->
isNameMatch (size name - 2) name (FL lib mod f))
]
# members = findClassMembers`` filts db
# members = map (\(CL lib mod cls,vs,f,t) -> makeResult name mbType
(Just {cls_name=cls,cls_vars=vs}) (FL lib mod f,t)) members
# results = take MAX_RESULTS $ sort $ funcs ++ members
= ({return=0,msg="Success",data=results}, w)
makeResult :: String (Maybe Type) (Maybe ClassResult) (FunctionLocation, Type) -> Result
makeResult orgsearch orgsearchtype mbCls (FL lib mod fname, type)
= { library = lib
, filename = (toString $ reverse $ takeWhile ((<>)'.') $ reverse $ fromString mod) +++ ".dcl"
, modul = mod
, func = fname +++ " :: " +++ concat (stripParens $ print type)
, cls = mbCls
, distance = distance
}
where
stripParens :: [String] -> [String]
stripParens ["(":ss]
| last ss == ")" && parensMatch 0 (init ss) = init ss
| last ss == ")" && parensMatch 0 (init ss) = stripParens $ init ss
| otherwise = ["(":ss]
stripParens ss = ss
......@@ -104,38 +120,38 @@ where
parensMatch i [")":ss] = i >= 0 && parensMatch (i-1) ss
parensMatch i [_:ss] = i >= 0 && parensMatch i ss
distance
| orgsearch == ""
| isNothing orgsearchtype = 0
# orgsearchtype = fromJust orgsearchtype
# (Just (ass1, ass2)) = unify [] orgsearchtype type
= length $ filter (not o isVar o snd) $ ass1 ++ ass2
# levdist = levenshtein fname orgsearch
= if (indexOf orgsearch fname == -1) 0 -100 + levdist
isUnifiable :: Type FunctionLocation Type -> Bool
isUnifiable t1 _ t2 = isJust (unify [] t1 t2)
isNameMatch :: Int String FunctionLocation Type -> Bool
isNameMatch maxdist n1 (FL _ _ n2) _
# (n1, n2) = ({toLower c \\ c <-: n1}, {toLower c \\ c <-: n2})
= n1 == "" || indexOf n1 n2 <> -1 || levenshtein n1 n2 <= maxdist
log :: (LogMessage (Maybe Command) Response) IPAddress *World -> *(IPAddress, *World)
log msg s w
# (io,w) = stdio w
# io = fwrites (msgToString msg s) io
= (newS msg s, snd (fclose io w))
newS :: (LogMessage (Maybe Command) Response) IPAddress -> IPAddress
newS m s = case m of (Connected ip) = ip; _ = s
msgToString :: (LogMessage (Maybe Command) Response) IPAddress -> String
msgToString (Received Nothing) ip
= toString ip +++ " <-- Nothing\n"
msgToString (Received (Just a)) ip
= toString ip +++ " <-- " +++ toString a +++ "\n"
msgToString (Sent b) ip
= toString ip +++ " --> " +++ toString b +++ "\n"
msgToString _ _ = ""
distance
| orgsearch == ""
| isNothing orgsearchtype = 0
# orgsearchtype = fromJust orgsearchtype
# (Just (ass1, ass2)) = unify [] orgsearchtype type
= length $ filter (not o isVar o snd) $ ass1 ++ ass2
# levdist = levenshtein fname orgsearch
= if (indexOf orgsearch fname == -1) 0 -100 + levdist
isUnifiable :: Type Type -> Bool
isUnifiable t1 t2 = isJust (unify [] t1 t2)
isNameMatch :: Int String FunctionLocation -> Bool
isNameMatch maxdist n1 (FL _ _ n2)
# (n1, n2) = ({toLower c \\ c <-: n1}, {toLower c \\ c <-: n2})
= n1 == "" || indexOf n1 n2 <> -1 || levenshtein n1 n2 <= maxdist
log :: (LogMessage (Maybe Command) Response) IPAddress *World -> *(IPAddress, *World)
log msg s w
# (io,w) = stdio w
# io = fwrites (msgToString msg s) io
= (newS msg s, snd (fclose io w))
newS :: (LogMessage (Maybe Command) Response) IPAddress -> IPAddress
newS m s = case m of (Connected ip) = ip; _ = s
msgToString :: (LogMessage (Maybe Command) Response) IPAddress -> String
msgToString (Received Nothing) ip
= toString ip +++ " <-- Nothing\n"
msgToString (Received (Just a)) ip
= toString ip +++ " <-- " +++ toString a +++ "\n"
msgToString (Sent b) ip
= toString ip +++ " --> " +++ toString b +++ "\n"
msgToString _ _ = ""
......@@ -32,7 +32,7 @@ putType :: FunctionLocation Type TypeDB -> TypeDB
putTypes :: [(FunctionLocation, Type)] TypeDB -> TypeDB
findType :: FunctionName TypeDB -> [(FunctionLocation, Type)]
findType` :: (FunctionLocation Type -> Bool) TypeDB -> [(FunctionLocation, Type)]
findType`` :: [(FunctionLocation Type -> Bool)] TypeDB -> [(FunctionLocation, Type)]
findType`` :: [FunctionLocation Type -> Bool] TypeDB -> [(FunctionLocation, Type)]
getInstances :: Class TypeDB -> [Type]
putInstance :: Class Type TypeDB -> TypeDB
......@@ -44,11 +44,17 @@ putClass :: ClassLocation [TypeVar] [(FunctionName, Type)] TypeDB -> TypeDB
putClasses :: [(ClassLocation, [TypeVar], [(FunctionName, Type)])] TypeDB -> TypeDB
findClass :: Class TypeDB -> [(ClassLocation, [TypeVar], [(FunctionName, Type)])]
findClass` :: (ClassLocation [TypeVar] [(FunctionName,Type)] -> Bool) TypeDB
-> [(ClassLocation, [TypeVar], [(FunctionName, Type)])]
-> [(ClassLocation, [TypeVar], [(FunctionName, Type)])]
findClassMembers` :: (ClassLocation [TypeVar] FunctionName Type -> Bool) TypeDB
-> [(ClassLocation, [TypeVar], FunctionName, Type)]
findClassMembers`` :: [ClassLocation [TypeVar] FunctionName Type -> Bool]
TypeDB -> [(ClassLocation, [TypeVar], FunctionName, Type)]
searchExact :: Type TypeDB -> [(FunctionLocation, Type)]
searchUnifiable :: Type TypeDB
-> [(FunctionLocation, Type, [TVAssignment], [TVAssignment])]
-> [(FunctionLocation, Type, [TVAssignment], [TVAssignment])]
newDb :: TypeDB
openDb :: *File -> *(Maybe TypeDB, *File)
......
......@@ -86,6 +86,21 @@ findClass` f {classmap} = map (\(k,(x,y))->(k,x,y)) results
where
results = toList $ filterWithKey (\cl (vs,fs)->f cl vs fs) classmap
findClassMembers` :: (ClassLocation [TypeVar] FunctionName Type -> Bool) TypeDB
-> [(ClassLocation, [TypeVar], FunctionName, Type)]
findClassMembers` f {classmap} = filter (\(a,b,c,d)->f a b c d) $ flatten members
where
members = map (\(cl,(vs,fs))->[(cl,vs,f,t) \\ (f,t)<-fs]) $ toList classmap
findClassMembers`` :: [(ClassLocation [TypeVar] FunctionName Type -> Bool)]
TypeDB -> [(ClassLocation, [TypeVar], FunctionName, Type)]
findClassMembers`` fs {classmap} = foldr (filter o app4) all_members fs
where
app4 :: (a b c d -> e) (a,b,c,d) -> e
app4 f (a,b,c,d) = f a b c d
all_members = [(cl,vs,f,t) \\ (cl,(vs,fs)) <- toList classmap, (f,t) <- fs]
searchExact :: Type TypeDB -> [(FunctionLocation, Type)]
searchExact t db = filter ((==)t o snd) $ toList db.typemap
......
......@@ -86,6 +86,7 @@ function formsubmit(){
'<tr><th>Filename: </th><td>' + c['filename'] + '</td></tr>' +
'<tr><th>Module: </th><td>' + c['modul'] + '</td>' +
'<td>' + c['distance'] + '</td></tr>' +
('cls' in c ? ('<tr><th>Class: </th><td>' + c['cls']['cls_name'] + ' ' + c['cls']['cls_vars'].join(' ') + '</td></tr>') : '') +
'</table>' +
'<code>' + highlight(c['func']) + '</code>';
}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment