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

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

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