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

Search on class definitions

parent 0a7bf1b7
Subproject commit cc75e69f4b9c2070d495ca465c1964b9fcd6ed0e
Subproject commit a890ba730f497dd71795895a4d590c6a9b8d7a56
......@@ -28,10 +28,11 @@ import Levenshtein
:: OldMaybe a :== 'SimpleTCPServer'.Maybe a
:: Request = { unify :: Maybe String
, name :: Maybe String
, modules :: Maybe [String]
, page :: Maybe Int
:: Request = { unify :: Maybe String
, name :: Maybe String
, className :: Maybe String
, modules :: Maybe [String]
, page :: Maybe Int
}
:: Response = { return :: Int
......@@ -43,6 +44,7 @@ import Levenshtein
:: Result = FunctionResult FunctionResult
| TypeResult TypeResult
| ClassResult ClassResult
:: BasicResult = { library :: String
, filename :: String
......@@ -53,7 +55,7 @@ import Levenshtein
:: FunctionResult :== (BasicResult, FunctionResultExtras)
:: FunctionResultExtras = { func :: String
, unifier :: Maybe StrUnifier
, cls :: Maybe ClassResult
, cls :: Maybe ShortClassResult
, constructor_of :: Maybe String
}
......@@ -61,23 +63,31 @@ import Levenshtein
:: TypeResultExtras = { type :: String
}
:: ClassResult :== (BasicResult, ClassResultExtras)
:: ClassResultExtras = { class_name :: String
, class_heading :: String
, class_funs :: [String]
, class_instances :: [String]
}
:: StrUnifier :== ([(String,String)], [(String,String)])
:: ErrorResult = Error Int String
:: ClassResult = { cls_name :: String, cls_vars :: [String] }
:: ShortClassResult = { cls_name :: String, cls_vars :: [String] }
derive JSONEncode Request, Response, Result, ClassResult, BasicResult,
FunctionResultExtras, TypeResultExtras
derive JSONDecode Request, Response, Result, ClassResult, BasicResult,
FunctionResultExtras, TypeResultExtras
derive JSONEncode Request, Response, Result, ShortClassResult, BasicResult,
FunctionResultExtras, TypeResultExtras, ClassResultExtras
derive JSONDecode Request, Response, Result, ShortClassResult, BasicResult,
FunctionResultExtras, TypeResultExtras, ClassResultExtras
instance zero Request
where
zero = { unify = Nothing
, name = Nothing
, modules = Nothing
, page = Nothing
zero = { unify = Nothing
, name = Nothing
, className = Nothing
, modules = Nothing
, page = Nothing
}
instance toString Response where toString r = toString (toJSON r) +++ "\n"
......@@ -104,7 +114,7 @@ err c m = { return = c
E_NORESULTS :== 127
E_INVALIDINPUT :== 128
E_NAMETOOLONG :== 129
E_INVALIDNAME :== 129
E_INVALIDTYPE :== 130
MAX_RESULTS :== 15
......@@ -130,7 +140,9 @@ where
handle _ Nothing w = (err E_INVALIDINPUT "Couldn't parse input", w)
handle db (Just request=:{unify,name,modules,page}) w
| isJust name && size (fromJust name) > 40
= (err E_NAMETOOLONG "function name too long", w)
= (err E_INVALIDNAME "function name too long", w)
| isJust name && any isSpace (fromString $ fromJust name)
= (err E_INVALIDNAME "name cannot contain spaces", w)
| isJust unify && isNothing (parseType $ fromString $ fromJust unify)
= (err E_INVALIDTYPE "couldn't parse type", w)
// Results
......@@ -163,7 +175,11 @@ where
suggs _ _ = Nothing
search :: !Request !TypeDB -> [Result]
search {unify,name,modules,page} db
search {unify,name,className,modules,page} db
| isJust className
# className = fromJust className
# classes = findClass className db
= map (flip makeClassResult db) classes
# mbType = prepare_unification True <$> (unify >>= parseType o fromString)
// Search normal functions
# filts = catMaybes [ (\t _ -> isUnifiable t) <$> mbType
......@@ -172,13 +188,13 @@ where
]
# funs = map (makeFunctionResult name mbType Nothing) $ findFunction`` filts db
// Search class members
# filts = catMaybes [ (\t _ _ _->isUnifiable t) <$> mbType
, (\n (CL lib mod _) _ f _ -> isNameMatch
# filts = catMaybes [ (\t _ _ _ _->isUnifiable t) <$> mbType
, (\n (CL lib mod _) _ _ f _ -> isNameMatch
(size n-2) n (FL lib mod f)) <$> name
, isModMatchC <$> modules
]
# members = findClassMembers`` filts db
# members = map (\(CL lib mod cls,vs,f,et) -> makeFunctionResult name mbType
# members = map (\(CL lib mod cls,vs,_,f,et) -> makeFunctionResult name mbType
(Just {cls_name=cls,cls_vars=vs}) (FL lib mod f,et)) members
// Search types
# lcTypeName = if (isJust mbType && isType (fromJust mbType))
......@@ -191,6 +207,24 @@ where
// Merge results
= sort $ funs ++ members ++ types
makeClassResult :: (ClassLocation, [TypeVar], ClassContext, [(FunctionName,ExtendedType)])
TypeDB -> Result
makeClassResult (CL lib mod cls, vars, cc, funs) db
= ClassResult
( { library = lib
, filename = modToFilename mod
, modul = mod
, distance = 0
}
, { class_name = cls
, class_heading = foldl ((+++) o (flip (+++) " ")) cls vars +++
if (isEmpty cc) "" " " +++ concat (print False cc)
, class_funs = [f +++ concat (print False t) \\ (f,t) <- funs]
, class_instances
= sort [concat (print False t) \\ t <- getInstances cls db]
}
)
makeTypeResult :: (Maybe String) TypeLocation TypeDef -> Result
makeTypeResult mbName (TL lib mod t) td
= TypeResult
......@@ -203,18 +237,17 @@ where
, { type = concat $ print False td }
)
makeFunctionResult :: (Maybe String) (Maybe Type) (Maybe ClassResult)
makeFunctionResult :: (Maybe String) (Maybe Type) (Maybe ShortClassResult)
(FunctionLocation, ExtendedType) -> Result
makeFunctionResult
orgsearch orgsearchtype mbCls (FL lib mod fname, ET type tes)
orgsearch orgsearchtype mbCls (FL lib mod fname, et=:(ET type tes))
= FunctionResult
( { library = lib
, filename = modToFilename mod
, modul = mod
, distance = distance
}
, { func = fname +++ toStrPriority tes.te_priority +++
" :: " +++ concat (print False type)
, { func = fname +++ concat (print False et)
, unifier = toStrUnifier <$> finish_unification <$>
(orgsearchtype >>= unify [] (prepare_unification False type))
, cls = mbCls
......@@ -266,8 +299,8 @@ where
isModMatchF :: ![String] FunctionLocation ExtendedType -> Bool
isModMatchF mods (FL _ mod _) _ = isMember mod mods
isModMatchC :: ![String] ClassLocation [TypeVar] FunctionName ExtendedType -> Bool
isModMatchC mods (CL _ mod _) _ _ _ = isMember mod mods
isModMatchC :: ![String] ClassLocation [TypeVar] ClassContext FunctionName ExtendedType -> Bool
isModMatchC mods (CL _ mod _) _ _ _ _ = isMember mod mods
log :: (LogMessage (Maybe Request) Response) IPAddress *World
-> *(IPAddress, *World)
......
......@@ -60,8 +60,8 @@ fields:
* `0`: success
* `127`: no results
* `128`: ununderstandable input (usually shouldn't happen)
* `129`: function name too long
* `130`: couldn't parse type
* `129`: invalid name field
* `130`: couldn't parse unify field as a type
* `150`: the Clean backend could not be reached
* `151`: invalid request type (should use GET)
* `152`: no input (GET variable `str` should be set to the search string)
......
......@@ -10,7 +10,8 @@ from Data.Maybe import ::Maybe
from GenEq import generic gEq
// CleanTypeUnifier
from Type import ::Type, ::TypeVar, ::TVAssignment, ::TypeDef, class print(..)
from Type import ::Type, ::TypeVar, ::TVAssignment, ::TypeDef, class print(..),
::ClassContext, ::ClassRestriction, ::ClassOrGeneric
:: TypeDB
instance zero TypeDB
......@@ -28,6 +29,7 @@ instance zero TypeExtras
instance print TE_Priority
:: ExtendedType = ET Type TypeExtras
instance print ExtendedType
:: ClassLocation = CL Library Module Class
......@@ -54,17 +56,17 @@ putInstance :: Class Type TypeDB -> TypeDB
putInstances :: Class [Type] TypeDB -> TypeDB
putInstancess :: [(Class, [Type])] TypeDB -> TypeDB
getClass :: ClassLocation TypeDB -> Maybe ([TypeVar],[(FunctionName,ExtendedType)])
putClass :: ClassLocation [TypeVar] [(FunctionName, ExtendedType)] TypeDB -> TypeDB
putClasses :: [(ClassLocation, [TypeVar], [(FunctionName, ExtendedType)])] TypeDB -> TypeDB
findClass :: Class TypeDB -> [(ClassLocation, [TypeVar], [(FunctionName, ExtendedType)])]
findClass` :: (ClassLocation [TypeVar] [(FunctionName,ExtendedType)] -> Bool) TypeDB
-> [(ClassLocation, [TypeVar], [(FunctionName, ExtendedType)])]
findClassMembers` :: (ClassLocation [TypeVar] FunctionName ExtendedType -> Bool) TypeDB
-> [(ClassLocation, [TypeVar], FunctionName, ExtendedType)]
findClassMembers`` :: [ClassLocation [TypeVar] FunctionName ExtendedType -> Bool]
TypeDB -> [(ClassLocation, [TypeVar], FunctionName, ExtendedType)]
getClass :: ClassLocation TypeDB -> Maybe ([TypeVar],ClassContext,[(FunctionName,ExtendedType)])
putClass :: ClassLocation [TypeVar] ClassContext [(FunctionName,ExtendedType)] TypeDB -> TypeDB
putClasses :: [(ClassLocation, [TypeVar], ClassContext, [(FunctionName,ExtendedType)])] TypeDB -> TypeDB
findClass :: Class TypeDB -> [(ClassLocation, [TypeVar], ClassContext, [(FunctionName, ExtendedType)])]
findClass` :: (ClassLocation [TypeVar] ClassContext [(FunctionName,ExtendedType)] -> Bool) TypeDB
-> [(ClassLocation, [TypeVar], ClassContext, [(FunctionName, ExtendedType)])]
findClassMembers` :: (ClassLocation [TypeVar] ClassContext FunctionName ExtendedType -> Bool) TypeDB
-> [(ClassLocation, [TypeVar], ClassContext, FunctionName, ExtendedType)]
findClassMembers`` :: [ClassLocation [TypeVar] ClassContext FunctionName ExtendedType -> Bool]
TypeDB -> [(ClassLocation, [TypeVar], ClassContext, FunctionName, ExtendedType)]
getType :: TypeLocation TypeDB -> Maybe TypeDef
putType :: TypeLocation TypeDef TypeDB -> TypeDB
......
......@@ -11,7 +11,7 @@ import Text.JSON
import Type
:: TypeDB = { functionmap :: Map FunctionLocation ExtendedType
, classmap :: Map ClassLocation ([TypeVar],[(FunctionName, ExtendedType)])
, classmap :: Map ClassLocation ([TypeVar],ClassContext,[(FunctionName, ExtendedType)])
, instancemap :: Map Class [Type]
, typemap :: Map TypeLocation TypeDef
}
......@@ -49,12 +49,21 @@ where
, te_isconstructor = False
}
instance print TypeExtras
where
print _ {te_priority=Nothing} = []
print b {te_priority=Just p} = print b p -- " "
instance print TE_Priority
where
print _ (LeftAssoc i) = "infixl " -- i
print _ (RightAssoc i) = "infixr " -- i
print _ (NoAssoc i) = "infix " -- i
instance print ExtendedType
where
print _ (ET t e) = " " -- e -- ":: " -- t
getFunction :: FunctionLocation TypeDB -> Maybe ExtendedType
getFunction loc {functionmap} = get loc functionmap
......@@ -91,35 +100,35 @@ putInstances c ts db = foldr (\t db -> putInstance c t db) db ts
putInstancess :: [(Class, [Type])] TypeDB -> TypeDB
putInstancess is db = foldr (\(c,ts) db -> putInstances c ts db) db is
getClass :: ClassLocation TypeDB -> Maybe ([TypeVar],[(FunctionName,ExtendedType)])
getClass :: ClassLocation TypeDB -> Maybe ([TypeVar],ClassContext,[(FunctionName,ExtendedType)])
getClass loc {classmap} = get loc classmap
putClass :: ClassLocation [TypeVar] [(FunctionName, ExtendedType)] TypeDB -> TypeDB
putClass cl tvs fs db=:{classmap} = {db & classmap = put cl (tvs,fs) classmap}
putClass :: ClassLocation [TypeVar] ClassContext [(FunctionName, ExtendedType)] TypeDB -> TypeDB
putClass cl tvs cc fs db=:{classmap} = {db & classmap = put cl (tvs,cc,fs) classmap}
putClasses :: [(ClassLocation, [TypeVar], [(FunctionName, ExtendedType)])] TypeDB -> TypeDB
putClasses cs db = foldr (\(cl,tvs,fs) db -> putClass cl tvs fs db) db cs
putClasses :: [(ClassLocation, [TypeVar], ClassContext, [(FunctionName, ExtendedType)])] TypeDB -> TypeDB
putClasses cs db = foldr (\(cl,tvs,cc,fs) db -> putClass cl tvs cc fs db) db cs
findClass :: Class TypeDB -> [(ClassLocation, [TypeVar], [(FunctionName, ExtendedType)])]
findClass c {classmap} = map (\(k,(x,y))->(k,x,y)) results
findClass :: Class TypeDB -> [(ClassLocation, [TypeVar], ClassContext, [(FunctionName, ExtendedType)])]
findClass c {classmap} = map (\(k,(x,y,z))->(k,x,y,z)) results
where results = toList $ filterWithKey (\(CL _ _ c`) _->c==c`) classmap
findClass` :: (ClassLocation [TypeVar] [(FunctionName,ExtendedType)] -> Bool) TypeDB
-> [(ClassLocation, [TypeVar], [(FunctionName,ExtendedType)])]
findClass` f {classmap} = map (\(k,(x,y))->(k,x,y)) results
where results = toList $ filterWithKey (\cl (vs,fs)->f cl vs fs) classmap
findClass` :: (ClassLocation [TypeVar] ClassContext [(FunctionName,ExtendedType)] -> Bool) TypeDB
-> [(ClassLocation, [TypeVar], ClassContext, [(FunctionName,ExtendedType)])]
findClass` f {classmap} = map (\(k,(x,y,z))->(k,x,y,z)) results
where results = toList $ filterWithKey (\cl (vs,cc,fs)->f cl vs cc fs) classmap
findClassMembers` :: (ClassLocation [TypeVar] FunctionName ExtendedType -> Bool) TypeDB
-> [(ClassLocation, [TypeVar], FunctionName, ExtendedType)]
findClassMembers` f {classmap} = filter (app4 f) $ flatten members
findClassMembers` :: (ClassLocation [TypeVar] ClassContext FunctionName ExtendedType -> Bool) TypeDB
-> [(ClassLocation, [TypeVar], ClassContext, FunctionName, ExtendedType)]
findClassMembers` f {classmap} = filter (app5 f) $ flatten members
where
members = map (\(cl,(vs,fs))->[(cl,vs,f,t) \\ (f,t)<-fs]) $ toList classmap
members = map (\(cl,(vs,cc,fs))->[(cl,vs,cc,f,t) \\ (f,t)<-fs]) $ toList classmap
findClassMembers`` :: [(ClassLocation [TypeVar] FunctionName ExtendedType -> Bool)]
TypeDB -> [(ClassLocation, [TypeVar], FunctionName, ExtendedType)]
findClassMembers`` fs {classmap} = foldr (filter o app4) all_members fs
findClassMembers`` :: [(ClassLocation [TypeVar] ClassContext FunctionName ExtendedType -> Bool)]
TypeDB -> [(ClassLocation, [TypeVar], ClassContext, FunctionName, ExtendedType)]
findClassMembers`` fs {classmap} = foldr (filter o app5) all_members fs
where
all_members = [(cl,vs,f,t) \\ (cl,(vs,fs)) <- toList classmap, (f,t) <- fs]
all_members = [(cl,vs,cc,f,t) \\ (cl,(vs,cc,fs)) <- toList classmap, (f,t) <- fs]
getType :: TypeLocation TypeDB -> Maybe TypeDef
getType loc {typemap} = get loc typemap
......@@ -152,4 +161,4 @@ openDb f
saveDb :: TypeDB *File -> *File
saveDb db f = fwrites (toString $ toJSON db) f
app4 f (a,b,c,d) :== f a b c d
app5 f (a,b,c,d,e) :== f a b c d e
......@@ -20,6 +20,10 @@ function getResults(str, page) {
return '<a class="hidden" title="Search :: ' + str + '" href="#' +
encodeURIComponent(':: ' + str) + '">' +
span + '</a>';
} else if (cls == 'classname') {
return '<a class="hidden" title="Search class ' + str + '" href="#' +
encodeURIComponent('class ' + str) + '">' +
span + '</a>';
} else {
return span;
}
......@@ -61,7 +65,7 @@ function getResults(str, page) {
switch (kind) {
case 'FunctionResult':
specificData = [];
var specificData = [];
if ('constructor_of' in specific) {
specificData.push([
'This function is a type constructor of <code>' +
......@@ -82,12 +86,44 @@ function getResults(str, page) {
);
return '<hr/>' +
makeTable(basicData.concat(specificData)) +
'<code>' + highlightFunction(specific['func'], highlightCallback) + '</code>';
'<code>' +
highlightFunction(specific['func'], highlightCallback) +
'</code>';
break;
case 'TypeResult':
return '<hr/>' +
makeTable(basicData) +
'<pre>' + highlightTypeDef(specific['type'], highlightCallback) + '</pre>';
'<pre>' +
highlightTypeDef(specific['type'], highlightCallback) +
'</pre>';
break;
case 'ClassResult':
var instances = '';
for (var i in specific['class_instances']) {
if (instances != '') {
instances += ', ';
}
instances += '<code>' +
highlightType(specific['class_instances'][i],
highlightCallback) +
'</code>'
}
var specificData = [
['Instances', instances]
];
var html = '<hr/>' +
makeTable(basicData.concat(specificData)) + '<pre>' +
highlightClassDef(
'class ' + specific['class_heading'] + ' where',
highlightCallback) +
'<br/>';
for (var i in specific['class_funs']) {
html += '<br/> ' +
highlightFunction(specific['class_funs'][i],
highlightCallback);
}
html += '</pre>';
return html;
break;
default:
return '';
......
......@@ -22,7 +22,9 @@ if($_SERVER['REQUEST_METHOD'] !== 'GET'){
$unify = isset($str[1]) ? trim($str[1]) : '';
$command = [];
if ($name != '') {
if (substr($name, 0, 6) == 'class ') {
$command['className'] = substr($name, 6);
} elseif ($name != '') {
$command['name'] = $name;
}
......
......@@ -30,8 +30,8 @@ from syntax import ::SymbolTable, ::SymbolTableEntry, ::Ident{..}, ::SymbolPtr,
::ParsedDefinition(PD_TypeSpec,PD_Instance,PD_Class,PD_Type),
::FunSpecials, ::Priority, ::ParsedModule, ::SymbolType,
::ParsedInstanceAndMembers{..}, ::ParsedInstance{pi_ident,pi_types},
::Type, ::ClassDef{class_ident,class_args}, ::TypeVar, ::ParsedTypeDef,
::TypeDef
::Type, ::ClassDef{class_ident,class_args,class_context},
::TypeVar, ::ParsedTypeDef, ::TypeDef
from scanner import ::Priority(..), ::Assoc(..)
from parse import wantModule
......@@ -190,13 +190,14 @@ where
\\ PD_Instance {pim_pi={pi_ident,pi_types}} <- pds]
pd_classes :: String String [ParsedDefinition]
-> [('DB'.ClassLocation, ['T'.TypeVar],
-> [('DB'.ClassLocation, ['T'.TypeVar], 'T'.ClassContext,
[('DB'.FunctionName, 'DB'.ExtendedType)])]
pd_classes lib mod pds
# pds = filter (\pd->case pd of (PD_Class _ _)=True; _=False) pds
= map (\(PD_Class {class_ident={id_name},class_args} pds)
= map (\(PD_Class {class_ident={id_name},class_args,class_context} pds)
-> let typespecs = pd_typespecs lib mod pds
in ('DB'.CL lib mod id_name, map 'T'.toTypeVar class_args,
flatten $ map 'T'.toClassContext class_context,
[(f,et) \\ ('DB'.FL _ _ f, et) <- typespecs])) pds
pd_types :: String String [ParsedDefinition]
......
......@@ -37,3 +37,8 @@
color: #932d1d;
font-weight: bold;
}
.keyword {
color: #333;
font-weight: bold;
}
function highlight(lex, istr) {
function highlight(lex, istr, start) {
var out = [];
for (var group in lex) {
......@@ -12,6 +12,9 @@ function highlight(lex, istr) {
var state_stack = [];
var state = 'start';
if (typeof start != 'undefined') {
state = start;
}
while (true) {
var found = false;
for (var i in lex[state]) {
......@@ -45,8 +48,8 @@ function highlight(lex, istr) {
}
}
function highlightToHTML(lex, istr, callback) {
var elems = highlight(lex, istr);
function highlightToHTML(lex, istr, callback, start) {
var elems = highlight(lex, istr, start);
var ostr = '';
for (var i in elems) {
var cls = elems[i]['class'];
......@@ -62,7 +65,7 @@ function highlightToHTML(lex, istr, callback) {
return ostr;
}
function highlightFunction(func, callback) {
function highlightFunction(func, callback, start) {
return highlightToHTML({
start: [
[/(\s+)/, ['whitespace']],
......@@ -92,10 +95,10 @@ function highlightFunction(func, callback) {
[/([,&])/, ['punctuation'], 'context'],
[/([^\s,]+)/, ['typevar']]
]
}, func, callback);
}, func, callback, start);
}
function highlightTypeDef(type, callback) {
function highlightTypeDef(type, callback, start) {
return highlightToHTML({
start: [
[/(::)/, ['punctuation'], 'name']
......@@ -171,7 +174,45 @@ function highlightTypeDef(type, callback) {
[/(\|)/, ['punctuation'], 'conses'],
[/(\W)/, ['punctuation']]
]
}, type, callback);
}, type, callback, start);
}
function highlightClassDef(cls, callback, start) {
return highlightToHTML({
start: [
[/(\s+)/, ['whitespace']],
[/(class)/, ['keyword'], 'className'],
[/(where)/, ['keyword']],
[/([a-z][\w`]*)/, ['typevar']],
[/(\|)/, ['punctuation'], 'context']
],
className: [
[/(\s+)/, ['whitespace']],
[/(\S+)/, ['classname'], 'pop']
],
context: [
[/(where)/, ['keyword']],
[/(\s+)/, ['whitespace']],
[/(,)/, ['punctuation']],
[/(\S+)(\{\|)/, ['generic', 'punctuation'], 'generic'],
[/([^\s{]+)(,)/, ['classname', 'punctuation']],
[/([^\s{]+)/, ['classname'], 'contextType']
],
generic: [
[/([*>-]+\|\},)/, ['punctuation'], 'pop'],
[/([*>-]+\|\})/, ['punctuation'], 'contextType']
],
contextType: [
[/(where)/, ['keyword']],
[/(\s+)/, ['whitespace']],
[/([,&])/, ['punctuation'], 'context'],
[/([^\s,]+)/, ['typevar']]
]
}, cls, callback, start);
}
function highlightType(type, callback) {
return highlightFunction(type, callback, 'type');
}
function escapeHTML(unsafe) {
......
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