Verified Commit cb36b33e authored by Camil Staps's avatar Camil Staps 🐟

Use new functions from cloogle core

parent 0a8ac007
Subproject commit a06d99e0964bb6d20022140780dec7999fd0626c
Subproject commit 669fdc17cba570ef140de8ee2cb7e104671c3705
......@@ -3,45 +3,37 @@ module CloogleServer
import StdArray
import StdBool
import StdFile
import StdList
from StdFunc import o, seq
from StdMisc import abort, undef
import StdOrdList
import StdOverloaded
import StdString
import StdTuple
from StdFunc import const, flip, id, o, seq
from StdMisc import abort, undef
from TCPIP import :: IPAddress, :: Port, instance toString IPAddress
import Control.Applicative
import Control.Monad
import qualified Data.Foldable as Foldable
from Data.Foldable import class Foldable, instance Foldable Maybe
from Data.Func import $
import Data.Functor
import Data.List
import Data.Maybe
import Data.Tuple
import System.CommandLine
from Text import class Text(concat,trim,indexOf,toLowerCase,split),
instance Text String, instance + String
from Text import class Text(concat), instance Text String
import Text.JSON
import System.Time
from SimpleTCPServer import :: LogMessage{..}, serve, :: Logger
import qualified SimpleTCPServer
import TypeDB
import Type
import Cache
import Cloogle
import Type
import TypeDB
import Search
MAX_RESULTS :== 15
CACHE_PREFETCH :== 5
DEFAULT_INCLUDE_BUILTINS :== True
DEFAULT_INCLUDE_CORE :== False
:: RequestCacheKey
= { c_unify :: Maybe Type
, c_name :: Maybe String
......@@ -161,313 +153,6 @@ where
\\ is` <- permutations is | is` <> is]
suggs _ _ _ = Nothing
search :: !Request !TypeDB -> [Result]
search {unify,name,className,typeName,modules,libraries,page,include_builtins,include_core} db_org
# include_builtins = fromJust (include_builtins <|> Just DEFAULT_INCLUDE_BUILTINS)
# include_core = fromJust (include_core <|> Just DEFAULT_INCLUDE_CORE)
# db = db_org
# db = case libraries of
(Just ls) = filterLocations (isLibMatch ls) db
Nothing = db
# db = case modules of
(Just ms) = filterLocations (isModMatch ms) db
Nothing = db
# db = if include_builtins id (filterLocations (not o isBuiltin)) db
# db = if include_core id (filterLocations (not o isCore)) db
with
isCore :: Location -> Bool
isCore (Builtin _) = False
isCore (Location lib mod _ _ _) = case getModule lib mod db of
Nothing = False
(Just b) = b.is_core
| isJust className
# className = fromJust className
# classes = findClass className db
= map (flip makeClassResult db) classes
| isJust typeName
# typeName = fromJust typeName
# types = findType typeName db
= [makeTypeResult (Just typeName) l td db \\ (l,td) <- types]
# mbPreppedType = prepare_unification True (allTypes db_org)
<$> (unify >>= parseType o fromString)
# usedSynonyms = 'Foldable'.concat (fst <$> mbPreppedType)
# mbType = snd <$> mbPreppedType
// Search normal functions
# filts = catMaybes [ (\t _ -> isUnifiable t db_org) <$> mbType
, (\n loc _ -> isNameMatch (size n*2/3) n $ getName loc) <$> name
]
# funs = map (\f -> makeFunctionResult name mbType usedSynonyms Nothing f db_org) $ findFunction`` filts db
// Search macros
# macros = case (isNothing mbType,name) of
(True,Just n) = findMacro` (\loc _ -> isNameMatch (size n*2/3) n $ getName loc) db
_ = []
# macros = map (\(lhs,rhs) -> makeMacroResult name lhs rhs) macros
// Search class members
# filts = catMaybes [ (\t _ _ _ _ -> isUnifiable t db_org) <$> mbType
, (\n (Location lib mod _ _ _) _ _ f _ -> isNameMatch
(size n*2/3) n f) <$> name
]
# members = findClassMembers`` filts db
# members = map (\(Location lib mod line iclline cls,vs,_,f,et) -> makeFunctionResult name mbType usedSynonyms
(Just {cls_name=cls,cls_vars=vs}) (Location lib mod line iclline f,et) db) members
// Search types
# lcName = if (isJust mbType && isType (fromJust mbType))
(let (Type name _) = fromJust mbType in Just $ toLowerCase name)
(toLowerCase <$> name)
# types = case (mbType,lcName) of
(Nothing, Just n) = findType` (\loc _ -> toLowerCase (getName loc) == n) db
(Just (Type n _),_) = findType n db
(Just _, _) = []
# types = map (\(tl,td) -> makeTypeResult name tl td db) types
// Search classes
# classes = case (isNothing mbType, toLowerCase <$> name) of
(True, Just c) = findClass` (\loc _ _ _ -> toLowerCase (getName loc) == c) db
_ = []
# classes = map (flip makeClassResult db) classes
// Search modules
# modules = case (mbType, name) of
(Nothing, Just n) = findModule` (\_ m _ -> isModNameMatch (size n*2/3) n m) db
_ = []
# modules = map (makeModuleResult name) modules
// Merge results
= sort $ funs ++ members ++ types ++ classes ++ macros ++ modules
makeModuleResult :: (Maybe String) (Library, Module, ModuleInfo) -> Result
makeModuleResult mbName (lib, mod, info)
= ModuleResult
( { library = lib
, modul = mod
, filename = modToFilename mod
, dcl_line = Nothing
, icl_line = Nothing
, distance = modLevenshtein (fromJust mbName) mod
, builtin = Nothing
}
, { module_is_core = info.is_core
}
)
makeClassResult :: (Location, [TypeVar], ClassContext, [(Name,ExtendedType)])
TypeDB -> Result
makeClassResult rec=:(Builtin _, _, _, _) db
= ClassResult
( { library = ""
, filename = ""
, dcl_line = Nothing
, icl_line = Nothing
, modul = ""
, distance = -100
, builtin = Just True
}
, makeClassResultExtras rec db
)
makeClassResult rec=:(Location lib mod line iclline cls, vars, cc, funs) db
= ClassResult
( { library = lib
, filename = modToFilename mod
, dcl_line = line
, icl_line = iclline
, modul = mod
, distance = -100
, builtin = Nothing
}
, makeClassResultExtras rec db
)
makeClassResultExtras :: (Location, [TypeVar], ClassContext, [(Name,ExtendedType)])
TypeDB -> ClassResultExtras
makeClassResultExtras (l, vars, cc, funs) db
= { class_name = cls
, class_heading = foldl ((+) o (flip (+) " ")) cls vars +
if (isEmpty cc) "" " | " + concat (print False cc)
, class_funs = [print_fun fun \\ fun <- funs]
, class_instances
= sortBy (\(a,_) (b,_) -> a < b)
[(map snd ts, map loc ls) \\ (ts,ls) <- getInstances cls db]
}
where
cls = case l of
Builtin c = c
Location _ _ _ _ c = c
print_fun :: (Name,ExtendedType) -> String
print_fun f=:(_,ET _ et) = fromJust $
et.te_representation <|> (pure $ concat $ print False f)
makeTypeResult :: (Maybe String) Location TypeDef TypeDB -> Result
makeTypeResult mbName (Location lib mod line iclline t) td db
= TypeResult
( { library = lib
, filename = modToFilename mod
, dcl_line = line
, icl_line = iclline
, modul = mod
, distance
= if (isNothing mbName) -100 (levenshtein` t (fromJust mbName))
, builtin = Nothing
}
, { type = concat $ print False td
, type_instances = map (appSnd3 (map snd)) $
map (appThd3 (map loc)) $ getTypeInstances t db
, type_derivations = map (appSnd (map loc)) $ getTypeDerivations t db
}
)
makeTypeResult mbName (Builtin t) td db
= TypeResult
( { library = ""
, filename = ""
, dcl_line = Nothing
, icl_line = Nothing
, modul = ""
, distance
= if (isNothing mbName) -100 (levenshtein` t (fromJust mbName))
, builtin = Just True
}
, { type = concat $ print False td
, type_instances = map (appSnd3 (map snd)) $
map (appThd3 (map loc)) $ getTypeInstances t db
, type_derivations = map (appSnd (map loc)) $ getTypeDerivations t db
}
)
makeMacroResult :: (Maybe String) Location Macro -> Result
makeMacroResult mbName (Location lib mod line iclline m) mac
= MacroResult
( { library = lib
, filename = modToFilename mod
, dcl_line = line
, icl_line = iclline
, modul = mod
, distance
= if (isNothing mbName) -100 (levenshtein` (fromJust mbName) m)
, builtin = Nothing
}
, { macro_name = m
, macro_representation = mac.macro_as_string
}
)
makeFunctionResult :: (Maybe String) (Maybe Type) [TypeDef] (Maybe ShortClassResult)
(Location, ExtendedType) TypeDB -> Result
makeFunctionResult
orgsearch orgsearchtype usedsynonyms mbCls (fl, et=:(ET type tes)) db
= FunctionResult
( { library = lib
, filename = modToFilename mod
, dcl_line = line
, icl_line = iclline
, modul = mod
, distance = distance
, builtin = builtin
}
, { func = fromJust (tes.te_representation <|>
(pure $ concat $ print False (fname,et)))
, unifier = toStrUnifier <$> finish_unification (unisyns ++ usedsynonyms) <$>
(orgsearchtype >>= unify [] unitype)
, cls = mbCls
, constructor_of = if tes.te_isconstructor
(let (Func _ r _) = type in Just $ concat $ print False r)
Nothing
, recordfield_of = if tes.te_isrecordfield
(let (Func [t:_] _ _) = type in Just $ concat $ print False t)
Nothing
, generic_derivations
= let derivs = getDerivations fname db in
const (sortBy (\(a,_) (b,_) -> a < b)
[(s, map loc ls) \\ (_,s,ls) <- derivs]) <$>
tes.te_generic_vars
}
)
where
(lib,mod,fname,line,iclline,builtin) = case fl of
(Location l m ln iln f) = (l, m, f, ln, iln, Nothing)
(Builtin f) = ("", "", f, Nothing, Nothing, Just True)
(unisyns, unitype) = prepare_unification` False db type
toStrUnifier :: Unifier -> StrUnifier
toStrUnifier unif =
{ StrUnifier
| left_to_right = map toStr unif.Unifier.left_to_right
, right_to_left = map toStr unif.Unifier.right_to_left
, used_synonyms = [
( concat $ [td.td_name," ":intersperse " " $ print False td.td_args]
, concat $ print False s)
\\ td=:{td_rhs=TDRSynonym s} <- unif.Unifier.used_synonyms]
}
where
toStr (var, type) = (var, concat $ print False type)
toStrPriority :: (Maybe Priority) -> String
toStrPriority p = case print False p of [] = ""; ss = concat [" ":ss]
distance
| isNothing orgsearch || fromJust orgsearch == ""
| isNothing orgsearchtype = 0
# orgsearchtype = fromJust orgsearchtype
# (syns, t) = prepare_unification` False db type
# (Just unif) = finish_unification syns <$> unify [] orgsearchtype t
= penalty + toInt (sum [typeComplexity t \\ (_,t) <- allTvas unif | not (isVar t)])
# orgsearch = fromJust orgsearch
= penalty + levenshtein` orgsearch fname
where
penalty
| tes.te_isrecordfield = 2
| tes.te_isconstructor = 1
| otherwise = 0
allTvas :: Unifier -> [TVAssignment]
allTvas unif = unif.Unifier.left_to_right ++ unif.Unifier.right_to_left
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
prepare_unification` :: !Bool !TypeDB -> Type -> ([TypeDef], Type)
prepare_unification` b db = prepare_unification b (allTypes db)
levenshtein` :: String String -> Int
levenshtein` a b = if (indexOf a b == -1) 0 -100 +
levenshtein [c \\ c <-: a] [c \\ c <-: b]
modLevenshtein :: String Module -> Int
modLevenshtein s mod
| s == mod = -100
| isMember s path = length path
| otherwise = levenshtein` s mod
where path = split "." mod
modToFilename :: String -> String
modToFilename mod = (toString $ reverse $ takeWhile ((<>)'.')
$ reverse $ fromString mod) + ".dcl"
isUnifiable :: !Type !TypeDB !ExtendedType -> Bool
isUnifiable t1 db (ET t2 _) = isJust $ unify [] t1 t2`
where
(_, t2`) = (prepare_unification` False db t2)
isNameMatch :: !Int !String !String -> Bool
isNameMatch maxdist n1 name
# (n1, n2) = ({toLower c \\ c <-: n1}, {toLower c \\ c <-: name})
= n1 == "" || indexOf n1 n2 <> -1 || levenshtein [c \\ c <-: n1] [c \\ c <-: n2] <= maxdist
isModNameMatch :: !Int !String !Module -> Bool
isModNameMatch maxdist name mod
= isNameMatch maxdist name mod || isMember name (split "." mod)
isModMatch :: ![String] Location -> Bool
isModMatch mods (Location _ mod _ _ _) = isMember mod mods
isModMatch _ (Builtin _) = False
isLibMatch :: ![String] Location -> Bool
isLibMatch libs (Location lib _ _ _ _) = any (\l -> indexOf l lib == 0) libs
isLibMatch _ (Builtin _) = True
loc :: Location -> LocationResult
loc (Location lib mod ln iln _) = (lib, mod, ln, iln)
:: LogMemory =
{ mem_ip :: IPAddress
, mem_time_start :: Tm
......
module builddb
// Project libraries
import qualified TypeDB as DB
from TypeDB import ::TypeExtras{..}, ::Macro{..}, ::ModuleInfo{..},
instance zero TypeExtras, instance zero ModuleInfo
// StdEnv
from StdFunc import const, flip, o
import StdFile, StdList, StdMisc, StdArray, StdBool, StdString, StdTuple
// CleanPlatform
import Data.Maybe, Data.Either, Data.Error, Data.Func, Data.Tuple, Data.Functor
import Control.Applicative, Control.Monad
from Text import class Text(concat,replaceSubString,indexOf,startsWith),
instance Text String
import System.Directory, System.CommandLine
// CleanTypeUnifier
import qualified Type as T
from Type import class print(print), instance print [a], instance print String,
instance print Type, instance print Priority, instance == Type
from Type import qualified ::TypeDef{..}, ::Constructor{..}
import CoclUtils
// CleanPrettyPrint
import CleanPrettyPrint
// frontend
import Heap
from hashtable import ::HashTable, ::QualifiedIdents(NoQualifiedIdents),
::IdentClass(IC_Module), ::BoxedIdent{..}, putIdentInHashTable
from predef import init_identifiers
from compile import empty_cache, ::DclCache{hash_table}
from general import ::Optional(..)
from syntax import ::SymbolTable, ::SymbolTableEntry, ::Ident{..}, ::SymbolPtr,
::Position(..), ::LineNr, ::FileName, ::FunctName,
::Module{mod_ident,mod_defs},
::ParsedDefinition(PD_TypeSpec,PD_Instance,PD_Instances,PD_Class,PD_Type,PD_Generic,PD_Derive,PD_Function),
::FunSpecials, ::Priority, ::ParsedModule, ::SymbolType,
::ParsedInstanceAndMembers{..}, ::ParsedInstance{pi_ident,pi_pos,pi_types},
::Type, ::ClassDef{class_ident,class_pos,class_args,class_context},
::TypeVar, ::ParsedTypeDef, ::TypeDef{td_pos,td_ident},
::GenericDef{gen_ident,gen_pos,gen_type,gen_vars},
::GenericCaseDef{gc_type,gc_pos,gc_gcf}, ::GenericCaseFunctions(GCF), ::GCF,
::FunKind(FK_Macro),
::Rhs, ::ParsedExpr
from scanner import ::Priority(..), ::Assoc(..)
from parse import wantModule
import StdArray
import StdBool
import StdFile
from StdFunc import const, o
import StdList
import StdMisc
import StdString
import StdTuple
import Data.Either
from Data.Func import $, mapSt
import Data.Functor
import Data.Maybe
import System.CommandLine
from Text import class Text(concat,startsWith), instance Text String
import TypeDB
import Type
from TypeDBFactory import :: DclCache, setupCache, findModules, getModuleTypes,
constructor_functions, record_functions
:: CLI = { help :: Bool
, version :: Bool
......@@ -107,25 +80,24 @@ Start w
| cli.version = fclose (f <<< VERSION) w
# (modss, w) = mapSt (flip (uncurry $ findModules cli.exclude cli.root) "") cli.libs w
# mods = flatten modss
# (st, w) = init_identifiers newHeap w
# cache = empty_cache st
# (db, w) = loop cli.root mods 'DB'.newDb cache w
# db = 'DB'.putFunctions predefFunctions db
# db = 'DB'.putClasses predefClasses db
# db = 'DB'.putTypes predefTypes db
# db = 'DB'.putFunctions (flatten $ map constructor_functions predefTypes) db
# db = 'DB'.putFunctions (flatten $ map record_functions predefTypes) db
# (cache, w) = setupCache w
# (db, w) = loop cli.root mods newDb cache w
# db = putFunctions predefFunctions db
# db = putClasses predefClasses db
# db = putTypes predefTypes db
# db = putFunctions (flatten $ map constructor_functions predefTypes) db
# db = putFunctions (flatten $ map record_functions predefTypes) db
# io = stderr
# io = printStats db io
# (ok1,w) = fclose io w
# f = 'DB'.saveDb db f
# f = saveDb db f
# (ok2,w) = fclose f w
= (ok1 && ok2,w)
| not ok = abort "Couldn't close stdio"
= w
where
loop :: String [(String,String,Bool)] 'DB'.TypeDB
*DclCache *World -> *('DB'.TypeDB, *World)
loop :: String [(String,String,Bool)] TypeDB
*DclCache *World -> *(TypeDB, *World)
loop _ [] db _ w = (db,w)
loop root [(lib,mod,iscore):list] db cache w
# w = snd (fclose (stderr <<< lib <<< ": " <<< mod <<< "\n") w)
......@@ -143,7 +115,7 @@ where
("-l", [x:xs]) = (\c->{c & libs=[(x,const False):c.libs]}) <$> parseCLI xs
(x, _) = Left $ "Unknown option '" +++ x +++ "'"
printStats :: !'DB'.TypeDB !*File -> *File
printStats :: !TypeDB !*File -> *File
printStats db f = f
<<< "+-------------+------+\n"
<<< "| Modules | " <<< modules <<< " |\n"
......@@ -157,278 +129,51 @@ where
where
[modules,funs,macros,types,classes,insts,derives:_]
= map (pad 4)
[ 'DB'.moduleCount db
, 'DB'.functionCount db
, 'DB'.macroCount db
, 'DB'.typeCount db
, 'DB'.classCount db
, 'DB'.instanceCount db
, 'DB'.deriveCount db
[ moduleCount db
, functionCount db
, macroCount db
, typeCount db
, classCount db
, instanceCount db
, deriveCount db
]
pad n i = {' ' \\ _ <- [0..n-size (toString i)-1]} +++ toString i
predefFunctions :: [('DB'.Location, 'DB'.ExtendedType)]
predefFunctions :: [(Location, ExtendedType)]
predefFunctions
= [ ( 'DB'.Builtin "if"
, 'DB'.ET ('T'.Func ['T'.Type "Bool" [], 'T'.Var "a", 'T'.Var "a"] ('T'.Var "a") []) zero
= [ ( Builtin "if"
, ET (Func [Type "Bool" [], Var "a", Var "a"] (Var "a") []) zero
)
, ( 'DB'.Builtin "dynamic"
, 'DB'.ET ('T'.Func ['T'.Var "a"] ('T'.Type "Dynamic" []) []) zero
, ( Builtin "dynamic"
, ET (Func [Var "a"] (Type "Dynamic" []) []) zero
)
]
predefClasses :: [('DB'.Location, ['T'.TypeVar], 'T'.ClassContext, [('DB'.Name, 'DB'.ExtendedType)])]
predefClasses :: [(Location, [TypeVar], ClassContext, [(Name, ExtendedType)])]
predefClasses
= [ ( 'DB'.Builtin "TC", ["v"], [], [])
= [ ( Builtin "TC", ["v"], [], [])
]
predefTypes :: [('DB'.Location, 'T'.TypeDef)]
predefTypes :: [(Location, TypeDef)]
predefTypes
= [ ( 'DB'.Builtin "Bool"
= [ ( Builtin "Bool"
, { deft
& 'Type'.td_name = "Bool"
, 'Type'.td_rhs = 'T'.TDRCons False
[ { defc & 'Type'.cons_name="False" }
, { defc & 'Type'.cons_name="True" }
& td_name = "Bool"
, td_rhs = TDRCons False
[ { defc & cons_name="False" }
, { defc & cons_name="True" }
]
}
)
, ( 'DB'.Builtin "Int", { deft & 'Type'.td_name = "Int" } )
, ( 'DB'.Builtin "Real", { deft & 'Type'.td_name = "Real" } )
, ( 'DB'.Builtin "Char", { deft & 'Type'.td_name = "Char" } )
, ( 'DB'.Builtin "String", { deft & 'Type'.td_name = "String",
'Type'.td_rhs = 'T'.TDRSynonym ('T'.Type "_#Array" ['T'.Type "Char" []]) } )
, ( 'DB'.Builtin "Dynamic", { deft & 'Type'.td_name = "Dynamic" } )
, ( 'DB'.Builtin "File", { deft & 'Type'.td_name = "File" } )
, ( 'DB'.Builtin "World", { deft & 'Type'.td_name = "World",