Commit 411151ed authored by Mart Lubbers's avatar Mart Lubbers
Browse files

Merge branch 'types'

Conflicts:
	api.js
parents b237a8f7 fcad4758
......@@ -8,3 +8,8 @@ StdEnv
StdLib
TCPIP
clean-platform
Clean System Files/
search
builddb
CloogleServer
[submodule "CleanTypeUnifier"]
path = CleanTypeUnifier
url = https://github.com/camilstaps/CleanTypeUnifier
[submodule "CleanLevenshtein"]
path = CleanLevenshtein
url = https://github.com/camilstaps/CleanLevenshtein
Subproject commit 34b88397b2d392a391e63c7fd3b924b045a61184
Subproject commit d477cee1eef4b24ff2ad4be74b3a2f8d11ed06bf
module CloogleServer
import StdString, StdArray, StdList, StdFile, StdTuple, StdMisc, StdOrdList, StdBool
from StdFunc import o
import TCPIP
from Data.Func import $
import Data.Maybe
import System.CommandLine
import Text
import Text.JSON
import Data.Functor
import Control.Applicative
from Control.Monad import class Monad(..)
import SimpleTCPServer
import TypeDB
import Type
import Levenshtein
:: Command = { unify :: String
, name :: String
}
:: Response = { return :: Int
, data :: [Result]
, msg :: String
}
:: Result = { library :: String
, filename :: String
, func :: String
, modul :: String
, distance :: Int
}
derive JSONEncode Command, Response, Result
derive JSONDecode Command, Response, Result
instance toString Response where toString r = toString $ toJSON r
instance toString Command where toString r = toString $ toJSON r
instance fromString (Maybe Command) where fromString s = fromJSON $ fromString s
instance < Result where (<) r1 r2 = r1.distance < r2.distance
err :: Int String -> Response
err c m = {return=c, data=[], msg=m}
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"
# db = fromJust db
= serve (handle db) (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 = map (makeResult name mbType) $ findType`` filters db
= ({return=0,msg="Success",data=sort 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 (print type)
, distance = distance
}
where
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 _ _ = ""
This diff is collapsed.
# cloogle
A clean hoogle clone. Use at your own risk. Live version available
[here](http://martlubbers.net/cloogle)
A Clean hoogle clone. Use at your own risk. Live version available
[here](http://cloogle.org/).
### Current features
- Search for function/operator/class names.
- Search for function types.
### How to setup
- The frontend heavily depends on [VanillaJS](http://vanilla-js.com/) so you
should have a webbrowsers that supports it.
- Put a folder containing `StdEnv` in a directory called `stdenv` in the same
directory as the code. You can also change the `STDENV_PATH` variable which
is set in `api.php` if you want it loaded from somewhere else.
should have a webbrowsers that supports it.
- Set the list of libraries and `CLEAN_LIB` in `builddb.icl`. Then build
`builddb.prj` and run it:
$ cpm project builddb.prj build
$ ./builddb -h 10M > types.db
This creates a file `types.db` which holds the internal database of functions
and their types. If you later add new libraries, you need to rerun `builddb`.
- You can then build and run the Clean backend with:
$ cpm project CloogleServer.prj build
$ ./CloogleServer -h 10M 31215 < types.db
In this example, the server uses port 31215. You need to use the same
settings in `api.php`.
Leave the `CloogleServer` running. When a HTTP request for `api.php` is made,
that PHP script will communicate with the Clean backend server.
You may want to consider running the backend server in a sandbox or with
limited permissions.
### Api specification for developers
`api.php` should be called with a `GET` request where the `str` variable
contains the search string. The api will return a JSON formatted datastructure
containing the following fields
contains the search string. The api will return a JSON formatted data structure
containing the following fields:
- `return`
Return code, `0` for success, `1` for wrongly called api, `127` for no
results.
Return code:
* `0`: success
* `1`: invalid request type (should use GET)
* `2`: no input (GET variable `str` should be set to the search string)
* `3`: the Clean backend could not be reached
* `4`: ununderstandable input (usually shouldn't happen)
- `msg`
A human friendly message representing the return code.
- `data`
An array of search results. Every items contains the following fields:
`library`, `filename`, `module`, `func` and `distance` representing the name
of the library, filename, the module name, the matched function signature and
the levenshtein distance.
`library`, `filename`, `modul` (not a typo), `func` and `distance`
representing the name of the library, filename, the module name, the matched
function signature and some loosely defined distance to the search string.
### Todo in order of importance
- Search on type definitions
- Search for function signatures
- Also grab possible comments above the function signature
- Search also in `clean-platform`
- Search for instances of classes
### Licence
......
definition module SimpleTCPServer
from StdOverloaded import class zero, class fromString, class toString
from Data.Maybe import ::Maybe
from TCPIP import ::IPAddress, ::Port
:: LogMessage a b = Connected IPAddress
| Received a
| Sent b
| Disconnected
:: Logger a b s :== (LogMessage a b) s *World -> *(s, *World)
serve :: (a *World -> *(b,*World)) (Maybe (Logger a b s)) Port *World
-> *World | fromString a & toString b
implementation module SimpleTCPServer
import TCPIP
import StdEnv
import StdMaybe
instance zero (Logger a b s) where zero = \_ _ w -> (undef, w)
serve :: (a *World -> *(b,*World)) (Maybe (Logger a b s)) Port *World
-> *World | fromString a & toString b
serve f log port w
# (ok, mbListener, w) = openTCP_Listener port w
| not ok = abort ("Couldn't open port " +++ toString port)
# listener = fromJust mbListener
# log = if (isNothing log) zero (fromJust log)
# (listener, w) = handle f log listener w
= closeRChannel listener w
where
handle :: (a *World -> *(b,*World)) (Logger a b s) TCP_Listener *World
-> (TCP_Listener, *World) | fromString a & toString b
handle f log li w
# ((ip, dupChan),li,w) = receive li w
# (s, w) = log (Connected ip) undef w
# (msg, rChan, w) = receive dupChan.rChannel w
dupChan = {dupChan & rChannel=rChan}
# msg = fromString (toString msg)
# (s, w) = log (Received msg) s w
# (resp, w) = f msg w
# (sChan, w) = send (toByteSeq (toString resp)) dupChan.sChannel w
dupChan = {dupChan & sChannel=sChan}
# (s, w) = log (Sent resp) s w
# w = closeRChannel dupChan.rChannel w
# w = closeChannel dupChan.sChannel w
# (s, w) = log Disconnected s w
= handle f log li w
definition module TypeDB
// Standard libraries
from StdOverloaded import class <, class zero
from StdClass import class Ord
from Data.Map import ::Map
from Data.Maybe import ::Maybe
from GenEq import generic gEq
// CleanTypeUnifier
from Type import ::Type, ::TypeVar, ::TVAssignment, class print(..)
:: TypeDB
instance zero TypeDB
derive gEq TypeDB
:: FunctionLocation = FL Library Module FunctionName
instance < FunctionLocation
instance print FunctionLocation
:: ClassLocation = CL Library Module Class
:: Library :== String
:: Module :== String
:: FunctionName :== String
:: Class :== String
getType :: FunctionLocation TypeDB -> Maybe Type
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)]
getInstances :: Class TypeDB -> [Type]
putInstance :: Class Type TypeDB -> TypeDB
putInstances :: Class [Type] TypeDB -> TypeDB
putInstancess :: [(Class, [Type])] TypeDB -> TypeDB
getClass :: ClassLocation TypeDB -> Maybe ([TypeVar],[(FunctionName,Type)])
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)])]
searchExact :: Type TypeDB -> [(FunctionLocation, Type)]
searchUnifiable :: Type TypeDB
-> [(FunctionLocation, Type, [TVAssignment], [TVAssignment])]
newDb :: TypeDB
openDb :: *File -> *(Maybe TypeDB, *File)
saveDb :: TypeDB *File -> *File
implementation module TypeDB
// Standard libraries
import StdEnv
from Data.Func import $
import Data.Map
import Data.Maybe
import Text.JSON
// CleanTypeUnifier
import Type
:: TypeDB = { typemap :: Map FunctionLocation Type
, classmap :: Map ClassLocation ([TypeVar],[(FunctionName, Type)])
, instancemap :: Map Class [Type]
}
(<+) infixr 5 :: a b -> [String] | print a & print b
(<+) a b = print a ++ print b
derive gEq ClassOrGeneric, FunctionLocation, ClassLocation, Type, TypeDB
derive JSONEncode ClassOrGeneric, FunctionLocation, ClassLocation, Type, TypeDB
derive JSONDecode ClassOrGeneric, FunctionLocation, ClassLocation, Type, TypeDB
instance zero TypeDB where zero = { typemap = newMap
, classmap = newMap
, instancemap = newMap
}
instance < FunctionLocation where (<) (FL a b c) (FL d e f) = (a,b,c) < (d,e,f)
instance print FunctionLocation
where print (FL lib mod fn) = fn <+ " in " <+ mod <+ " in " <+ lib
instance < ClassLocation where (<) (CL a b c) (CL d e f) = (a,b,c) < (d,e,f)
getType :: FunctionLocation TypeDB -> Maybe Type
getType loc {typemap} = get loc typemap
putType :: FunctionLocation Type TypeDB -> TypeDB
putType fl t tdb=:{typemap} = { tdb & typemap = put fl t typemap }
putTypes :: [(FunctionLocation, Type)] TypeDB -> TypeDB
putTypes ts tdb = foldr (\(loc,t) db -> putType loc t db) tdb ts
findType :: FunctionName TypeDB -> [(FunctionLocation, Type)]
findType f db=:{typemap} = toList $ filterWithKey (\(FL _ _ f`) _->f==f`) typemap
findType` :: (FunctionLocation Type -> Bool) TypeDB -> [(FunctionLocation, Type)]
findType` f {typemap} = toList $ filterWithKey f typemap
findType`` :: [(FunctionLocation Type -> Bool)] TypeDB -> [(FunctionLocation, Type)]
findType`` fs {typemap} = toList $ foldr filterWithKey typemap fs
getInstances :: Class TypeDB -> [Type]
getInstances c {instancemap} = if (isNothing ts) [] (fromJust ts)
where ts = get c instancemap
putInstance :: Class Type TypeDB -> TypeDB
putInstance c t db=:{instancemap} = {db & instancemap=put c ts instancemap}
where
ts = removeDup [t : getInstances c db]
putInstances :: Class [Type] TypeDB -> TypeDB
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,Type)])
getClass loc {classmap} = get loc classmap
putClass :: ClassLocation [TypeVar] [(FunctionName, Type)] TypeDB -> TypeDB
putClass cl tvs fs db=:{classmap} = {db & classmap = put cl (tvs,fs) classmap}
putClasses :: [(ClassLocation, [TypeVar], [(FunctionName, Type)])] TypeDB -> TypeDB
putClasses cs db = foldr (\(cl,tvs,fs) db -> putClass cl tvs fs db) db cs
findClass :: Class TypeDB -> [(ClassLocation, [TypeVar], [(FunctionName, Type)])]
findClass c {classmap} = map (\(k,(x,y))->(k,x,y)) results
where
results = toList $ filterWithKey (\(CL _ _ c`) _->c==c`) classmap
findClass` :: (ClassLocation [TypeVar] [(FunctionName,Type)] -> Bool) TypeDB
-> [(ClassLocation, [TypeVar], [(FunctionName, Type)])]
findClass` f {classmap} = map (\(k,(x,y))->(k,x,y)) results
where
results = toList $ filterWithKey (\cl (vs,fs)->f cl vs fs) classmap
searchExact :: Type TypeDB -> [(FunctionLocation, Type)]
searchExact t db = filter ((==)t o snd) $ toList db.typemap
searchUnifiable :: Type TypeDB
-> [(FunctionLocation, Type, [TVAssignment], [TVAssignment])]
searchUnifiable t db = search` $ toList db.typemap
where
search` :: [(FunctionLocation,Type)]
-> [(FunctionLocation,Type,[TVAssignment],[TVAssignment])]
search` [] = []
search` [(l,t`):list]
# tvas = unify [] t t`
| isNothing tvas = search` list
# (tvas1,tvas2) = fromJust tvas
= [(l,t`,tvas1,tvas2):search` list]
newDb :: TypeDB
newDb = zero
openDb :: *File -> *(Maybe TypeDB, *File)
openDb f
# (data, f) = freadline f
= (fromJSON $ fromString data, f)
saveDb :: TypeDB *File -> *File
saveDb db f = fwrites (toString $ toJSON db) f
......@@ -65,11 +65,9 @@ function formsubmit(){
sresults.innerHTML = 'Proccessing...';
var str = encodeURIComponent(form_str.value);
var url = 'api.php?str=' + str;
console.log('Apicall: ' + url);
var xmlHttp = new XMLHttpRequest();
xmlHttp.onreadystatechange = function() {
if(xmlHttp.readyState == 4 && xmlHttp.status == 200){
console.log('Response: ' + xmlHttp.responseText);
var responsedata = JSON.parse(xmlHttp.responseText);
sresults.innerHTML =
'<p>Return code: ' + responsedata['return'] + '</p>' +
......@@ -80,7 +78,7 @@ function formsubmit(){
sresults.innerHTML += '<hr /><table>' +
'<tr><th>Library: </th><td>' + c['library'] + '</td></tr>' +
'<tr><th>Filename: </th><td>' + c['filename'] + '</td></tr>' +
'<tr><th>Module: </th><td>' + c['module'] + '</td>' +
'<tr><th>Module: </th><td>' + c['modul'] + '</td>' +
'<td>' + c['distance'] + '</td></tr>' +
'</table>' +
'<code>' + highlight(c['func']) + '</code>';
......@@ -100,8 +98,9 @@ window.onload = function(){
var str = document.location.hash;
if(str !== ''){
str = str.substring(1);
console.log('Detected hash, setting searchstring to ' + str);
form_str.value = decodeURIComponent(str);
formsubmit();
}
document.getElementById('search_str').focus();
}
......@@ -2,52 +2,8 @@
error_reporting(E_ALL);
ini_set('display_errors', '1');
define('PRE_IDENT', '[\w~@#$%^?!+\-*<>\/|&=:`]+');
define('PRE_MODULE',
"/\s*(?:definition\s*|system\s*|implementation\s*)module\s+([\w.]+)\s*[\n;]/");
define('PRE_FUNC',
'/^(?:\\/\\/)?\s*(?:instance|class)?\s*\(?(' . PRE_IDENT . ')\)?\s*(?:infix[lr]?\s+\d\s*(?:\\/\\/)?)?(?:\s+a\s+)?::.*$/mi');
function search_doc(&$r, $name, $libraries){
foreach($libraries as $library => $librarypath){
$files = glob($librarypath . "*.dcl", GLOB_NOSORT | GLOB_MARK);
foreach($files as $filepath) {
if(mb_substr($filepath, -1) !== DIRECTORY_SEPARATOR){
$filename = end(explode(DIRECTORY_SEPARATOR, $filepath));
$contents = file_get_contents($filepath);
$module = preg_match(PRE_MODULE, $contents, $modules) == 1 ?
$modules[1] : NULL;
if(preg_match_all(PRE_FUNC, $contents, $funcs) !== false){
for($i=0; $i<count($funcs[1]); $i++){
$funcname = $funcs[1][$i];
$funcsig = $funcs[0][$i];
$lowername = strtolower($name);
$lowerfuncname = strtolower($funcname);
if(strstr($lowerfuncname, $lowername) !== FALSE){
$score = -100+levenshtein($lowername, $lowerfuncname);
} else {
$score = levenshtein($lowername, $lowerfuncname);
}
if($score < 3){
array_push($r, array(
"library" => $library,
"filename" => $filename,
"func" => str_replace("\n", "", $funcsig),
"module" => $module,
"distance" => $score));
}
}
}
}
}
}
return "Success";
}
function sort_results(&$r, $by='distance'){
usort($r, function($a, $b) use ($by) { return $a[$by] > $b[$by]; });
}
define('SERVER_HOSTNAME', 'localhost');
define('SERVER_PORT', 31215);
if($_SERVER['REQUEST_METHOD'] !== 'GET'){
echo json_encode(array(
......@@ -60,87 +16,23 @@ if($_SERVER['REQUEST_METHOD'] !== 'GET'){
"data" => array(),
"msg" => "GET variable 'str' should be set"));
} else {
$libraries = array(
'ArgEnv' => './ArgEnv/',
'Directory' => './Directory/',
'Dynamics' => './Dynamics/',
'Generics' => './Generics/',
'MersenneTwister' => './MersenneTwister/',
'StdEnv' => './StdEnv/',
'StdLib' => './StdLib/',
'TCPIP' => './TCPIP/',
'cleanplatform:OS-Linux-64' =>'./clean-platform/OS-Linux-64/',
'cleanplatform:OS-Linux-64/System' =>'./clean-platform/OS-Linux-64/System/',
'cleanplatform:OS-Linux-64/Database' =>'./clean-platform/OS-Linux-64/Database/',
'cleanplatform:OS-Linux-64/Database/SQL' =>'./clean-platform/OS-Linux-64/Database/SQL/',
'cleanplatform:OS-Mac' =>'./clean-platform/OS-Mac/',
'cleanplatform:OS-Mac/System' =>'./clean-platform/OS-Mac/System/',
'cleanplatform:OS-Mac/Database' =>'./clean-platform/OS-Mac/Database/',
'cleanplatform:OS-Mac/Database/SQL' =>'./clean-platform/OS-Mac/Database/SQL/',
'cleanplatform:OS-Mac/Network' =>'./clean-platform/OS-Mac/Network/',
'cleanplatform:OS-Linux-32' =>'./clean-platform/OS-Linux-32/',
'cleanplatform:OS-Linux-32/System' =>'./clean-platform/OS-Linux-32/System/',
'cleanplatform:OS-Windows-64' =>'./clean-platform/OS-Windows-64/',
'cleanplatform:OS-Windows-64/System' =>'./clean-platform/OS-Windows-64/System/',
'cleanplatform:OS-Linux' =>'./clean-platform/OS-Linux/',
'cleanplatform:OS-Linux/System' =>'./clean-platform/OS-Linux/System/',
'cleanplatform:OS-Linux/Network' =>'./clean-platform/OS-Linux/Network/',
'cleanplatform:OS-Posix' =>'./clean-platform/OS-Posix/',
'cleanplatform:OS-Posix/System' =>'./clean-platform/OS-Posix/System/',
'cleanplatform:OS-Posix/Network' =>'./clean-platform/OS-Posix/Network/',
'cleanplatform:OS-Posix/DataSources' =>'./clean-platform/OS-Posix/DataSources/',
'cleanplatform:OS-Windows-32' =>'./clean-platform/OS-Windows-32/',
'cleanplatform:OS-Windows-32/System' =>'./clean-platform/OS-Windows-32/System/',
'cleanplatform:OS-Windows' =>'./clean-platform/OS-Windows/',
'cleanplatform:OS-Windows/System' =>'./clean-platform/OS-Windows/System/',
'cleanplatform:OS-Windows/Database' =>'./clean-platform/OS-Windows/Database/',
'cleanplatform:OS-Windows/Database/SQL' =>'./clean-platform/OS-Windows/Database/SQL/',