Commit 5fda4588 authored by Camil Staps's avatar Camil Staps 🚀

WIP for array-db branch on clean-cloogle/Cloogle

parent 59acb586
definition module Builtins
from CloogleDB import :: Location, :: FunctionEntry, :: ClassEntry,
:: TypeDefEntry, :: SyntaxEntry
from CloogleDB import :: FunctionEntry, :: ClassEntry, :: TypeDefEntry,
:: SyntaxEntry
builtin_functions :: [(Location, FunctionEntry)]
builtin_classes :: [(Location, ClassEntry)]
builtin_types :: [(Location, TypeDefEntry)]
builtin_functions :: [(FunctionEntry)]
builtin_classes :: [(ClassEntry)]
builtin_types :: [(TypeDefEntry)]
builtin_syntax :: [([String], SyntaxEntry)]
......@@ -18,87 +18,114 @@ import Cloogle
import Doc
import CloogleDB
builtin_functions :: [(Location, FunctionEntry)]
builtin_functions
= [ ( Builtin "if" [CLR 5 "3.4.2" "_Toc311798001"]
, {zero & fe_type=Just $ Func [Type "Bool" [], Var "a", Var "a"] (Var "a") []}
)
, ( Builtin "dynamic" [CLR 10 "8.1" "_Toc311798076"]
, {zero & fe_type=Just $ Func [Var "a"] (Type "Dynamic" []) [Instance "TC" [Var "a"]]}
)
builtin_functions :: [FunctionEntry]
builtin_functions =
[ { zero
& fe_loc=Builtin "if" [CLR 5 "3.4.2" "_Toc311798001"]
, fe_type=Just $ Func [Type "Bool" [], Var "a", Var "a"] (Var "a") []
}
, { zero
& fe_loc=Builtin "dynamic" [CLR 10 "8.1" "_Toc311798076"]
, fe_type=Just $ Func [Var "a"] (Type "Dynamic" []) [Instance "TC" [Var "a"]]
}
]
builtin_classes :: [(Location, ClassEntry)]
builtin_classes
= [ ( Builtin "TC" [CLR 10 "8.1.4" "_Toc311798080"]
, { ce_vars=["v"]
builtin_classes :: [ClassEntry]
builtin_classes =
[ { ce_loc=Builtin "TC" [CLR 10 "8.1.4" "_Toc311798080"]
, ce_vars=["v"]
, ce_context=[]
, ce_documentation=Nothing
, ce_members=[]
, ce_instances=[]
, ce_derivations=[]
}
)
]
builtin_types :: [(Location, TypeDefEntry)]
builtin_types
= [ ( Builtin "Bool" [CLR 6 "4.1" "_Toc311798017"]
, { deft
& tde_typedef.td_name = "Bool"
builtin_types :: [TypeDefEntry]
builtin_types =
[ { deft
& tde_loc=Builtin "Bool" [CLR 6 "4.1" "_Toc311798017"]
, tde_typedef.td_name = "Bool"
, tde_typedef.td_rhs = TDRCons False
[ { defc & cons_name="False" }
, { defc & cons_name="True" }
]
}
)
, ( Builtin "Int" [CLR 6 "4.1" "_Toc311798017"], {deft & tde_typedef.td_name = "Int"})
, ( Builtin "Real" [CLR 6 "4.1" "_Toc311798017"], {deft & tde_typedef.td_name = "Real"})
, ( Builtin "Char" [CLR 6 "4.1" "_Toc311798017"], {deft & tde_typedef.td_name = "Char"})
, ( Builtin "String" [CLR 6 "4.7" "_Toc311798037"], {deft & tde_typedef.td_name = "String",
tde_typedef.td_rhs = TDRSynonym (Type "_#Array" [Type "Char" []]) } )
, ( Builtin "Dynamic" [CLR 10 "8" "_Toc311798077"], {deft & tde_typedef.td_name = "Dynamic"})
, ( Builtin "File" [CLR 6 "4.7" "_Toc311798037"], {deft & tde_typedef.td_name = "File"})
, ( Builtin "World" [CLR 6 "4.7" "_Toc311798037"], {deft & tde_typedef.td_name = "World",
tde_typedef.td_uniq = True,
tde_doc = Just
, { deft & tde_loc=Builtin "Int" [CLR 6 "4.1" "_Toc311798017"], tde_typedef.td_name = "Int"}
, { deft & tde_loc=Builtin "Real" [CLR 6 "4.1" "_Toc311798017"], tde_typedef.td_name = "Real"}
, { deft & tde_loc=Builtin "Char" [CLR 6 "4.1" "_Toc311798017"], tde_typedef.td_name = "Char"}
, { deft & tde_loc=Builtin "Dynamic" [CLR 10 "8" "_Toc311798077"], tde_typedef.td_name = "Dynamic"}
, { deft & tde_loc=Builtin "File" [CLR 6 "4.7" "_Toc311798037"], tde_typedef.td_name = "File"}
, { deft
& tde_loc=Builtin "String" [CLR 6 "4.7" "_Toc311798037"]
, tde_typedef.td_name = "String"
, tde_typedef.td_rhs = TDRSynonym (Type "_#Array" [Type "Char" []]) }
, { deft
& tde_loc=Builtin "World" [CLR 6 "4.7" "_Toc311798037"], tde_typedef.td_name = "World"
, tde_typedef.td_uniq = True
, tde_doc = Just
{ TypeDoc | gDefault{|*|}
& description = Just "An object of this type is automatically created when the program is started, if needed. It makes efficient interfacing with the outside world possible. Its value is always `65536`."
}})
, ( Builtin "->" [CLR 6 "4.6" "_Toc311798036"], {deft & tde_typedef.td_name = "(->)",
tde_typedef.td_args = [Var "a", Var "b"],
tde_doc = Just
}
}
, { deft
& tde_loc=Builtin "->" [CLR 6 "4.6" "_Toc311798036"]
, tde_typedef.td_name = "(->)"
, tde_typedef.td_args = [Var "a", Var "b"]
, tde_doc = Just
{ TypeDoc | gDefault{|*|}
& description = Just "The arrow type is used to denote functions.\n\nOften, function types can be written in an uncurried fashion, e.g. `a b -> c` is the same as `a -> b -> c`."
, vars = ["The argument type", "The result type"]
}})
, ( Builtin "()" [], {deft & tde_typedef.td_name="_Unit",
tde_doc = Just
}
}
, { deft
& tde_loc=Builtin "()" []
, tde_typedef.td_name="_Unit"
, tde_doc = Just
{ TypeDoc | gDefault{|*|}
& description = Just "The void / unit type."
},
tde_typedef.td_rhs = TDRCons False [{defc & cons_name="()"}]})
}
, tde_typedef.td_rhs = TDRCons False [{defc & cons_name="()"}]
}
: lists
++ arrays
++ tuples
]
where
deft = {tde_typedef={td_name="", td_uniq=False, td_args=[], td_rhs=TDRAbstract Nothing}, tde_doc=Nothing}
defc = {cons_name="", cons_args=[], cons_exi_vars=[], cons_context=[], cons_priority=Nothing}
deft =
{ tde_loc=zero
, tde_typedef=
{ td_name=""
, td_uniq=False
, td_args=[]
, td_rhs=TDRAbstract Nothing
}
, tde_doc=Nothing
, tde_instances=[]
}
defc =
{ cons_name=""
, cons_args=[]
, cons_exi_vars=[]
, cons_context=[]
, cons_priority=Nothing
}
lists = [make_list kind spine \\ kind <- [[], ['#'], ['!'], ['|']], spine <- [[], ['!']] | kind <> ['|'] || spine <> ['!']]
where
make_list :: [Char] [Char] -> (Location, TypeDefEntry)
make_list k s = (Builtin higherorder [CLR 6 "4.2" "_Toc311798019"],
make_list :: [Char] [Char] -> TypeDefEntry
make_list k s =
{ deft
& tde_typedef.td_name = toString (['_':k] ++ ['List'] ++ s)
& tde_loc = Builtin higherorder [CLR 6 "4.2" "_Toc311798019"]
, tde_typedef.td_name = toString (['_':k] ++ ['List'] ++ s)
, tde_typedef.td_args = [Var "a"]
, tde_doc = Just
{ TypeDoc | gDefault{|*|}
& description = Just $ "A" + kind + spine + " list.\n\n" + description
, vars = ["The type of the list elements."]
}
})
}
where
higherorder = toString (['[':k] ++ s` ++ [']'])
with s` = if (s == ['!'] && k == []) [' !'] s
......@@ -125,17 +152,18 @@ where
arrays = [make_array kind \\ kind <- [[], ['!'], ['#']]]
where
make_array :: [Char] -> (Location, TypeDefEntry)
make_array k = (Builtin typec [CLR 6 "4.4" "_Toc311798029"],
make_array :: [Char] -> TypeDefEntry
make_array k =
{ deft
& tde_typedef.td_name = toString (['_':k] ++ ['Array'])
& tde_loc = Builtin typec [CLR 6 "4.4" "_Toc311798029"]
, tde_typedef.td_name = toString (['_':k] ++ ['Array'])
, tde_typedef.td_args = [Var "a"]
, tde_doc = Just
{ TypeDoc | gDefault{|*|}
& description = Just $ "An array contains a finite number of elements of the same type. Access time is constant.\n\n" + description
, vars = ["The type of the array elements."]
}
})
}
where
typec = toString (['{':k]++['}'])
......@@ -146,10 +174,11 @@ where
tuples = [make_tuple n \\ n <- [2..32]]
where
make_tuple :: Int -> (Location, TypeDefEntry)
make_tuple n = (Builtin typec [CLR 6 "4.3" "_Toc311798026"],
make_tuple :: Int -> TypeDefEntry
make_tuple n =
{ deft
& tde_typedef.td_name = "_Tuple" <+ n
& tde_loc = Builtin typec [CLR 6 "4.3" "_Toc311798026"]
, tde_typedef.td_name = "_Tuple" <+ n
, tde_typedef.td_args = [Var $ toString [v:repeatn (n / 26) '`'] \\ v <- cycle ['a'..'z'] & n <- [0..n-1]]
, tde_doc = Just
{ TypeDoc | gDefault{|*|}
......@@ -157,7 +186,7 @@ where
"Tuples allow bundling a finite number of expressions of different types into one object without defining a new data type.\n\n" +
"Clean supports tuples of arity 2 to 32."
}
})
}
where
typec = toString ['(':repeatn (n-1) ',' ++ [')']]
ary = case n of
......
Subproject commit 705b5d7a11d7cb2ecf06dc753f06142ce33c7bee
Subproject commit 33751e14a6a4d25b273506980258ce694789af4a
......@@ -59,11 +59,11 @@ derive JSONDecode Kind, Type, RequestCacheKey, TypeRestriction
instance toString RequestCacheKey
where toString rck = toString $ toJSON rck
toRequestCacheKey :: CloogleDB Request -> RequestCacheKey
toRequestCacheKey db r =
{ c_unify = snd <$>
toRequestCacheKey :: !*CloogleDB !Request -> *(!RequestCacheKey, !*CloogleDB)
toRequestCacheKey db r = (
{ c_unify = Nothing /*snd <$>
prepare_unification True (map getTypeDef $ allTypes db) <$>
(parseType o fromString =<< r.unify)
(parseType o fromString =<< r.unify)*/
, c_name = r.name
, c_className = r.className
, c_typeName = r.typeName
......@@ -73,7 +73,7 @@ toRequestCacheKey db r =
, c_include_core = fromJust (r.include_core <|> Just DEFAULT_INCLUDE_CORE)
, c_include_apps = fromJust (r.include_apps <|> Just DEFAULT_INCLUDE_APPS)
, c_page = fromJust (r.page <|> Just 0)
}
}, db)
fromRequestCacheKey :: RequestCacheKey -> Request
fromRequestCacheKey k =
{ unify = concat <$> print False <$> k.c_unify
......@@ -119,17 +119,23 @@ Start w
| opts.help = help (hd cmdline) w
# w = disableSwap w
#! (_,f,w) = fopen "types.json" FReadText w
#! (db,f) = openDb f
#! db = hyperstrict db
#! w = if opts.reload_cache (doInBackground (reloadCache db)) id w
#! (db,f) = openDB f
#! (ok,db) = isJustU db
| not ok
# (io,w) = stdio w
# io = io <<< "Could not open database\n"
# (_,w) = fclose io w
= w
#! db = hyperstrict (fromJust db)
//#! w = if opts.reload_cache (doInBackground (reloadCache db)) id w
#! (_,w) = fclose f w
= serve
{ handler = handle db
{ handler = handle
, logger = Just log
, port = opts.Options.port
, connect_timeout = Just 3600000 // 1h
, keepalive_timeout = Just 5000 // 5s
} w
} db w
where
help :: String *World -> *World
help pgm w
......@@ -146,33 +152,36 @@ where
# io = io <<< "Could not lock memory (" <<< err <<< "); process may get swapped out\n"
= snd $ fclose io w
handle :: !CloogleDB !(Maybe Request) !*World -> *(!Response, CacheKey, !*World)
handle db Nothing w = (err InvalidInput "Couldn't parse input", "", w)
handle db (Just request=:{unify,name,page}) w
handle :: !(Maybe Request) !*CloogleDB !*World -> *(!Response, CacheKey, !*CloogleDB, !*World)
handle Nothing db w = (err InvalidInput "Couldn't parse input", "", db, w)
handle (Just request=:{unify,name,page}) db w
//Check cache
#! (key,db) = toRequestCacheKey db request
#! (mbResponse, w) = readCache key w
| isJust mbResponse
# r = fromJust mbResponse
= respond {r & return = if (r.return == 0) 1 r.return} w
= respond key {r & return = if (r.return == 0) 1 r.return} db w
| isJust name && size (fromJust name) > 40
= respond (err InvalidName "Function name too long") w
= respond key (err InvalidName "Function name too long") db w
| isJust name && any isSpace (fromString $ fromJust name)
= respond (err InvalidName "Name cannot contain spaces") w
= respond key (err InvalidName "Name cannot contain spaces") db w
| isJust unify && isNothing (parseType $ fromString $ fromJust unify)
= respond (err InvalidType "Couldn't parse type") w
= respond key (err InvalidType "Couldn't parse type") db w
// Results
#! drop_n = fromJust (page <|> pure 0) * MAX_RESULTS
#! results = drop drop_n $ sort $ search request db
#! (res,db) = search request db
#! results = drop drop_n res
#! more = max 0 (length results - MAX_RESULTS)
// Suggestions
#! suggestions = unify >>= parseType o fromString >>= flip (suggs name) db
#! w = seq [cachePages
(toRequestCacheKey db req) CACHE_PREFETCH 0 zero suggs
\\ (req,suggs) <- 'Foldable'.concat suggestions] w
#! suggestions
= sortBy (\a b -> snd a > snd b) <$>
filter ((<) (length results) o snd) <$>
map (appSnd length) <$> suggestions
// #! suggestions = unify >>= parseType o fromString >>= flip (suggs name) db
// #! w = seq [cachePages
// (toRequestCacheKey db req) CACHE_PREFETCH 0 zero suggs
// \\ (req,suggs) <- 'Foldable'.concat suggestions] w
// #! suggestions
// = sortBy (\a b -> snd a > snd b) <$>
// filter ((<) (length results) o snd) <$>
// map (appSnd length) <$> suggestions
# suggestions = Nothing
#! (results,nextpages) = splitAt MAX_RESULTS results
// Response
#! response = if (isEmpty results)
......@@ -185,12 +194,10 @@ where
// Save page prefetches
#! w = cachePages key CACHE_PREFETCH 1 response nextpages w
// Save cache file
= respond response w
= respond key response db w
where
key = toRequestCacheKey db request
respond :: !Response !*World -> *(!Response, !CacheKey, !*World)
respond r w = (r, cacheKey key, writeCache LongTerm key r w)
respond :: !RequestCacheKey !Response !*CloogleDB !*World -> *(!Response, !CacheKey, !*CloogleDB, !*World)
respond key r db w = (r, cacheKey key, db, writeCache LongTerm key r w)
cachePages :: !RequestCacheKey !Int !Int !Response ![Result] !*World -> *World
cachePages key _ _ _ [] w = w
......
......@@ -4,20 +4,21 @@ from StdOverloaded import class zero, class fromString, class toString
from StdMaybe import :: Maybe
from TCPIP import ::IPAddress, ::Port
:: LogMessage a b t
:: LogMessage req res sentinfo
= Connected IPAddress
| Received a
| Sent b t
| Received req
| Sent res sentinfo
| Disconnected
:: Logger a b s t :== (LogMessage a b t) (Maybe s) *World -> *(Maybe s, *World)
:: Logger req res logst sentinfo
:== (LogMessage req res sentinfo) (Maybe logst) *World -> *(Maybe logst, *World)
:: Server a b s t
= { handler :: !a *World -> *(!b, !t, !*World)
, logger :: !Maybe (Logger a b s t)
:: Server req res st logst sentinfo =
{ handler :: !req -> .(st -> *(*World -> *(!res, !sentinfo, !st, !*World)))
, logger :: !Maybe (Logger req res logst sentinfo)
, port :: !Int
, connect_timeout :: !Maybe Int
, keepalive_timeout :: !Maybe Int
}
serve :: !(Server a b s t) !*World -> *World | fromString a & toString b
serve :: !(Server req res .st logst sentinfo) .st !*World -> *World | fromString req & toString res
......@@ -7,8 +7,8 @@ import TCPIP
instance zero (Logger a b s t) where zero = \_ _ w -> (undef, w)
serve :: !(Server a b s t) !*World -> *World | fromString a & toString b
serve server w
serve :: !(Server req res .st logst sentinfo) .st !*World -> *World | fromString req & toString res
serve server st w
# (ok, mbListener, w) = openTCP_Listener server.port w
| not ok = abort ("Couldn't open port " +++ toString server.port +++ "\n")
# listener = fromJust mbListener
......@@ -30,22 +30,22 @@ where
| pid > 0 // Parent: handle new requests
= loop li w
| pid == 0 // Child: handle current request
#! (st,w) = logger (Connected ip) Nothing w
= handle st dupChan w
#! (logst,w) = logger (Connected ip) Nothing w
= handle logst st dupChan w
//handle :: !(Maybe s) !TCP_DuplexChannel !*World -> *(!TCP_Listener, !*World)
handle st dupChannel=:{rChannel,sChannel} w
handle logst st dupChannel=:{rChannel,sChannel} w
#! (tRep,msg,rChannel,w) = receive_MT server.keepalive_timeout rChannel w
| tRep <> TR_Success
#! (st,w) = logger Disconnected st w
#! (logst,w) = logger Disconnected logst w
#! w = closeChannel sChannel (closeRChannel rChannel w)
= exit 0 w
#! msg = fromString (toString (fromJust msg))
#! (st, w) = logger (Received msg) st w
#! (resp, hidden, w) = server.handler msg w
#! (logst, w) = logger (Received msg) logst w
#! (resp, hidden, st, w) = server.handler msg st w
#! (sChannel, w) = send (toByteSeq (toString resp)) sChannel w
#! (st, w) = logger (Sent resp hidden) st w
= handle st {dupChannel & rChannel=rChannel, sChannel=sChannel} w
#! (logst, w) = logger (Sent resp hidden) logst w
= handle logst st {dupChannel & rChannel=rChannel, sChannel=sChannel} w
signal :: !Int !Int !*World -> *(!Int, !*World)
signal signum handler w = code {
......
......@@ -89,19 +89,19 @@ Start w
# (modss, w) = mapSt (flip (uncurry $ findModules cli.exclude cli.root) "") cli.libs w
# mods = flatten modss
#! (db, w) = loop cli.root mods newTemporaryDb w
#! db = finaliseDb db newDb
#! db = putFunctions builtin_functions db
#! db = putClasses builtin_classes db
#! db = putTypes builtin_types db
#! db = putFunctions [(setName n loc, f)\\ (loc,t) <- builtin_types, (n, f) <- constructor_functions t ++ record_functions t] db
#! db = putSyntaxElems builtin_syntax db
#! db = syncDb 2 db
#! (ok1,w) = fclose (printStats db stderr) w
#! f = saveDb db f
#! db = finaliseDb db
//#! db = putFunctions builtin_functions db
//#! db = putClasses builtin_classes db
//#! db = putTypes builtin_types db
//#! db = putFunctions [(setName n loc, f)\\ (loc,t) <- builtin_types, (n, f) <- constructor_functions t ++ record_functions t] db
//#! db = putSyntaxElems builtin_syntax db
#! db = syncDB 2 db
#! (ok1,w) = (True,w) // TODO fclose (printStats db stderr) w
#! (db,f) = saveDB db f
#! (ok2,w) = fclose f w
#! (_,dbg,w) = fopen "typetree.dot" FWriteText w
#! dbg = writeTypeTree db dbg
#! (_,w) = fclose dbg w
//#! (_,dbg,w) = fopen "typetree.dot" FWriteText w
//#! dbg = writeTypeTree db dbg
//#! (_,w) = fclose dbg w
= (ok1 && ok2,w)
| not ok = abort "Couldn't close stdio"
= w
......@@ -133,33 +133,33 @@ where
("-l", [x:xs]) = (\c->{c & libs=[(x,const id):c.libs]}) <$> parseCLI xs
(x, _) = Left $ "Unknown option '" +++ x +++ "'"
printStats :: !CloogleDB !*File -> *File
printStats db f = f
<<< "+-------------------+-------+\n"
<<< "| Modules | " <<< modules <<< " |\n"
<<< "| Functions | " <<< funs <<< " |\n"
<<< "| With types | " <<< treesize <<< " |\n"
<<< "| Unique types | " <<< unqtypes <<< " |\n"
<<< "| Type tree depth | " <<< treedep <<< " |\n"
<<< "| Type definitions | " <<< types <<< " |\n"
<<< "| Classes | " <<< classes <<< " |\n"
<<< "| Instances | " <<< insts <<< " |\n"
<<< "| Derivations | " <<< derives <<< " |\n"
<<< "| Syntax constructs | " <<< syntaxs <<< " |\n"
<<< "+-------------------+-------+\n"
where
[modules,funs,unqtypes,treesize,treedep,types,classes,insts,derives,syntaxs:_]
= map (pad 5)
[ moduleCount db
, functionCount db
, treenodes
, treesize
, treedepth
, typeCount db
, classCount db
, instanceCount db
, deriveCount db
, syntaxCount db
]
where (treenodes,treesize,treedepth) = typeTreeStats db
pad n i = {' ' \\ _ <- [0..n-size (toString i)-1]} +++ toString i
//printStats :: !CloogleDB !*File -> *File
//printStats db f = f
// <<< "+-------------------+-------+\n"
// <<< "| Modules | " <<< modules <<< " |\n"
// <<< "| Functions | " <<< funs <<< " |\n"
// <<< "| With types | " <<< treesize <<< " |\n"
// <<< "| Unique types | " <<< unqtypes <<< " |\n"
// <<< "| Type tree depth | " <<< treedep <<< " |\n"
// <<< "| Type definitions | " <<< types <<< " |\n"
// <<< "| Classes | " <<< classes <<< " |\n"
// <<< "| Instances | " <<< insts <<< " |\n"
// <<< "| Derivations | " <<< derives <<< " |\n"
// <<< "| Syntax constructs | " <<< syntaxs <<< " |\n"
// <<< "+-------------------+-------+\n"
//where
// [modules,funs,unqtypes,treesize,treedep,types,classes,insts,derives,syntaxs:_]
// = map (pad 5)
// [ moduleCount db
// , functionCount db
// , treenodes
// , treesize
// , treedepth
// , typeCount db
// , classCount db
// , instanceCount db
// , deriveCount db
// , syntaxCount db
// ]
// where (treenodes,treesize,treedepth) = typeTreeStats db
// pad n i = {' ' \\ _ <- [0..n-size (toString i)-1]} +++ toString i
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