Commit 7b294fab authored by Camil Staps's avatar Camil Staps 🚀

Merge branch 'new-maybe-types' into 'master'

Use new maybe types

See merge request !225
parents dec3cd0d f4ad1f1e
Pipeline #44609 passed with stages
in 19 minutes and 36 seconds
......@@ -29,26 +29,26 @@ CLR sec =
builtin_functions :: [FunctionEntry]
builtin_functions =
[ { zero
& fe_loc=Builtin "if" [CLR "3.4.2"]
, fe_type=Just $ Func [Type "Bool" [], Var "a", Var "a"] (Var "a") (TypeContext [])
& fe_loc = Builtin "if" [CLR "3.4.2"]
, fe_type = ?Just $ Func [Type "Bool" [], Var "a", Var "a"] (Var "a") (TypeContext [])
}
, { zero
& fe_loc=Builtin "dynamic" [CLR "8.1"]
, fe_type=Just $ Func [Var "a"] (Type "Dynamic" []) (TypeContext [Instance "TC" [Var "a"]])
& fe_loc = Builtin "dynamic" [CLR "8.1"]
, fe_type = ?Just $ Func [Var "a"] (Type "Dynamic" []) (TypeContext [Instance "TC" [Var "a"]])
}
]
builtin_classes :: [ClassEntry]
builtin_classes =
[ { ce_loc=Builtin "TC" [CLR "8.1.4"]
, ce_vars=["v"]
, ce_is_meta=False
, ce_context=TypeContext []
, ce_documentation=Nothing
, ce_members={}
, ce_instances={}
, ce_derivations={}
, ce_usages={}
[ { ce_loc = Builtin "TC" [CLR "8.1.4"]
, ce_vars = ["v"]
, ce_is_meta = False
, ce_context = TypeContext []
, ce_documentation = ?None
, ce_members = {}
, ce_instances = {}
, ce_derivations = {}
, ce_usages = {}
}
]
......@@ -74,27 +74,27 @@ builtin_types =
, { deft
& tde_loc=Builtin "World" [CLR "4.7"], tde_typedef.td_name = "World"
, tde_typedef.td_uniq = True
, tde_doc = Just
, 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`."
& 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`."
}
}
, { deft
& tde_loc=Builtin "->" [CLR "4.6"]
, tde_typedef.td_name = "(->)"
, tde_typedef.td_args = [Var "a", Var "b"]
, tde_doc = Just
, 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`."
& 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"]
}
}
, { deft
& tde_loc=Builtin "()" []
, tde_typedef.td_name="_Unit"
, tde_doc = Just
, tde_doc = ?Just
{ TypeDoc | gDefault{|*|}
& description = Just "The void / unit type."
& description = ?Just "The void / unit type."
}
, tde_typedef.td_rhs = TDRCons False [{defc & cons_name="()"}]
}
......@@ -105,24 +105,24 @@ builtin_types =
]
where
deft =
{ tde_loc=zero
, tde_typedef=
{ td_name=""
, td_uniq=False
, td_args=[]
, td_rhs=TDRAbstract Nothing
{ tde_loc = zero
, tde_typedef =
{ td_name = ""
, td_uniq = False
, td_args = []
, td_rhs = TDRAbstract ?None
}
, tde_doc=Nothing
, tde_instances={}
, tde_derivations={}
, tde_usages={}
, tde_doc = ?None
, tde_instances = {}
, tde_derivations = {}
, tde_usages = {}
}
defc =
{ cons_name=""
, cons_args=[]
, cons_exi_vars=[]
, cons_context=TypeContext []
, cons_priority=Nothing
{ cons_name = ""
, cons_args = []
, cons_exi_vars = []
, cons_context = TypeContext []
, cons_priority = ?None
}
lists = [make_list kind spine \\ kind <- [[], ['#'], ['!']], spine <- [[], ['!']]]
......@@ -133,9 +133,9 @@ where
& tde_loc = Builtin higherorder [CLR "4.2"]
, tde_typedef.td_name = toString (['_':k] ++ ['List'] ++ s)
, tde_typedef.td_args = [Var "a"]
, tde_doc = Just
, tde_doc = ?Just
{ 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."]
}
}
......@@ -172,9 +172,9 @@ where
& tde_loc = Builtin typec [CLR "4.4"]
, tde_typedef.td_name = toString (['_':k] ++ ['Array'])
, tde_typedef.td_args = [Var "a"]
, tde_doc = Just
, 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
& 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."]
}
}
......@@ -199,9 +199,9 @@ where
[ { defc & cons_name=toString ['?':k` ++ ['None']]}
, { defc & cons_name=toString ['?':k` ++ ['Just']], cons_args=[Var "a"]}
]
, tde_doc = Just
, tde_doc = ?Just
{ TypeDoc | gDefault{|*|}
& description = Just $ "A maybe optionally contains a value." + description
& description = ?Just $ "A maybe optionally contains a value." + description
, vars = ["The type of the optional value."]
}
}
......@@ -215,7 +215,7 @@ where
, cons_args = []
, cons_exi_vars = []
, cons_context = TypeContext []
, cons_priority = Nothing
, cons_priority = ?None
}
description = "These types of maybes are available:\n\n" +
......@@ -232,9 +232,9 @@ where
& tde_loc = Builtin typec [CLR "4.3"]
, 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
, tde_doc = ?Just
{ TypeDoc | gDefault{|*|}
& description = Just $ article + " " + ary + "ary tuple.\n\n" +
& description = ?Just $ article + " " + ary + "ary tuple.\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."
}
......
......@@ -7,7 +7,6 @@ import StdString
import Data.Error
from Data.Func import $
import Data.Maybe
import Text
import Regex
......@@ -75,9 +74,9 @@ builtin_syntax =
]
EX :: !String -> SyntaxExample
EX c = {example=c, cleanjs_start=Nothing, bootstrap=[], requires_itask_compiler=False}
EX c = {example = c, cleanjs_start = ?None, bootstrap = [], requires_itask_compiler = False}
EXs :: !String !String -> SyntaxExample
EXs s c = {EX c & cleanjs_start=Just s}
EXs s c = {EX c & cleanjs_start = ?Just s}
add_imports :: ![String] !SyntaxExample -> SyntaxExample
add_imports is se = {se & bootstrap=["import " +++ mod \\ mod <- is] ++ se.bootstrap}
......@@ -122,8 +121,8 @@ bs_case =
]
, syntax_doc_locations = [CLR "3.4.2"]
, syntax_examples =
[ add_imports ["StdMaybe"] $ EXs "macro"
"isJust m = case m of\n\tJust _ -> True\n\t_ -> False"
[ EXs "macro"
"isJust m = case m of\n\t?Just _ -> True\n\t_ -> False"
]
}
......@@ -357,8 +356,8 @@ bs_generic =
"generic gEq a :: !a !a -> Bool // The type of a generic function\n" +
"gEq{|Int|} x y = x == y // Implementation of a generic\n" +
"gEq{|PAIR|} fx fy (PAIR x1 y1) (PAIR x2 y2) = fx x1 x2 && fy y1 y2"
, add_imports ["StdMaybe", "Data.GenEq"] $ EX
"derive gEq Maybe // Deriving the gEq generic for type Maybe"
, add_imports ["Data.GenEq"] $ EX
"derive gEq ? // Deriving the gEq generic for type ?"
, add_imports ["StdGeneric"] $ add_bootstrap "generic gConsName a :: a -> String" $ EX
"gConsName{|CONS of d|} _ _ = d.gcd_name // Using type information"
, add_imports ["StdGeneric"] $ add_bootstrap "generic gConsName a :: a -> String" $ EX
......@@ -404,9 +403,9 @@ bs_import =
, "import code from library \"msvcrt\" // Import functions from linked DLLs according to the msvcrt file in Clean System Files.\n" +
" // The file should start with the DLL name (e.g. msvcrt) and followed by one line per function you want to link."
] ++ map (add_imports ["StdEnv"] o EX)
[ "from StdMaybe import :: Maybe // Import only the type Maybe"
, "from StdMaybe import :: Maybe(..) // Import the type Maybe and all constructors"
, "from StdMaybe import :: Maybe(Just) // Import the type Maybe and the Just constructor"
[ "from Data.Map import :: Map // Import only the type Map"
, "from Data.Map import :: Map(..) // Import the type Map and all constructors"
, "from Data.Map import :: Map(Bin) // Import the type Map and the Bin constructor"
, "from Data.Foldable import class Foldable(foldr1()) // Import the class Foldable and the foldr1 member type"
] ++ map (requires_itask_compiler o EX)
[ "import qualified Data.Map as M // Import Data.Map to use as e.g. 'M'.get (only supported by the iTask compiler)"
......@@ -591,11 +590,10 @@ bs_overloaded_type_variable =
, syntax_description = "A pattern match on the type of a dynamic depending on the type of the function."
, syntax_doc_locations = [CLR "8.2.5"]
, syntax_examples =
[ add_imports ["StdMaybe"] $
EX $
"unpack :: Dynamic -> Maybe a | TC a\n" +
"unpack (x :: a^) = Just x // Only values of type a\n" +
"unpack _ = Nothing"
[ EX $
"unpack :: Dynamic -> ?a | TC a\n" +
"unpack (x :: a^) = ?Just x // Only values of type a\n" +
"unpack _ = ?None"
]
}
......@@ -605,8 +603,8 @@ bs_pattern_named =
, syntax_code = ["...=:(...)"]
, syntax_description = "Give a name to the expression of a pattern to be able to use the whole expression without creating new graphs."
, syntax_doc_locations = [CLR "3.2"]
, syntax_examples = map (add_imports ["StdMaybe"] o EX)
[ "isJustU e=:(Just _) = (True, e) // On an ADT"
, syntax_examples = map (add_imports ["_SystemStrictMaybes"] o EX)
[ "isJustU e=:(?Just _) = (True, e) // On an ADT"
, ":: Position = {px :: Int, py :: Int}\ngetx p=:{px} = (px, p) // On a record; this has type :: Position -> (Int, Position)"
]
}
......@@ -619,7 +617,7 @@ bs_pattern_predicate =
[ "Check whether an expression matches a certain pattern (undocumented)."
, "The result has type `Bool`."
, "It is not possible to introduce new identifiers this way."
, "For instance, one cannot use `if (mbx=:(Just x)) x 0`."
, "For instance, one cannot use `if (mbx=:(?Just x)) x 0`."
, "Also, `=:` can not be used in prefix form because it is not an actual operator but a builtin."
]
, syntax_doc_locations = [CLR "3.4.3"]
......@@ -875,11 +873,11 @@ bs_zf =
]
, syntax_description = "Constructs a list or array composed of elements drawn from other lists or arrays. It is possible to use local definitions as well (see {{`let`}})."
, syntax_doc_locations = [CLR "4.2.1", CLR "4.4.1"]
, syntax_examples = map (add_imports ["StdEnv", "StdMaybe"] o EXs "macro")
, syntax_examples = map (add_imports ["StdEnv", "_SystemStrictMaybes"] o EXs "macro")
[ "cartesian = [(x,y) \\\\ x <- [1,2,3], y <- [10,20]] // Cartesian product: (1,10), (1,20), (2,10), (2,20), (3,10), (3,20)"
, "zip xs ys = [(x,y) \\\\ x <- xs & y <- ys] // Pairwise zip through the lists"
, "filter f xs = [x \\\\ x <- xs | f x] // Guard to add conditions"
, "catMaybes ms = [x \\\\ Just x <- ms] // Pattern matching in the selector"
, "catMaybes ms = [x \\\\ ?Just x <- ms] // Pattern matching in the selector"
, "triangle = [(x,y) \\\\ x <- [1,2,3], y <- [1..x]] // Reusing x in the next generator: (1,1), (2,1), (2,2), (3,1), (3,2), (3,3)"
, "arrToList a = [x \\\\ x <-: a] // <-: to draw elements from an array"
, "listToArr l = {x \\\\ x <- l} // {..} to create an array"
......
Subproject commit b0c0e4d0d376c8cce9f468d4120a7bc3998848cf
Subproject commit 26e5456832ef0199207619d7df199f71658f3d5e
......@@ -97,10 +97,10 @@ fromRequestCacheKey k =
, using = k.c_using
, modules = k.c_modules
, libraries = k.c_libraries
, include_builtins = Just k.c_include_builtins
, include_core = Just k.c_include_core
, include_apps = Just k.c_include_apps
, page = Just k.c_page
, include_builtins = ?Just k.c_include_builtins
, include_core = ?Just k.c_include_core
, include_apps = ?Just k.c_include_apps
, page = ?Just k.c_page
}
where
unprepare :: !Type -> Type
......@@ -141,8 +141,8 @@ where
{ port = 31215
, db_file = "db.jsonl"
, reload_cache = False
, rank_settings_constraints = Nothing
, test_file = Nothing
, rank_settings_constraints = ?None
, test_file = ?None
, test_options = []
}
......@@ -167,12 +167,12 @@ optionDescription = WithHelp True $ Options
"Reload the cache in the background"
, Option
"--rank-settings-constraints"
(\file opts -> Ok {opts & rank_settings_constraints=Just file})
(\file opts -> Ok {opts & rank_settings_constraints = ?Just file})
"FILE"
"Output symbolic rank constraints in Z3 format based on test cases in FILE"
, Option
"--test"
(\file opts -> Ok {opts & test_file=Just file})
(\file opts -> Ok {opts & test_file = ?Just file})
"FILE"
"Load queries from FILE and execute them (do not start a TCP server)"
, Flag
......@@ -218,10 +218,10 @@ Start w
= reloadCache db w
= serve
{ handler = handle
, logger = Just log
, logger = ?Just log
, port = opts.Options.port
, connect_timeout = Just 3600000 // 1h
, keepalive_timeout = Just 5000 // 5s
, connect_timeout = ?Just 3600000 // 1h
, keepalive_timeout = ?Just 5000 // 5s
} db w
where
disableSwap :: *World -> *World
......@@ -237,8 +237,8 @@ errexit msg rcode w
= setReturnCode rcode w
handle :: !(Maybe Request) !*CloogleDB !*World -> *(!Response, !(!Maybe CacheKey, !MicroSeconds), !*CloogleDB, !*World)
handle Nothing db w = (err InvalidInput "Couldn't parse input" Nothing, (Nothing,0), db, w)
handle (Just request=:{unify,name,page}) db w
handle ?None db w = (err InvalidInput "Couldn't parse input" ?None, (?None,0), db, w)
handle (?Just request=:{unify,name,page}) db w
#! (start,w) = nsTime w
//Check cache
#! (alwaysUnique,db) = alwaysUniquePredicate db
......@@ -247,20 +247,20 @@ handle (Just request=:{unify,name,page}) db w
#! (mbResponse, w) = readCache key w
| isJust mbResponse
# r = fromJust mbResponse
= respond start Nothing {r & return = if (r.return == 0) 1 r.return} db w
= respond start ?None {r & return = if (r.return == 0) 1 r.return} db w
| isJust name && size (fromJust name) > 40
= respond start Nothing (err InvalidName "Function name too long" Nothing) db w
= respond start ?None (err InvalidName "Function name too long" ?None) db w
| isJust name && any isSpace (fromString $ fromJust name)
= respond start Nothing (err InvalidName "Name cannot contain spaces" Nothing) db w
= respond start ?None (err InvalidName "Name cannot contain spaces" ?None) db w
| isJust unify && isNothing (parseType $ fromString $ fromJust unify)
= respond start Nothing (err InvalidType "Couldn't parse type" Nothing) db w
= respond start ?None (err InvalidType "Couldn't parse type" ?None) db w
| all isNothing [unify,name,request.exactName,request.typeName,request.className] && isNothing request.using
= respond start Nothing (err InvalidInput "Empty query" Nothing) db w
= respond start ?None (err InvalidInput "Empty query" ?None) db w
#! (warnings,db) = getWarnings (parseType =<< fromString <$> unify) db
// Results
#! drop_n = fromJust (page <|> pure 0) * MAX_RESULTS
#! (res,suggs,db) = searchWithSuggestions request db
#! suggs = if (isEmpty suggs) Nothing (Just suggs)
#! suggs = if (isEmpty suggs) ?None (?Just suggs)
#! results = [r \\ r <|- Drop drop_n res]
#! more = max 0 (length results - MAX_RESULTS)
// Suggestions
......@@ -275,14 +275,14 @@ handle (Just request=:{unify,name,page}) db w
(err NoResults "No results" suggs)
{ zero
& data = results
, more_available = Just more
, more_available = ?Just more
, suggestions = suggs
, warnings = if (isEmpty warnings) Nothing (Just $ removeDup warnings)
, warnings = if (isEmpty warnings) ?None (?Just $ removeDup warnings)
}
// Save page prefetches
#! w = cachePages key CACHE_PREFETCH 1 response nextpages w
// Save cache file
= respond start (Just key) response db w
= respond start (?Just key) response db w
where
respond :: !Timespec !(Maybe RequestCacheKey) !Response !*CloogleDB !*World ->
*(!Response, !(!Maybe CacheKey, !MicroSeconds), !*CloogleDB, !*World)
......@@ -290,13 +290,13 @@ where
#! (end,w) = nsTime w
#! duration = 1000000000 * (end.tv_sec - start.tv_sec) + end.tv_nsec - start.tv_nsec
#! cache = duration > CACHE_NS_THRESHOLD
= (r, (if cache (cacheKey <$> key) Nothing, duration / 1000), db, case (cache,key) of
(True,Just k) -> writeCache LongTerm k r w
_ -> w)
= (r, (if cache (cacheKey <$> key) ?None, duration / 1000), db, case (cache,key) of
(True,?Just k) -> writeCache LongTerm k r w
_ -> w)
getWarnings :: !(Maybe Type) !*CloogleDB -> (![String], !*CloogleDB)
getWarnings Nothing db = ([], db)
getWarnings (Just t) db
getWarnings ?None db = ([], db)
getWarnings (?Just t) db
# (warnings,db) = mapSt checkTypeVariables [(n,length args) \\ type=:(Type n args) <- subtypes t] db
= (catMaybes warnings,db)
where
......@@ -305,13 +305,13 @@ where
# (entries,db) = getExactNameMatches name db
# nvars = sort $ removeDup [length tde_typedef.td_args \\ TypeDefEntry {tde_typedef} <|- entries]
| isEmpty nvars
= (Nothing,db)
= (?None,db)
| isMember nargs nvars
= (Nothing,db)
= (?None,db)
= case nvars of
[1] -> (Just (concat $ warn ++ ["1 was expected"]),db)
[n] -> (Just (concat $ warn ++ [toString n," were expected"]),db)
_ -> (Just (concat $ warn ++ intersperse ", " (map toString (init nvars)) ++ [", or ",toString (last nvars)," were expected"]),db)
[1] -> (?Just (concat $ warn ++ ["1 was expected"]),db)
[n] -> (?Just (concat $ warn ++ [toString n," were expected"]),db)
_ -> (?Just (concat $ warn ++ intersperse ", " (map toString (init nvars)) ++ [", or ",toString (last nvars)," were expected"]),db)
where
warn = ["Type {{`",name,"`}} used with ",toString nargs," argument",if (nargs==1) "" "s"," where "]
......@@ -325,7 +325,7 @@ where
req` = { key & c_page = key.c_page + i }
resp` =
{ response
& more_available = Just $ max 0 (length results - MAX_RESULTS)
& more_available = ?Just $ max 0 (length results - MAX_RESULTS)
, data = give
}
(give,keep) = splitAt MAX_RESULTS results
......@@ -339,7 +339,7 @@ where
loop [] _ w = w
loop [k:ks] db w
# w = removeFromCache LongTerm k w
# (_,_,db,w) = handle (Just $ fromRequestCacheKey k) db w
# (_,_,db,w) = handle (?Just $ fromRequestCacheKey k) db w
# db = resetDB db
= loop ks db w
......@@ -360,7 +360,7 @@ test opts queries db w
w
(snd $ fclose (stderr <<< qstring) w)
#! (Clock start,w) = clock w
#! (resp,_,db,w) = handle (Just q) db w
#! (resp,_,db,w) = handle (?Just q) db w
| (hyperstrict resp).return < 0 = abort "return code was < 0\n"
#! (Clock end,w) = clock w
# w = if (isMember TO_Quiet opts)
......@@ -422,10 +422,10 @@ log :: LogMessage` (Maybe LogMemory) *World -> *(Maybe LogMemory, *World)
log msg mem w
# mem = fromJust (mem <|> pure zero)
# (mem,w) = updateMemory msg mem w
| not needslog = (Just mem, w)
| not needslog = (?Just mem, w)
# (io,w) = stdio w
# io = io <<< toString (toJSON $ makeLogEntry msg mem) <<< "\n"
= (Just mem, snd (fclose io w))
= (?Just mem, snd (fclose io w))
where
needslog = case msg of (Sent _ _) = True; _ = False
......
......@@ -12,7 +12,7 @@ cacheKey :: (a -> CacheKey) | toString a
/**
* Check if for the hash of the argument a JSON file exists of type `b`.
*/
readCache :: !a !*World -> (!Maybe b, !*World) | toString a & JSONDecode{|*|} b
readCache :: !a !*World -> (! ?b, !*World) | toString a & JSONDecode{|*|} b
/**
* All keys of a certain type currently in the cache. The list is sorted in
......
......@@ -38,7 +38,7 @@ cacheKey = md5 o toString
toCacheFile :: !CacheType -> a -> FilePath | toString a
toCacheFile t = (</>) (cache_dir t) o cacheKey
readCache :: !a !*World -> (!Maybe b, !*World) | toString a & JSONDecode{|*|} b
readCache :: !a !*World -> (! ?b, !*World) | toString a & JSONDecode{|*|} b
readCache k w
# (files,w) = seqList [appFst error2mb o readFile (toCacheFile t k) \\ t <- cache_types] w
= (join $ fromJSON <$> fromString <$> foldl (<|>) empty files, w)
......
definition module Util.SimpleTCPServer
from StdOverloaded import class zero, class fromString, class toString
from StdMaybe import :: Maybe
from TCPIP import ::IPAddress, ::Port
from TCPIP import :: IPAddress, :: Port
:: LogMessage req res sentinfo
= Connected IPAddress
......@@ -11,14 +10,14 @@ from TCPIP import ::IPAddress, ::Port
| Disconnected
:: Logger req res logst sentinfo
:== (LogMessage req res sentinfo) (Maybe logst) *World -> *(Maybe logst, *World)
:== (LogMessage req res sentinfo) (?logst) *World -> *(?logst, *World)
:: Server req res st logst sentinfo =
{ handler :: !req -> .(st -> *(*World -> *(res, sentinfo, st, *World)))
, logger :: !Maybe (Logger req res logst sentinfo)
, logger :: ! ?(Logger req res logst sentinfo)
, port :: !Int
, connect_timeout :: !Maybe Int
, keepalive_timeout :: !Maybe Int
, connect_timeout :: ! ?Int
, keepalive_timeout :: ! ?Int
}
serve :: !(Server req res .st logst sentinfo) .st !*World -> *World | fromString req & toString res
implementation module Util.SimpleTCPServer
import StdEnv
import Data.Maybe
import System._Posix
import TCPIP
import qualified TCPIP
import qualified StdMaybe
from TCPIP import
:: IPAddress, :: Port, :: TimeoutReport, :: ByteSeq,
:: TCP_Listener_, :: TCP_RChannel_, :: TCP_SChannel_, :: DuplexChannel{..},
class ChannelEnv, class closeRChannel, class Receive, class Send,
instance == TimeoutReport,
instance toString ByteSeq,
instance ChannelEnv World,
instance closeRChannel TCP_Listener_, instance closeRChannel TCP_RChannel_,
instance Receive TCP_Listener_, instance Receive TCP_RChannel_,
instance Send TCP_SChannel_
instance zero (Logger a b s t) where zero = \_ _ w -> (undef, 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
# (ok, mbListener, w) = 'TCPIP'.openTCP_Listener server.port w
| not ok = abort ("Couldn't open port " +++ toString server.port +++ "\n")
# listener = fromJust mbListener
# listener = 'StdMaybe'.fromJust mbListener
# (_,w) = signal 17 1 w // SIGCHLD, SIG_IGN: no notification if child ps dies
# (listener, w) = loop listener w
= closeRChannel listener w
= 'TCPIP'.closeRChannel listener w
where
logger = fromMaybe zero server.logger
loop :: TCP_Listener *World -> (TCP_Listener, *World)
connect_timeout = case server.connect_timeout of ?Just to -> 'StdMaybe'.Just to; _ -> 'StdMaybe'.Nothing
keepalive_timeout = case server.keepalive_timeout of ?Just to -> 'StdMaybe'.Just to; _ -> 'StdMaybe'.Nothing
loop :: 'TCPIP'.TCP_Listener *World -> ('TCPIP'.TCP_Listener, *World)
loop li w
#! (tRep,conn,li,w) = receive_MT server.connect_timeout li w
| tRep <> TR_Success
#! (tRep,conn,li,w) = 'TCPIP'.receive_MT connect_timeout li w
| tRep <> 'TCPIP'.TR_Success
= (li,w)
#! (ip,{rChannel,sChannel}) = fromJust conn
#! (ip,{rChannel,sChannel}) = 'StdMaybe'.fromJust conn
#! (pid,w) = fork w
| pid < 0
= abort "fork failed\n"
| pid > 0 // Parent: handle new requests
# w = abortConnection sChannel (closeRChannel rChannel w)
# w = 'TCPIP'.abortConnection sChannel ('TCPIP'.closeRChannel rChannel w)
= loop li w
| otherwise // Child: handle current request
# w = closeRChannel li w
#! (logst,w) = logger (Connected ip) Nothing w
# w = 'TCPIP'.closeRChannel li w
#! (logst,w) = logger (Connected ip) ?None w
= handle logst st rChannel sChannel w
//handle :: (Maybe s) TCP_SChannel_ TCP_RChannel_ *World -> (TCP_Listener, *World)
handle logst st rChannel sChannel w
#! (tRep,msg,rChannel,w) = receive_MT server.keepalive_timeout rChannel w
| tRep <> TR_Success
#! (tRep,msg,rChannel,w) = 'TCPIP'.receive_MT keepalive_timeout rChannel w