Commit 94be5208 authored by Camil Staps's avatar Camil Staps 🚀

Added backend/ and frontend/; reorganisation; some cleanup

parents
CleanLevenshtein @ 34b88397
Subproject commit 34b88397b2d392a391e63c7fd3b924b045a61184
CleanTypeUnifier @ 445b766c
Subproject commit 445b766c1642d196670f9b419ed5e9e350f1353a
module CloogleServer
import StdArray, StdBool, StdFile, StdList, StdOrdList, StdOverloaded, StdTuple
from StdFunc import o, flip
from StdMisc import abort
from TCPIP import :: IPAddress, :: Port, instance toString IPAddress
from Data.Func import $
import Data.List
import Data.Maybe
import System.CommandLine
import Text.JSON
import Data.Functor
import Control.Applicative
import Control.Monad
from Text import class Text(concat,trim,indexOf,toLowerCase),
instance Text String, instance + String
import System.Time
import qualified StdMaybe as OldMaybe
from SimpleTCPServer import :: LogMessage{..}, serve, :: Logger
import qualified SimpleTCPServer
import TypeDB
import Type
import Levenshtein
:: OldMaybe a :== 'SimpleTCPServer'.Maybe a
:: Request = { unify :: Maybe String
, name :: Maybe String
, className :: Maybe String
, modules :: Maybe [String]
, page :: Maybe Int
}
:: Response = { return :: Int
, data :: [Result]
, msg :: String
, more_available :: Maybe Int
, suggestions :: Maybe [(Request, Int)]
}
:: Result = FunctionResult FunctionResult
| TypeResult TypeResult
| ClassResult ClassResult
:: BasicResult = { library :: String
, filename :: String
, modul :: String
, distance :: Int
}
:: FunctionResult :== (BasicResult, FunctionResultExtras)
:: FunctionResultExtras = { func :: String
, unifier :: Maybe StrUnifier
, cls :: Maybe ShortClassResult
, constructor_of :: Maybe String
, generic_derivations :: Maybe [String]
}
:: TypeResult :== (BasicResult, TypeResultExtras)
:: 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
:: ShortClassResult = { cls_name :: String, cls_vars :: [String] }
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
, className = Nothing
, modules = Nothing
, page = Nothing
}
instance toString Response where toString r = toString (toJSON r) + "\n"
instance toString Request where toString r = toString $ toJSON r
instance fromString (Maybe Request) where fromString s = fromJSON $ fromString s
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
basic (TypeResult (br,_)) = br
basic (ClassResult (br,_)) = br
err :: Int String -> Response
err c m = { return = c
, data = []
, msg = m
, more_available = Nothing
, suggestions = Nothing
}
E_NORESULTS :== 127
E_INVALIDINPUT :== 128
E_INVALIDNAME :== 129
E_INVALIDTYPE :== 130
MAX_RESULTS :== 15
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) ('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 Request) !*World -> *(!Response, !*World)
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_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
# drop_n = fromJust (page <|> pure 0) * MAX_RESULTS
# results = drop drop_n $ sort $ search request db
# more = max 0 (length results - MAX_RESULTS)
// Suggestions
# mbType = unify >>= parseType o fromString
# suggestions
= sortBy (\a b -> snd a > snd b) <$>
filter ((<)(length results) o snd) <$>
(mbType >>= \t -> suggs name t db)
# results = take MAX_RESULTS results
// Response
| isEmpty results = (err E_NORESULTS "No results", w)
= ( { return = 0
, msg = "Success"
, data = results
, more_available = Just more
, suggestions = suggestions
}
, w)
suggs :: !(Maybe String) !Type !TypeDB -> Maybe [(Request, Int)]
suggs n (Func is r cc) db
| length is < 3
= Just [let t` = concat $ print False $ Func is` r cc in
let request = {zero & name=n, unify=Just t`} in
(request, length $ search request db)
\\ is` <- permutations is | is` <> is]
suggs _ _ _ = Nothing
search :: !Request !TypeDB -> [Result]
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
, (\n loc _ -> isNameMatch (size n-2) n loc) <$> name
, isModMatchF <$> modules
]
# funs = map (\f -> makeFunctionResult name mbType Nothing f db) $ findFunction`` filts db
// Search class members
# 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
(Just {cls_name=cls,cls_vars=vs}) (FL lib mod f,et) db) members
// Search types
# lcTypeName = if (isJust mbType && isType (fromJust mbType))
(let (Type name _) = fromJust mbType in Just $ toLowerCase name)
(toLowerCase <$> name)
# types = case lcTypeName of
(Just n) = findType` (\(TL _ _ t) _ -> toLowerCase t == n) db
Nothing = []
# types = map (\(tl,td) -> makeTypeResult name tl td) types
// Search classes
# classes = case (isNothing mbType, toLowerCase <$> name) of
(True, Just c) = map (flip makeClassResult db) $
findClass` (\(CL _ _ c`) _ _ _ -> toLowerCase c` == c) db
_ = []
// Merge results
= sort $ funs ++ members ++ types ++ classes
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 = -100
}
, { class_name = cls
, class_heading = foldl ((+) o (flip (+) " ")) cls vars +
if (isEmpty cc) "" " " + concat (print False cc)
, class_funs = [concat $ print False fun \\ fun <- 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
( { library = lib
, filename = modToFilename mod
, modul = mod
, distance
= if (isNothing mbName) -100 (levenshtein` t (fromJust mbName))
}
, { type = concat $ print False td }
)
makeFunctionResult :: (Maybe String) (Maybe Type) (Maybe ShortClassResult)
(FunctionLocation, ExtendedType) TypeDB -> Result
makeFunctionResult
orgsearch orgsearchtype mbCls (FL lib mod fname, et=:(ET type tes)) db
= FunctionResult
( { library = lib
, filename = modToFilename mod
, modul = mod
, distance = distance
}
, { func = concat $ print False (fname,et)
, unifier = toStrUnifier <$> finish_unification <$>
(orgsearchtype >>= unify [] (prepare_unification False type))
, cls = mbCls
, constructor_of = if (tes.te_isconstructor)
(let (Func _ r _) = type in Just $ concat $ print False r)
Nothing
, generic_derivations
= let derivs = getDerivations fname db in
(\_ -> [concat $ print False d \\ d <-derivs]) <$>
tes.te_generic_vars
}
)
where
toStrUnifier :: Unifier -> StrUnifier
toStrUnifier (tvas1, tvas2) = (map toStr tvas1, map toStr tvas2)
where toStr (var, type) = (var, concat $ print False type)
toStrPriority :: (Maybe TE_Priority) -> String
toStrPriority p = case print False p of [] = ""; ss = concat [" ":ss]
distance
| isNothing orgsearch || fromJust orgsearch == ""
| isNothing orgsearchtype = 0
# orgsearchtype = fromJust orgsearchtype
# (Just (ass1, ass2)) = finish_unification <$>
unify [] orgsearchtype (prepare_unification False type)
= toInt $ sum [typeComplexity t \\ (_,t)<-ass1 ++ ass2 | not (isVar t)]
# orgsearch = fromJust orgsearch
= levenshtein` orgsearch fname
where
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
levenshtein` :: String String -> Int
levenshtein` a b = if (indexOf a b == -1) 0 -100 + levenshtein a b
modToFilename :: String -> String
modToFilename mod = (toString $ reverse $ takeWhile ((<>)'.')
$ reverse $ fromString mod) + ".dcl"
isUnifiable :: Type ExtendedType -> Bool
isUnifiable t1 (ET t2 _) = isJust (unify [] t1 (prepare_unification False 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
isModMatchF :: ![String] FunctionLocation ExtendedType -> Bool
isModMatchF mods (FL _ 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)
log msg s w
| not needslog = (newS msg s, w)
# (tm,w) = localTime w
# (io,w) = stdio w
# io = io <<< trim (toString tm) <<< " " <<< msgToString msg s
= (newS msg s, snd (fclose io w))
where
needslog = case msg of (Received _) = True; (Sent _) = True; _ = False
newS :: (LogMessage (Maybe Request) Response) IPAddress -> IPAddress
newS m s = case m of (Connected ip) = ip; _ = s
msgToString :: (LogMessage (Maybe Request) Response) IPAddress -> String
msgToString (Received Nothing) ip
= toString ip + " <-- Nothing\n"
msgToString (Received (Just a)) ip
= toString ip + " <-- " + toString a + "\n"
msgToString (Sent {return,data,msg,more_available}) ip
= toString ip + " --> " + toString (length data)
+ " results (" + toString return + "; " + msg +
if (isJust more_available) ("; " + toString (fromJust more_available) + " more") "" + ")\n"
msgToString _ _ = ""
# Installation:
# docker build -t cloogle .
#
# Usage:
# docker run \
# -d \
# --net=host \
# --name=cloogle \
# -v /path/to/cloogle/cloogle.log:/usr/src/cloogle/cloogle.log \
# cloogle
FROM camilstaps/clean:2.4-itasks
COPY . /usr/src/cloogle
WORKDIR /usr/src/cloogle
RUN make
EXPOSE 31215
ENTRYPOINT "./serve"
CMD []
BIN:=CloogleServer builddb
PRJ:=$(addsuffix .prj,$(BIN))
DB=types.json
MAN:=builddb.1 # Others don't have --help/--version # $(addsuffix .1,$(BIN))
CPM:=cpm
SED:=sed
.SECONDARY: $(PRJ)
.PHONY: all
all: $(BIN) $(DB)
man: $(MAN)
%.1: %
help2man -N ./$< > $@
%: %.prj
$(CPM) $< \
| grep -v "^Analyzing" \
| grep -v "^Warning: Unable to setup directory cache"
%.prj:
$(CPM) project $(basename $@) create
$(SED) -i 's/\(Target:[ \t]\+\)StdEnv/\1CleanPlatform/' $@
$(SED) -i 's/[ \t]\+Path:[ \t]\+{Project}/&\n&\/CleanLevenshtein\n&\/CleanTypeUnifier\n&\/CleanTypeUnifier\/clean-compiler\/main\/\n&\/CleanTypeUnifier\/clean-compiler\/frontend\/\n&\/CleanTypeUnifier\/clean-compiler\/backend\/\n&\/CleanTypeUnifier\/clean-compiler\/main\/Unix\//' $@
$(SED) -i 's/\([ \t]\+Path:[ \t]\+\){Project}$$/&\n\1{Application}\/lib\/ArgEnv\/\n\1{Application}\/lib\/TCPIP\//' $@
$(SED) -i 's/\($(basename $@)\).exe/\1/' $@
$(SED) -i 's/\(Output:[ \t]\+\)ShowConstructors/\1NoConsole/' $@
$(SED) -i 's/\(HeapSize:[ \t]\+\)2097152/\141943040/' $@
$(DB): builddb
./builddb > $(DB)
clean:
$(RM) -r 'Clean System Files' $(BIN) $(PRJ) $(MAN) $(DB)
definition module SimpleTCPServer
from StdOverloaded import class zero, class fromString, class toString
from StdMaybe 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
import System._Posix
TIMEOUT :== Just 5000
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 +++ "\n")
# listener = fromJust mbListener
# log = if (isNothing log) zero (fromJust log)
# (_,w) = signal 17 1 w // SIGCHLD, SIG_IGN: no notification if child ps dies
# (listener, w) = loop f log listener w
= closeRChannel listener w
where
loop :: (a *World -> *(b,*World)) (Logger a b s) TCP_Listener *World
-> (TCP_Listener, *World) | fromString a & toString b
loop f log li w
#! ((ip,dupChan),li,w) = receive li w
#! (st,w) = log (Connected ip) undef w
# (pid,w) = fork w
| pid < 0
= abort "fork failed\n"
| pid > 0
// Parent: handle new requests
= loop f log li w
// Child: handle current request
= handle f log st dupChan w
handle :: (a *World-> (b,*World)) (Logger a b s) !s !TCP_DuplexChannel !*World
-> (TCP_Listener, *World) | fromString a & toString b
handle f log st dupChannel=:{rChannel,sChannel} w
# (tRep,msg,rChannel,w) = receive_MT TIMEOUT rChannel w
| tRep <> TR_Success
# (st,w) = log Disconnected st w
# w = closeChannel sChannel (closeRChannel rChannel w)
= exit 0 w
# msg = fromString (toString (fromJust msg))
# (st, w) = log (Received msg) st w
# (resp, w) = f msg w
# (sChannel, w) = send (toByteSeq (toString resp)) sChannel w
# (st, w) = log (Sent resp) st w
= handle f log st {dupChannel & rChannel=rChannel, sChannel=sChannel} w
signal :: !Int !Int !*World -> *(!Int, !*World)
signal signum handler w = code {
ccall signal "II:I:A"
}
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, ::TypeDef, class print(..),
::ClassContext, ::ClassRestriction, ::ClassOrGeneric
:: TypeDB
instance zero TypeDB
derive gEq TypeDB
:: FunctionLocation = FL Library Module FunctionName
instance print FunctionLocation
:: TypeExtras = { te_priority :: Maybe TE_Priority
, te_isconstructor :: Bool
, te_generic_vars :: Maybe [TypeVar]
}
instance zero TypeExtras
:: TE_Priority = LeftAssoc Int | RightAssoc Int | NoAssoc Int
instance print TE_Priority
:: ExtendedType = ET Type TypeExtras
instance print (FunctionName, ExtendedType)
:: ClassLocation = CL Library Module Class
:: Library :== String
:: Module :== String
:: FunctionName :== String
:: Class :== String
:: GenericName :== String
:: TypeLocation = TL Library Module TypeName
:: TypeName :== String
getFunction :: FunctionLocation TypeDB -> Maybe ExtendedType
putFunction :: FunctionLocation ExtendedType TypeDB -> TypeDB
putFunctions :: [(FunctionLocation, ExtendedType)] TypeDB -> TypeDB
findFunction :: FunctionName TypeDB -> [(FunctionLocation, ExtendedType)]
findFunction` :: (FunctionLocation ExtendedType -> Bool) TypeDB
-> [(FunctionLocation, ExtendedType)]
findFunction`` :: [(FunctionLocation ExtendedType -> Bool)] TypeDB
-> [(FunctionLocation, ExtendedType)]
getInstances :: Class TypeDB -> [Type]
putInstance :: Class Type TypeDB -> TypeDB
putInstances :: Class [Type] TypeDB -> TypeDB
putInstancess :: [(Class, [Type])] TypeDB -> TypeDB
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
putTypes :: [(TypeLocation, TypeDef)] TypeDB -> TypeDB
findType :: TypeName TypeDB -> [(TypeLocation, TypeDef)]
findType` :: (TypeLocation TypeDef -> Bool) TypeDB
-> [(TypeLocation, TypeDef)]
getDerivations :: GenericName TypeDB -> [Type]
putDerivation :: GenericName Type TypeDB -> TypeDB
putDerivations :: GenericName [Type] TypeDB -> TypeDB
putDerivationss :: [(GenericName, [Type])] TypeDB -> TypeDB
searchExact :: Type TypeDB -> [(FunctionLocation, ExtendedType)]
newDb :: TypeDB
openDb :: *File -> *(Maybe TypeDB, *File)
saveDb :: TypeDB *File -> *File
implementation module TypeDB
// Standard libraries
import StdEnv
from Data.Func import $
from Data.List import intercalate
import Data.Map
import Data.Maybe
import Text.JSON
// CleanTypeUnifier
import Type
:: TypeDB
= { functionmap :: Map FunctionLocation ExtendedType
, classmap :: Map ClassLocation ([TypeVar],ClassContext,[(FunctionName, ExtendedType)])
, instancemap :: Map Class [Type]
, typemap :: Map TypeLocation TypeDef
, derivemap :: Map GenericName [Type]
}
printersperse :: Bool a [b] -> [String] | print a & print b
printersperse ia a bs = intercalate (print False a) (map (print ia) bs)
(--) infixr 5 :: a b -> [String] | print a & print b
(--) a b = print False a ++ print False b