Add newtype to the builtins database

Add newtype to the builtins database

implementation module Builtins

import StdBool
import StdEnum
import StdInt
import StdList
import StdOverloaded
import StdString

from Data.Func import $
import Data.List
import Data.Maybe
import Text

import Type

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_classes :: [(Location, ClassEntry)]
builtin_classes
	= [ ( 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"
	      , 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 $ TypeDoc
	        (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`.")
	        [] Nothing})
	  , ( Builtin "->"      [CLR 6 "4.6" "_Toc311798036"], {deft & tde_typedef.td_name = "(->)",
	      tde_typedef.td_args = [Var "a", Var "b"],
	      tde_doc = Just $ TypeDoc
	        (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`.")
	        ["The argument type", "The result type"]
	        Nothing})
	  , ( Builtin "()" [], {deft & tde_typedef.td_name="_Unit",
	      tde_doc = Just $ TypeDoc
	        (Just "The void / unit type.")
	        [] Nothing,
	      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}

	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"],
			{ deft
			& tde_typedef.td_name = toString (['_':k] ++ ['List'] ++ s)
			, tde_typedef.td_args = [Var "a"]
			, tde_doc = Just $ TypeDoc
				(Just $ "A" + kind + spine + " list.\n\n" + description)
				["The type of the list elements."]
				Nothing
			})
		where
			higherorder = toString (['[':k] ++ s` ++ [']'])
				with s` = if (s == ['!'] && k == []) [' !'] s
			lista       = toString (['[':k] ++ ['a':s] ++ [']'])
			listints    = toString (['[':k] ++ ['1,1,2,3,5':s] ++ [']'])
			listany     = toString (['[':k] ++ ['\\','w':s] ++ [']'])
			kind = case k of
				[]    ->  " normal"
				['#'] -> "n unboxed"
				['!'] ->  " head strict"
				['|'] -> "n overloaded"
			spine = case s of
				[]    -> ""
				['!'] -> " spine strict"

			description = "These types of list are available:\n\n" +
				"- {{`[a]`}}, a normal list\n" +
				"- {{`[#a]`}}, an unboxed head-strict list (elements are stored directly, without pointers)\n" +
				"- {{`[!a]`}}, a head-strict list (the first element is in root normal form)\n" +
				"- {{`[a!]`}}, a spine-strict list (the last element is known)\n" +
				"- {{`[#a!]`}}, an unboxed spine-strict list\n" +
				"- {{`[!a!]`}}, a head-strict spine-strict list\n" +
				"- {{`[|a]`}}, an overloaded list (one of the types above)"

	arrays = [make_array kind \\ kind <- [[], ['!'], ['#']]]
	where
		make_array :: [Char] -> (Location, TypeDefEntry)
		make_array k = (Builtin typec [CLR 6 "4.4" "_Toc311798029"],
			{ deft
			& tde_typedef.td_name = toString (['_':k] ++ ['Array'])
			, tde_typedef.td_args = [Var "a"]
			, tde_doc = Just $ TypeDoc
				(Just $ "An array contains a finite number of elements of the same type. Access time is constant.\n\n" + description)
				["The type of the array elements."]
				Nothing
			})
		where
			typec = toString (['{':k]++['}'])

			description = "These types of array are available:\n\n" +
				"- `{a}`, a normal array\n" +
				"- `{#a}`, an unboxed strict array (elements are stored directly, without pointers)\n" +
				"- `{!a}`, a strict array (the elements are in root normal form)"

	tuples = [make_tuple n \\ n <- [2..32]]
	where
		make_tuple :: Int -> (Location, TypeDefEntry)
		make_tuple n = (Builtin typec [CLR 6 "4.3" "_Toc311798026"],
			{ deft
			& 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
				(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.")
				[] Nothing
			})
		where
			typec = toString ['(':repeatn (n-1) ',' ++ [')']]
			ary = case n of
				2 -> "bin"
				3 -> "tern"
				n -> n <+ "-"
			article = case n of
				11 -> "An"
				18 -> "An"
				_  -> "A"

builtin_syntax :: [([String], SyntaxEntry)]
builtin_syntax =
	[ bs_case
	, bs_class
	, bs_code
	, bs_define_constant
	, bs_define_graph
	, bs_dotdot
	, bs_exists
	, bs_forall
	, bs_generic
	, bs_import
	, bs_infix
	, bs_instance
	, bs_lambda
	, bs_layout_rule
	, bs_let
	, bs_let_before
	, bs_list_expressions
	, bs_macro
	, bs_module
	, bs_newtype
	, bs_otherwise
	, bs_pattern_named
	, bs_selection_array
	, bs_selection_array_unique
	, bs_selection_record
	, bs_selection_record_unique
	, bs_strict
	, bs_synonym
	, bs_synonym_abstract
	, bs_update_array
	, bs_update_record
	, bs_where_class
	, bs_where_instance
	, bs_where_local
	, bs_with
	, bs_zf
	]

CLR :: Int String String -> CleanLangReportLocation
CLR f sec h =
	{ clr_version = v
	, clr_file    = "CleanRep." + v + "_" <+ f <+ ".htm"
	, clr_section = sec
	, clr_heading = h
	}
where v = "2.2"

EX :: String String -> SyntaxExample
EX t c = {example=c, cleanjs_type=t, cleanjs_start=Nothing}
EXs :: String String String -> SyntaxExample
EXs t s c = {example=c, cleanjs_type=t, cleanjs_start=Just s}

bs_case = (["case", "of", "case of"],
	{ syntax_title         = "case expression"
	, syntax_code          = ["case ... of ..."]
	, syntax_description   = "Pattern match on an expression and do something depending on the alternative of the matching pattern."
	, syntax_doc_locations = [CLR 5 "3.4.2" "_Toc311798001"]
	, syntax_examples      =
		[ EXs "Function" "macro" "isJust m = case m of\n\tJust _ -> True\n\t_      -> False"
		]
	})

bs_class = (["class"],
	{ syntax_title         = "class"
	, syntax_code          =
		[ "class ... ... :: ..."
		, "class ... ... where ..."
		]
	, syntax_description   =
		"Classes are (sets of) overloaded functions. For classes with only one member function, a simplified syntax exists.\n\n" +
		"Types can instantiate classes with the {{`instance`}} keyword."
	, syntax_doc_locations = [CLR 8 "6.1" "_Toc311798056"]
	, syntax_examples      = map (EX "ClassDef")
		[ "class zero a :: a // one member" // TODO highlighting
		, "class Text s      // multiple members\nwhere\n\ttextSize :: !s -> Int\n\tconcat :: ![s] -> s\n\t// ..." // TODO highlighting
		]
	})

bs_code = (["code", "inline", "code inline"],
	{ syntax_title         = "ABC code"
	, syntax_code          = ["... = code [inline] { ... }"]
	, syntax_description   =
		"A code block with raw ABC instructions, which can be used for primitive functions like integer addition, for linking with C, bypassing the type system... welcome down the rabbit hole!\n\n" +
		"When `inline` is used, the function will be inlined when applied in a strict context."
	, syntax_doc_locations = [CLR 13 "11.2" "_Toc311798115"]
	, syntax_examples      = map (EX "Function") // TODO highlighting
		[ "add :: !Int !Int -> Int                   // Primitive function\nadd a b = code inline {\n\taddI\n}"
		, "sleep :: !Int !*World -> *(!Int, !*World) // Linking with C\nsleep n w = code {\n\tccall sleep \"I:I:A\"\n}"
		, "cast :: !.a -> .b                         // Bypassing the type system\ncast _ = code {\n\tpop_a 1\n}"
		]
	})

bs_define_constant = (["=:"],
	{ syntax_title         = "graph definition"
	, syntax_code          = ["... =: ..."]
	, syntax_description   =
		"Defining constants with `=:` at the top level makes sure they are shared through out the program; hence, they are evaluated only once.\n\n" +
		"This is the default understanding of `=` in local scope.\n\n" +
		"The inverse is {{`=>`}}, which defines an identifier to be a constant function."
	, syntax_doc_locations = [CLR 5 "3.6" "_Toc311798007"]
	, syntax_examples      = [EXs "Function" "macro" "mylist =: [1..10000]"]
	})
bs_define_graph = (["=>"],
	{ syntax_title         = "constant function definition"
	, syntax_code          = ["... => ..."]
	, syntax_description   =
		"Defining constants with `=>` at the top level makes sure they are interpreted as constant functions; hence, they are evaluated every time they are needed.\n\n" +
		"This is the default understanding of `=` in global scope.\n\n" +
		"The inverse is {{`=:`}}, which defines an identifier to be a graph."
	, syntax_doc_locations = [CLR 5 "3.6" "_Toc311798007"]
	, syntax_examples      = [EXs "Function" "macro" "mylist => [1..10000]"]
	})

bs_dotdot = (["[\\e..]", "[\\e..\e]", "[\\e,\\e..]", "[[\\e,\\e..\\e]", "dotdot", "dot-dot"],
	{ syntax_title         = "dotdot expression"
	, syntax_code          = ["[i..]", "[i..k]", "[i,j..]", "[i,j..k]"]
	, syntax_description   =
		"A shorthand for lists of enumerable types.\n\n" +
		"To use these expressions, you must import {{`StdEnum`}}. The underlying functions are defined in {{`_SystemEnum`}}."
	, syntax_doc_locations = [CLR 6 "4.2.1" "_Toc311798023"]
	, syntax_examples      = map (EXs "Function" "macro")
		[ "xs = [0..]     // 0, 1, 2, 3, ..."
		, "xs = [0,2..]   // 0, 2, 4, 6, ..."
		, "xs = [0..10]   // 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10"
		, "xs = [0,2..10] // 0, 2, 4, 6, 8, 10"
		]
	})

bs_exists = (["E", "E.*"],
	{ syntax_title         = "existential quantifier"
	, syntax_code          = [":: ... = E. ...: ..."]
	, syntax_description   = "Existential quantifiers make it possible to define (recursive) objects of the same type with different types of content."
	, syntax_doc_locations = [CLR 7 "5.1.3" "_Toc311798042"]
	, syntax_examples      = [EX "Function" ":: List = E.e: Cons e List | Nil\nStart = Cons 5 (Cons 'a' (Cons \"abc\" Nil))"] // TODO highlighting
	})

bs_forall = (["A", "A.*"],
	{ syntax_title         = "universal quantifier"
	, syntax_code          = ["A. ...:"]
	, syntax_description   = "Explicitly marks polymorphic type variables. Clean does not yet allow universal quantifiers on the topmost level."
	, syntax_doc_locations = [CLR 5 "3.7.4" "_Toc311798013"]
	, syntax_examples      =
		[ EX "Function" "hd :: A.a: [a] -> a           // Not yet allowed: A. on the topmost level"
		, EX "Function" "h :: (A.a: [a] -> Int) -> Int // The quantifier is needed to apply the function to both a [Int] and a [Char]\nh f = f [1..100] + f ['a'..'z']"
		, EX "TypeDef"  ":: T = C (A.a: a -> a)        // In a type"
		]
	})

bs_generic = (["generic", "derive", "of", "{|*|}"], // This * matches everything, which is intentional
	{ syntax_title         = "generic function definition"
	, syntax_code          = ["generic ... ... :: ...", "derive ... ..."]
	, syntax_description   = "With generics, a function can be defined once and derived for (almost) all possible types, to avoid very similar code snippets."
	, syntax_doc_locations = [CLR 9 "7.2" "_Toc311798069"]
	, syntax_examples      =
		[ EX  "Function"           "generic gEq a :: !a !a -> Bool        // The type of a generic function"
		, EXs "Function" "macro" $ "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" // TODO highlighting
		, EX  "Function"           "derive gEq []                         // Deriving the gEq generic for type []"
		, EXs "Function" "macro"   "gConsName{|CONS of d|} _ = d.gcd_name // Using type information"
		]
	})

bs_import = (["import", "from", "qualified", "as"],
	{ syntax_title         = "imports"
	, syntax_code          = ["import [qualified] ... [as ...]", "from ... import ..."]
	, syntax_description   =
		"Imports code from other modules.\n\n" +
		"With the `from` keyword, one can achieve more granularity.\n\n" +
		"In case of name clashes, `qualified` can be used (undocumented)."
	, syntax_doc_locations = [CLR 4 "2.5" "_Toc311797991"]
	, syntax_examples      = map (EX "Function")
		[ "import ..."
		, "import StdEnv                  // Import all code from the StdEnv definition module"
		, "from StdFunc import o          // Import only the o function from StdFunc"
		, "import qualified Data.Map as M // Import Data.Map such that functions are available as e.g. 'M'.get."
		]
	})

bs_infix = (["infix", "infixl", "infixr"],
	{ syntax_title         = "infix operator"
	, syntax_code          = ["infix[l,r] [...]"]
	, syntax_description   =
		"Defines a function with arity 2 that can be used in infix position.\n\n" +
		"The following number, if any, determines the precedence.\n\n" +
		"`infixl` and `infixr` indicate associativity."
	, syntax_doc_locations = [CLR 5 "3.7.2" "_Toc311798011"]
	, syntax_examples      =
		[ EX  "Function"         "(bitor) infixl 6 :: !Int !Int -> Int // Left-associative infix function with precedence 6"
		, EXs "Function" "macro" "(o) infixr 9                         // Infix macro\n(o) f g :== \\x -> f (g x)"
		, EX  "TypeDef"          ":: MyType = (:+:) infixl 6 Int Int   // Infix data constructor, can be used as (5 :+: 10)"
		]
	})

bs_instance = (["instance"],
	{ syntax_title         = "instance"
	, syntax_code          = ["instance ... ... where ..."]
	, syntax_description   = "Defines an instantiation of a {{class}} for a type."
	, syntax_doc_locations = [CLR 8 "6.1" "_Toc311798056"]
	, syntax_examples      = map (EX "Function")
		[ "instance zero Int\nwhere\n\tzero = 0"
		, "instance zero Real\nwhere\n\tzero = 0.0"
		]
	})

bs_lambda = (["lambda", "\\*", "->", "."],
	{ syntax_title         = "lambda abstraction"
	, syntax_code          = ["\\... -> ...", "\\... . ...", "\\... = ..."]
	, syntax_description   = "An anonymous, inline function."
	, syntax_doc_locations = [CLR 5 "3.4.1" "_Toc311798000"]
	, syntax_examples      = map (EXs "Function" "macro")
		[ "(o) f g = \\x -> f (g x)         // Simple lambda expression"
		, "swapall = map (\\(x,y) -> (y,x)) // Pattern matching in lambda arguments"
		, "mul     = \\x y -> x * y         // Multiple arguments (of course, it would be better to write `mul x y = x * y` or `mul = (*)`)"
		]
	})

bs_layout_rule = ([";", "{", "}"],
	{ syntax_title         = "layout rule"
	, syntax_code          = ["...;", "{ ... }"]
	, syntax_description   =
		"Most Clean programs are written using the layout rule, which means that scopes are indicated with indent levels." +
		"The layout sensitive mode can be turned off by adding a semicolon `;` at the end of the {{module}} line." +
		"Then, scopes have to be indicated with `{ ... }` and definitions have to end with `;`."
	, syntax_doc_locations = [CLR 4 "2.3.3" "_Toc311797989"]
	, syntax_examples      = [EX "Module" $
		"module test;\n" +
		"import StdEnv;\n" +
		"Start :: [(Int,Int)];\n" +
		"Start = [(x,y) \\\\ x <- odds, y <- evens];\n" +
		"where\n" +
		"{\n" +
		"\todds  = [1,3..9];\n" +
		"\tevens = [0,2..8];\n" +
		"}"]
	})

bs_let = (["let", "in", "let in"],
	{ syntax_title         = "let expression"
	, syntax_code          = ["let ... in ..."]
	, syntax_description   = "An expression that introduces new scope."
	, syntax_doc_locations = [CLR 5 "3.5.1" "_Toc311798003"]
	, syntax_examples      =
		[ EXs "Function" "macro"    "fac n = let fs = [1:1:[(fs!!(i-1)) + (fs!!(i-2)) \\ i <- [2..]]] in fs !! n"
		, EXs "Function" "macrorhs" "let // Multi-line let expressions\n\tfunction args = body\n\tselector = expr\n\t// ...\nin expression"
		]
	})
bs_let_before = (["#", "#!"],
	{ syntax_title         = "let before"
	, syntax_code          = ["#  ... = ...", "#! ... = ..."]
	, syntax_description   = "A {{`let`}} expression that can be defined before a guard or function body, which eases the syntax of sequential actions."
	, syntax_doc_locations = [CLR 5 "3.5.4" "_Toc311798006"]
	, syntax_examples      =
		[ EX "Function" "readchars :: *File -> *([Char], *File)\nreadchars f\n# (ok,c,f) = freadc file\n| not ok   = ([], f)\n# (cs,f)   = readchars f\n= ([c:cs], f)"
		]
	})

bs_list_expressions = (["list", "[]", "[:]", ":", "[\\e:\\e]", "['*"],
	{ syntax_title         = "list expression"
	, syntax_code          = ["[]", "[...:...]", "[..., ..., ...]", "['...']"]
	, syntax_description   =
		"A list can be composed of individual elements or a head and a tail. Special syntax is available for creating `[{{Char}}]` lists.\n\n" +
		"See also {{dotdot}} expressions.\n\n" +
		"The colon is not an operator in Clean, because it must always be surrounded by `[` and `]`. It can therefore not be curried, flipped, etc."
	, syntax_doc_locations = [CLR 6 "4.2.1" "_Toc311798021"]
	, syntax_examples      = map (EXs "Function" "macro")
		[ "abc = ['a', 'b', 'c']     // Individual elements"
		, "abc = ['a':['b':['c':[]]] // Head and tail, ending with the empty list"
		, "abc = ['abc']             // Special syntax for [Char] lists"
		]
	})

bs_macro = ([":==", "macro"],
	{ syntax_title         = "macro"
	, syntax_code          = ["... :== ..."]
	, syntax_description   =
		"A macro is a compile-time rewrite rule. It can be used for constants, inline subtitutions, renaming functions, conditional compilation, etc.\n\n" +
		"Macros can appear in patterns to match on constants."
	, syntax_doc_locations = [CLR 12 "10.3" "_Toc311798111"]
	, syntax_examples      = map (EXs "Function" "macro")
		[ "flip f a b :== f b a                    // Useful for currying"
		, "IF_INT_64_OR_32 int64 int32 :== int64   // Conditional compilation"
		, "(o) infixr 9                            // Function composition. Doing this at run-time would be slow\n(o) f g :== \\x -> f (g x)"
		]
	})

bs_module = (["module", "definition", "implementation", "system", "definition module", "implementation module", "system module"],
	{ syntax_title         = "module heading"
	, syntax_code          = ["[definition,implementation,system] module ..."]
	, syntax_description   = "The heading of a Clean file. Definition modules describe what things are exported (dcl files), implementation modules how they are implemented (icl files)."
	, syntax_doc_locations = [CLR 4 "2.2" "_Toc311797983"]
	, syntax_examples      = map (EX "Function")
		[ "definition module ..."
		, "definition module StdList     // Exported definitions of list functions"
		, "implementation module StdList // The implementations of the functions"
		, "module test                   // An implementation module without corresponding dcl"
		, "system module StdInt          // The definitions of a module that contains foreign code (see section 2.6 of the language report)"
		]
	})

bs_pattern_named = (["=:"],
	{ syntax_title         = "newtype definition (experimental)"
	, syntax_code          = [":: ... =: T c"]
	, syntax_description   = "Define a newtype, a newtype is a type synonym that is treated as a real type."
	, syntax_doc_locations = []
	, syntax_examples      =
		[ EX  "Function"         ":: T = T Int"
		]
	})

bs_otherwise = (["otherwise"],
	{ syntax_title         = "otherwise"
	, syntax_code          = ["otherwise"]
	, syntax_description   = "The (optional) last alternative in a guard. It caches all other cases, and makes sure your program does not crash if none of the cases matches."
	, syntax_doc_locations = [CLR 5 "3.3" "_Toc311797998"]
	, syntax_examples      =
		[ EXs "Function" "macrorhs" "| otherwise = ..."
		, EXs "Function" "macro"    "sign :: !Int -> Int\nsign n\n| n  < 0    = -1 // Negative number\n| n == 0    =  0 // Zero\n| otherwise =  1 // Must be positive"
		]
	})

bs_pattern_named = (["=:"],
	{ syntax_title         = "named pattern match"
	, 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 5 "3.2" "_Toc311797997"]
	, syntax_examples      =
		[ EXs "Function" "macro" "isJustU e=:(Just _) = (True, e) // On an ADT"
		, EX  "Function"         ":: Position = {px :: Int, py :: Int}\ngetx p=:{px} = (px, p) // On a record; this has type :: Position -> (Int, Position)"
		]
	})

bs_selection_array = ([".[]", ".[\\e]", ".[,*]", ".[\\e,*]"],
	{ syntax_title         = "array selection"
	, syntax_code          = [".[i]", ".[i,j,...]"]
	, syntax_description   = "Select an element from a (possibly multidimensional) array. The indexes must have the type {{`Int`}}."
	, syntax_doc_locations = [CLR 6 "4.4.1" "_Toc311798033"]
	, syntax_examples      = map (EXs "Function" "macro")
		[ "five = {1,2,3,4,5,6,7,8,9,10}.[4]    // Arrays are zero-indexed"
		, "five = {{1,2},{3,4,5},{6,7,8}}.[1,2] // This is equivalent to (...).[1].[2]"
		]
	})
bs_selection_array_unique = (["![]", "![\\e]", "![,*]", "![\\e,*]"],
	{ syntax_title         = "unique array selection"
	, syntax_code          = ["![i]", "![i,j,...]"]
	, syntax_description   = "Select an element from a (possibly multidimensional, possibly unique) array and return both the element and the array. The indexes must have the type {{`Int`}}."
	, syntax_doc_locations = [CLR 6 "4.4.1" "_Toc311798033"]
	, syntax_examples      = map (EXs "Function" "macro")
		[ "(five,arr) = {1,2,3,4,5,6,7,8,9,10}![4]"
		, "(five,arr) = {{1,2},{3,4,5},{6,7,8}}![1,2]"
		]
	})
bs_selection_record = (["."],
	{ syntax_title         = "record selection"
	, syntax_code          = ["."]
	, syntax_description   = "Select a field from a (possibly multilevel) record."
	, syntax_doc_locations = [CLR 7 "5.2.1" "_Toc311798050"]
	, syntax_examples      = map (EXs "Function" "macro")
		[ "five = {px=5, py=10}.px"
		, "five = {pxy={px=5, py=10}, pz=2}.pxy.px"
		, "five = {px=5, py=10}.Position.px // If multiple records have a field px, the type name can be used for disambiguation"
		]
	})
bs_selection_record_unique = (["!"],
	{ syntax_title         = "unique record selection"
	, syntax_code          = ["!"]
	, syntax_description   = "Select a field from a (possibly multilevel, possibly unique) record and return both the field data and the record."
	, syntax_doc_locations = [CLR 7 "5.2.1" "_Toc311798050"]
	, syntax_examples      = map (EXs "Function" "macro")
		[ "(five,rec) = {px=5, py=10}!px"
		, "(five,rec) = {pxy={px=5, py=10}, pz=2}!pxy.px // Only the first field should have the exclamation mark"
		, "(five,rec) = {px=5, py=10}!Position.px // If multiple records have a field px, the type name can be used for disambiguation\n" +
		  "                                       // The language report is erroneous here. It is !Position.px, not .Position!px."
		]
	})

bs_strict = (["strict", "!"],
	{ syntax_title         = "strictness annotation"
	, syntax_code          = ["!"]
	, syntax_description   = "Override the lazy evaluation strategy: the argument must be evaluated to head normal form before the function is entered."
	, syntax_doc_locations = [CLR 5 "3.7.5" "_Toc311798014", CLR 12 "10" "_Toc311798103"]
	, syntax_examples      = [EX "Function" "acker :: !Int !Int -> Int"]
	})

bs_synonym = (["synonym", ":=="],
	{ syntax_title         = "synonym type definition"
	, syntax_code          = [":: ... :== ..."]
	, syntax_description   = "Defines a new type name for an existing type."
	, syntax_doc_locations = [CLR 7 "5.3" "_Toc311798052"]
	, syntax_examples      = [EX "TypeDef" ":: String :== {#Char}"]
	})
bs_synonym_abstract = (["synonym", ":=="],
	{ syntax_title         = "abstract synonym type definition"
	, syntax_code          = [":: ... (:== ...)"]
	, syntax_description   = "Defines a new type name for an existing type, while the type behaves as an abstract type for the programmer. This allows compiler optimisations on abstract types."
	, syntax_doc_locations = [CLR 7 "5.4.1" "_Toc311798054"]
	, syntax_examples      = [EX "TypeDef" ":: Stack a (:== [a])"]
	})

bs_update_array = (["&", "{*&*[\\e]*=*}"],
	{ syntax_title         = "array update"
	, syntax_code          =
		[ "{ a & [i]=x, [j]=y, ... } // Updates a by setting index i to x, j to y, ..."
		, "# a & [i]=x, [j]=y, ...   // Same as # a = {a & [i]=x, [j]=y, ...}" // See https://clean.cs.ru.nl/Clean_2.3
		]
	, syntax_description   = "Updates an array by creating a copy and replacing one or more elements."
	, syntax_doc_locations = [CLR 6 "4.4.1" "_Toc311798032"]
	, syntax_examples      = []
	})
bs_update_record = (["&", "{*&*=*}"],
	{ syntax_title         = "record update"
	, syntax_code          =
		[ "{ r & f1=x, f2=y, ... } // Updates r by setting f1 to x, f2 to y, ..."
		, "# r & f1=x, f2=y, ...   // Same as # r = {r & f1=x, f2=y, ...}" // See https://clean.cs.ru.nl/Clean_2.3
		]
	, syntax_description   = "Updates a record by creating a copy and replacing one or more fields."
	, syntax_doc_locations = [CLR 7 "5.2.1" "_Toc311798049"]
	, syntax_examples      = []
	})

bs_where_class = (["where"],
	{ syntax_title         = "where"
	, syntax_code          = ["where"]
	, syntax_description   = "Introduces the members of a {{`class`}} definition."
	, syntax_doc_locations = [CLR 8 "6.1"   "_Toc311798056"]
	, syntax_examples      = [EX "ClassDef" "class Arith a        // Class definition\nwhere\n\t(+) infixl 6 :: a a -> a\n\t(-) infixl 6 :: a a -> a"] // TODO highlighting
	})
bs_where_instance = (["where"],
	{ syntax_title         = "where"
	, syntax_code          = ["where"]
	, syntax_description   = "Introduces the implementation of an {{`instance`}}."
	, syntax_doc_locations = [CLR 8 "6.1"   "_Toc311798056"]
	, syntax_examples      = [EX "Function" "instance Arith Int   // Instance definition\nwhere\n\t(+) x y = // ...\n\t(-) x y = // ..."]
	})
bs_where_local = (["where"],
	{ syntax_title         = "where"
	, syntax_code          = ["where"]
	, syntax_description   = "Introduces local definitions. For guard-local definitions, see {{`with`}}."
	, syntax_doc_locations = [CLR 5 "3.5.2" "_Toc311798004"]
	, syntax_examples      = [EXs "Function" "macro" "primes = sieve [2..] // Local definitions\nwhere\n\tsieve [pr:r] = [pr:sieve (filter pr r)]"]
	})

bs_with = (["with"],
	{ syntax_title         = "with"
	, syntax_code          = ["with"]
	, syntax_description   = "Introduces guard-local definitions. For function-local definitions, see {{`where`}}."
	, syntax_doc_locations = [CLR 5 "3.5.3" "_Toc311798005"]
	, syntax_examples      = [EXs "Function" "macro" "f x y\n| guard1 = alt1\n\twith local = expr1\n| guard2 = alt2\n\twith local = expr2"]
	})

bs_zf = (["ZF-expression", "ZF", "zf", "comprehension", "<-", "<|-", "<-:", "\\\\", ",", "&", "|"],
	{ syntax_title         = "list comprehension"
	, syntax_code          = ["[... \\\\ ... <- ...]"]
	, syntax_description   = "Constructs a list composed of elements drawn from other lists or arrays."
	, syntax_doc_locations = [CLR 6 "4.2.1" "_Toc311798024"]
	, syntax_examples      = map (EXs "Function" "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"
		, "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]                        // <-: for arrays"
		, "castList xs  = [|x \\\\ x <|- xs]                      // The two pipe characters make both xs and the result overloaded lists"
		]
	})

implementation module Builtins

import StdBool
import StdEnum
import StdInt
import StdList
import StdOverloaded
import StdString

from Data.Func import $
import Data.List
import Data.Maybe
import Text

import Type

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_classes :: [(Location, ClassEntry)]
builtin_classes
	= [ ( 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"
	      , 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 $ TypeDoc
	        (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`.")
	        [] Nothing})
	  , ( Builtin "->"      [CLR 6 "4.6" "_Toc311798036"], {deft & tde_typedef.td_name = "(->)",
	      tde_typedef.td_args = [Var "a", Var "b"],
	      tde_doc = Just $ TypeDoc
	        (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`.")
	        ["The argument type", "The result type"]
	        Nothing})
	  , ( Builtin "()" [], {deft & tde_typedef.td_name="_Unit",
	      tde_doc = Just $ TypeDoc
	        (Just "The void / unit type.")
	        [] Nothing,
	      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}

	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"],
			{ deft
			& tde_typedef.td_name = toString (['_':k] ++ ['List'] ++ s)
			, tde_typedef.td_args = [Var "a"]
			, tde_doc = Just $ TypeDoc
				(Just $ "A" + kind + spine + " list.\n\n" + description)
				["The type of the list elements."]
				Nothing
			})
		where
			higherorder = toString (['[':k] ++ s` ++ [']'])
				with s` = if (s == ['!'] && k == []) [' !'] s
			lista       = toString (['[':k] ++ ['a':s] ++ [']'])
			listints    = toString (['[':k] ++ ['1,1,2,3,5':s] ++ [']'])
			listany     = toString (['[':k] ++ ['\\','w':s] ++ [']'])
			kind = case k of
				[]    ->  " normal"
				['#'] -> "n unboxed"
				['!'] ->  " head strict"
				['|'] -> "n overloaded"
			spine = case s of
				[]    -> ""
				['!'] -> " spine strict"

			description = "These types of list are available:\n\n" +
				"- {{`[a]`}}, a normal list\n" +
				"- {{`[#a]`}}, an unboxed head-strict list (elements are stored directly, without pointers)\n" +
				"- {{`[!a]`}}, a head-strict list (the first element is in root normal form)\n" +
				"- {{`[a!]`}}, a spine-strict list (the last element is known)\n" +
				"- {{`[#a!]`}}, an unboxed spine-strict list\n" +
				"- {{`[!a!]`}}, a head-strict spine-strict list\n" +
				"- {{`[|a]`}}, an overloaded list (one of the types above)"

	arrays = [make_array kind \\ kind <- [[], ['!'], ['#']]]
	where
		make_array :: [Char] -> (Location, TypeDefEntry)
		make_array k = (Builtin typec [CLR 6 "4.4" "_Toc311798029"],
			{ deft
			& tde_typedef.td_name = toString (['_':k] ++ ['Array'])
			, tde_typedef.td_args = [Var "a"]
			, tde_doc = Just $ TypeDoc
				(Just $ "An array contains a finite number of elements of the same type. Access time is constant.\n\n" + description)
				["The type of the array elements."]
				Nothing
			})
		where
			typec = toString (['{':k]++['}'])

			description = "These types of array are available:\n\n" +
				"- `{a}`, a normal array\n" +
				"- `{#a}`, an unboxed strict array (elements are stored directly, without pointers)\n" +
				"- `{!a}`, a strict array (the elements are in root normal form)"

	tuples = [make_tuple n \\ n <- [2..32]]
	where
		make_tuple :: Int -> (Location, TypeDefEntry)
		make_tuple n = (Builtin typec [CLR 6 "4.3" "_Toc311798026"],
			{ deft
			& 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
				(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.")
				[] Nothing
			})
		where
			typec = toString ['(':repeatn (n-1) ',' ++ [')']]
			ary = case n of
				2 -> "bin"
				3 -> "tern"
				n -> n <+ "-"
			article = case n of
				11 -> "An"
				18 -> "An"
				_  -> "A"

builtin_syntax :: [([String], SyntaxEntry)]
builtin_syntax =
	[ bs_case
	, bs_class
	, bs_code
	, bs_define_constant
	, bs_define_graph
	, bs_dotdot
	, bs_exists
	, bs_forall
	, bs_generic
	, bs_import
	, bs_infix
	, bs_instance
	, bs_lambda
	, bs_layout_rule
	, bs_let
	, bs_let_before
	, bs_list_expressions
	, bs_macro
	, bs_module
	, bs_otherwise
	, bs_pattern_named
	, bs_selection_array
	, bs_selection_array_unique
	, bs_selection_record
	, bs_selection_record_unique
	, bs_strict
	, bs_synonym
	, bs_synonym_abstract
	, bs_update_array
	, bs_update_record
	, bs_where_class
	, bs_where_instance
	, bs_where_local
	, bs_with
	, bs_zf
	]

CLR :: Int String String -> CleanLangReportLocation
CLR f sec h =
	{ clr_version = v
	, clr_file    = "CleanRep." + v + "_" <+ f <+ ".htm"
	, clr_section = sec
	, clr_heading = h
	}
where v = "2.2"

EX :: String String -> SyntaxExample
EX t c = {example=c, cleanjs_type=t, cleanjs_start=Nothing}
EXs :: String String String -> SyntaxExample
EXs t s c = {example=c, cleanjs_type=t, cleanjs_start=Just s}

bs_case = (["case", "of", "case of"],
	{ syntax_title         = "case expression"
	, syntax_code          = ["case ... of ..."]
	, syntax_description   = "Pattern match on an expression and do something depending on the alternative of the matching pattern."
	, syntax_doc_locations = [CLR 5 "3.4.2" "_Toc311798001"]
	, syntax_examples      =
		[ EXs "Function" "macro" "isJust m = case m of\n\tJust _ -> True\n\t_      -> False"
		]
	})

bs_class = (["class"],
	{ syntax_title         = "class"
	, syntax_code          =
		[ "class ... ... :: ..."
		, "class ... ... where ..."
		]
	, syntax_description   =
		"Classes are (sets of) overloaded functions. For classes with only one member function, a simplified syntax exists.\n\n" +
		"Types can instantiate classes with the {{`instance`}} keyword."
	, syntax_doc_locations = [CLR 8 "6.1" "_Toc311798056"]
	, syntax_examples      = map (EX "ClassDef")
		[ "class zero a :: a // one member" // TODO highlighting
		, "class Text s      // multiple members\nwhere\n\ttextSize :: !s -> Int\n\tconcat :: ![s] -> s\n\t// ..." // TODO highlighting
		]
	})

bs_code = (["code", "inline", "code inline"],
	{ syntax_title         = "ABC code"
	, syntax_code          = ["... = code [inline] { ... }"]
	, syntax_description   =
		"A code block with raw ABC instructions, which can be used for primitive functions like integer addition, for linking with C, bypassing the type system... welcome down the rabbit hole!\n\n" +
		"When `inline` is used, the function will be inlined when applied in a strict context."
	, syntax_doc_locations = [CLR 13 "11.2" "_Toc311798115"]
	, syntax_examples      = map (EX "Function") // TODO highlighting
		[ "add :: !Int !Int -> Int                   // Primitive function\nadd a b = code inline {\n\taddI\n}"
		, "sleep :: !Int !*World -> *(!Int, !*World) // Linking with C\nsleep n w = code {\n\tccall sleep \"I:I:A\"\n}"
		, "cast :: !.a -> .b                         // Bypassing the type system\ncast _ = code {\n\tpop_a 1\n}"
		]
	})

bs_define_constant = (["=:"],
	{ syntax_title         = "graph definition"
	, syntax_code          = ["... =: ..."]
	, syntax_description   =
		"Defining constants with `=:` at the top level makes sure they are shared through out the program; hence, they are evaluated only once.\n\n" +
		"This is the default understanding of `=` in local scope.\n\n" +
		"The inverse is {{`=>`}}, which defines an identifier to be a constant function."
	, syntax_doc_locations = [CLR 5 "3.6" "_Toc311798007"]
	, syntax_examples      = [EXs "Function" "macro" "mylist =: [1..10000]"]
	})
bs_define_graph = (["=>"],
	{ syntax_title         = "constant function definition"
	, syntax_code          = ["... => ..."]
	, syntax_description   =
		"Defining constants with `=>` at the top level makes sure they are interpreted as constant functions; hence, they are evaluated every time they are needed.\n\n" +
		"This is the default understanding of `=` in global scope.\n\n" +
		"The inverse is {{`=:`}}, which defines an identifier to be a graph."
	, syntax_doc_locations = [CLR 5 "3.6" "_Toc311798007"]
	, syntax_examples      = [EXs "Function" "macro" "mylist => [1..10000]"]
	})

bs_dotdot = (["[\\e..]", "[\\e..\e]", "[\\e,\\e..]", "[[\\e,\\e..\\e]", "dotdot", "dot-dot"],
	{ syntax_title         = "dotdot expression"
	, syntax_code          = ["[i..]", "[i..k]", "[i,j..]", "[i,j..k]"]
	, syntax_description   =
		"A shorthand for lists of enumerable types.\n\n" +
		"To use these expressions, you must import {{`StdEnum`}}. The underlying functions are defined in {{`_SystemEnum`}}."
	, syntax_doc_locations = [CLR 6 "4.2.1" "_Toc311798023"]
	, syntax_examples      = map (EXs "Function" "macro")
		[ "xs = [0..]     // 0, 1, 2, 3, ..."
		, "xs = [0,2..]   // 0, 2, 4, 6, ..."
		, "xs = [0..10]   // 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10"
		, "xs = [0,2..10] // 0, 2, 4, 6, 8, 10"
		]
	})

bs_exists = (["E", "E.*"],
	{ syntax_title         = "existential quantifier"
	, syntax_code          = [":: ... = E. ...: ..."]
	, syntax_description   = "Existential quantifiers make it possible to define (recursive) objects of the same type with different types of content."
	, syntax_doc_locations = [CLR 7 "5.1.3" "_Toc311798042"]
	, syntax_examples      = [EX "Function" ":: List = E.e: Cons e List | Nil\nStart = Cons 5 (Cons 'a' (Cons \"abc\" Nil))"] // TODO highlighting
	})

bs_forall = (["A", "A.*"],
	{ syntax_title         = "universal quantifier"
	, syntax_code          = ["A. ...:"]
	, syntax_description   = "Explicitly marks polymorphic type variables. Clean does not yet allow universal quantifiers on the topmost level."
	, syntax_doc_locations = [CLR 5 "3.7.4" "_Toc311798013"]
	, syntax_examples      =
		[ EX "Function" "hd :: A.a: [a] -> a           // Not yet allowed: A. on the topmost level"
		, EX "Function" "h :: (A.a: [a] -> Int) -> Int // The quantifier is needed to apply the function to both a [Int] and a [Char]\nh f = f [1..100] + f ['a'..'z']"
		, EX "TypeDef"  ":: T = C (A.a: a -> a)        // In a type"
		]
	})

bs_generic = (["generic", "derive", "of", "{|*|}"], // This * matches everything, which is intentional
	{ syntax_title         = "generic function definition"
	, syntax_code          = ["generic ... ... :: ...", "derive ... ..."]
	, syntax_description   = "With generics, a function can be defined once and derived for (almost) all possible types, to avoid very similar code snippets."
	, syntax_doc_locations = [CLR 9 "7.2" "_Toc311798069"]
	, syntax_examples      =
		[ EX  "Function"           "generic gEq a :: !a !a -> Bool        // The type of a generic function"
		, EXs "Function" "macro" $ "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" // TODO highlighting
		, EX  "Function"           "derive gEq []                         // Deriving the gEq generic for type []"
		, EXs "Function" "macro"   "gConsName{|CONS of d|} _ = d.gcd_name // Using type information"
		]
	})

bs_import = (["import", "from", "qualified", "as"],
	{ syntax_title         = "imports"
	, syntax_code          = ["import [qualified] ... [as ...]", "from ... import ..."]
	, syntax_description   =
		"Imports code from other modules.\n\n" +
		"With the `from` keyword, one can achieve more granularity.\n\n" +
		"In case of name clashes, `qualified` can be used (undocumented)."
	, syntax_doc_locations = [CLR 4 "2.5" "_Toc311797991"]
	, syntax_examples      = map (EX "Function")
		[ "import ..."
		, "import StdEnv                  // Import all code from the StdEnv definition module"
		, "from StdFunc import o          // Import only the o function from StdFunc"
		, "import qualified Data.Map as M // Import Data.Map such that functions are available as e.g. 'M'.get."
		]
	})

bs_infix = (["infix", "infixl", "infixr"],
	{ syntax_title         = "infix operator"
	, syntax_code          = ["infix[l,r] [...]"]
	, syntax_description   =
		"Defines a function with arity 2 that can be used in infix position.\n\n" +
		"The following number, if any, determines the precedence.\n\n" +
		"`infixl` and `infixr` indicate associativity."
	, syntax_doc_locations = [CLR 5 "3.7.2" "_Toc311798011"]
	, syntax_examples      =
		[ EX  "Function"         "(bitor) infixl 6 :: !Int !Int -> Int // Left-associative infix function with precedence 6"
		, EXs "Function" "macro" "(o) infixr 9                         // Infix macro\n(o) f g :== \\x -> f (g x)"
		, EX  "TypeDef"          ":: MyType = (:+:) infixl 6 Int Int   // Infix data constructor, can be used as (5 :+: 10)"
		]
	})

bs_instance = (["instance"],
	{ syntax_title         = "instance"
	, syntax_code          = ["instance ... ... where ..."]
	, syntax_description   = "Defines an instantiation of a {{class}} for a type."
	, syntax_doc_locations = [CLR 8 "6.1" "_Toc311798056"]
	, syntax_examples      = map (EX "Function")
		[ "instance zero Int\nwhere\n\tzero = 0"
		, "instance zero Real\nwhere\n\tzero = 0.0"
		]
	})

bs_lambda = (["lambda", "\\*", "->", "."],
	{ syntax_title         = "lambda abstraction"
	, syntax_code          = ["\\... -> ...", "\\... . ...", "\\... = ..."]
	, syntax_description   = "An anonymous, inline function."
	, syntax_doc_locations = [CLR 5 "3.4.1" "_Toc311798000"]
	, syntax_examples      = map (EXs "Function" "macro")
		[ "(o) f g = \\x -> f (g x)         // Simple lambda expression"
		, "swapall = map (\\(x,y) -> (y,x)) // Pattern matching in lambda arguments"
		, "mul     = \\x y -> x * y         // Multiple arguments (of course, it would be better to write `mul x y = x * y` or `mul = (*)`)"
		]
	})

bs_layout_rule = ([";", "{", "}"],
	{ syntax_title         = "layout rule"
	, syntax_code          = ["...;", "{ ... }"]
	, syntax_description   =
		"Most Clean programs are written using the layout rule, which means that scopes are indicated with indent levels." +
		"The layout sensitive mode can be turned off by adding a semicolon `;` at the end of the {{module}} line." +
		"Then, scopes have to be indicated with `{ ... }` and definitions have to end with `;`."
	, syntax_doc_locations = [CLR 4 "2.3.3" "_Toc311797989"]
	, syntax_examples      = [EX "Module" $
		"module test;\n" +
		"import StdEnv;\n" +
		"Start :: [(Int,Int)];\n" +
		"Start = [(x,y) \\\\ x <- odds, y <- evens];\n" +
		"where\n" +
		"{\n" +
		"\todds  = [1,3..9];\n" +
		"\tevens = [0,2..8];\n" +
		"}"]
	})

bs_let = (["let", "in", "let in"],
	{ syntax_title         = "let expression"
	, syntax_code          = ["let ... in ..."]
	, syntax_description   = "An expression that introduces new scope."
	, syntax_doc_locations = [CLR 5 "3.5.1" "_Toc311798003"]
	, syntax_examples      =
		[ EXs "Function" "macro"    "fac n = let fs = [1:1:[(fs!!(i-1)) + (fs!!(i-2)) \\ i <- [2..]]] in fs !! n"
		, EXs "Function" "macrorhs" "let // Multi-line let expressions\n\tfunction args = body\n\tselector = expr\n\t// ...\nin expression"
		]
	})
bs_let_before = (["#", "#!"],
	{ syntax_title         = "let before"
	, syntax_code          = ["#  ... = ...", "#! ... = ..."]
	, syntax_description   = "A {{`let`}} expression that can be defined before a guard or function body, which eases the syntax of sequential actions."
	, syntax_doc_locations = [CLR 5 "3.5.4" "_Toc311798006"]
	, syntax_examples      =
		[ EX "Function" "readchars :: *File -> *([Char], *File)\nreadchars f\n# (ok,c,f) = freadc file\n| not ok   = ([], f)\n# (cs,f)   = readchars f\n= ([c:cs], f)"
		]
	})

bs_list_expressions = (["list", "[]", "[:]", ":", "[\\e:\\e]", "['*"],
	{ syntax_title         = "list expression"
	, syntax_code          = ["[]", "[...:...]", "[..., ..., ...]", "['...']"]
	, syntax_description   =
		"A list can be composed of individual elements or a head and a tail. Special syntax is available for creating `[{{Char}}]` lists.\n\n" +
		"See also {{dotdot}} expressions.\n\n" +
		"The colon is not an operator in Clean, because it must always be surrounded by `[` and `]`. It can therefore not be curried, flipped, etc."
	, syntax_doc_locations = [CLR 6 "4.2.1" "_Toc311798021"]
	, syntax_examples      = map (EXs "Function" "macro")
		[ "abc = ['a', 'b', 'c']     // Individual elements"
		, "abc = ['a':['b':['c':[]]] // Head and tail, ending with the empty list"
		, "abc = ['abc']             // Special syntax for [Char] lists"
		]
	})

bs_macro = ([":==", "macro"],
	{ syntax_title         = "macro"
	, syntax_code          = ["... :== ..."]
	, syntax_description   =
		"A macro is a compile-time rewrite rule. It can be used for constants, inline subtitutions, renaming functions, conditional compilation, etc.\n\n" +
		"Macros can appear in patterns to match on constants."
	, syntax_doc_locations = [CLR 12 "10.3" "_Toc311798111"]
	, syntax_examples      = map (EXs "Function" "macro")
		[ "flip f a b :== f b a                    // Useful for currying"
		, "IF_INT_64_OR_32 int64 int32 :== int64   // Conditional compilation"
		, "(o) infixr 9                            // Function composition. Doing this at run-time would be slow\n(o) f g :== \\x -> f (g x)"
		]
	})

bs_module = (["module", "definition", "implementation", "system", "definition module", "implementation module", "system module"],
	{ syntax_title         = "module heading"
	, syntax_code          = ["[definition,implementation,system] module ..."]
	, syntax_description   = "The heading of a Clean file. Definition modules describe what things are exported (dcl files), implementation modules how they are implemented (icl files)."
	, syntax_doc_locations = [CLR 4 "2.2" "_Toc311797983"]
	, syntax_examples      = map (EX "Function")
		[ "definition module ..."
		, "definition module StdList     // Exported definitions of list functions"
		, "implementation module StdList // The implementations of the functions"
		, "module test                   // An implementation module without corresponding dcl"
		, "system module StdInt          // The definitions of a module that contains foreign code (see section 2.6 of the language report)"
		]
	})

bs_otherwise = (["otherwise"],
	{ syntax_title         = "otherwise"
	, syntax_code          = ["otherwise"]
	, syntax_description   = "The (optional) last alternative in a guard. It caches all other cases, and makes sure your program does not crash if none of the cases matches."
	, syntax_doc_locations = [CLR 5 "3.3" "_Toc311797998"]
	, syntax_examples      =
		[ EXs "Function" "macrorhs" "| otherwise = ..."
		, EXs "Function" "macro"    "sign :: !Int -> Int\nsign n\n| n  < 0    = -1 // Negative number\n| n == 0    =  0 // Zero\n| otherwise =  1 // Must be positive"
		]
	})

bs_pattern_named = (["=:"],
	{ syntax_title         = "named pattern match"
	, 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 5 "3.2" "_Toc311797997"]
	, syntax_examples      =
		[ EXs "Function" "macro" "isJustU e=:(Just _) = (True, e) // On an ADT"
		, EX  "Function"         ":: Position = {px :: Int, py :: Int}\ngetx p=:{px} = (px, p) // On a record; this has type :: Position -> (Int, Position)"
		]
	})

bs_selection_array = ([".[]", ".[\\e]", ".[,*]", ".[\\e,*]"],
	{ syntax_title         = "array selection"
	, syntax_code          = [".[i]", ".[i,j,...]"]
	, syntax_description   = "Select an element from a (possibly multidimensional) array. The indexes must have the type {{`Int`}}."
	, syntax_doc_locations = [CLR 6 "4.4.1" "_Toc311798033"]
	, syntax_examples      = map (EXs "Function" "macro")
		[ "five = {1,2,3,4,5,6,7,8,9,10}.[4]    // Arrays are zero-indexed"
		, "five = {{1,2},{3,4,5},{6,7,8}}.[1,2] // This is equivalent to (...).[1].[2]"
		]
	})
bs_selection_array_unique = (["![]", "![\\e]", "![,*]", "![\\e,*]"],
	{ syntax_title         = "unique array selection"
	, syntax_code          = ["![i]", "![i,j,...]"]
	, syntax_description   = "Select an element from a (possibly multidimensional, possibly unique) array and return both the element and the array. The indexes must have the type {{`Int`}}."
	, syntax_doc_locations = [CLR 6 "4.4.1" "_Toc311798033"]
	, syntax_examples      = map (EXs "Function" "macro")
		[ "(five,arr) = {1,2,3,4,5,6,7,8,9,10}![4]"
		, "(five,arr) = {{1,2},{3,4,5},{6,7,8}}![1,2]"
		]
	})
bs_selection_record = (["."],
	{ syntax_title         = "record selection"
	, syntax_code          = ["."]
	, syntax_description   = "Select a field from a (possibly multilevel) record."
	, syntax_doc_locations = [CLR 7 "5.2.1" "_Toc311798050"]
	, syntax_examples      = map (EXs "Function" "macro")
		[ "five = {px=5, py=10}.px"
		, "five = {pxy={px=5, py=10}, pz=2}.pxy.px"
		, "five = {px=5, py=10}.Position.px // If multiple records have a field px, the type name can be used for disambiguation"
		]
	})
bs_selection_record_unique = (["!"],
	{ syntax_title         = "unique record selection"
	, syntax_code          = ["!"]
	, syntax_description   = "Select a field from a (possibly multilevel, possibly unique) record and return both the field data and the record."
	, syntax_doc_locations = [CLR 7 "5.2.1" "_Toc311798050"]
	, syntax_examples      = map (EXs "Function" "macro")
		[ "(five,rec) = {px=5, py=10}!px"
		, "(five,rec) = {pxy={px=5, py=10}, pz=2}!pxy.px // Only the first field should have the exclamation mark"
		, "(five,rec) = {px=5, py=10}!Position.px // If multiple records have a field px, the type name can be used for disambiguation\n" +
		  "                                       // The language report is erroneous here. It is !Position.px, not .Position!px."
		]
	})

bs_strict = (["strict", "!"],
	{ syntax_title         = "strictness annotation"
	, syntax_code          = ["!"]
	, syntax_description   = "Override the lazy evaluation strategy: the argument must be evaluated to head normal form before the function is entered."
	, syntax_doc_locations = [CLR 5 "3.7.5" "_Toc311798014", CLR 12 "10" "_Toc311798103"]
	, syntax_examples      = [EX "Function" "acker :: !Int !Int -> Int"]
	})

bs_synonym = (["synonym", ":=="],
	{ syntax_title         = "synonym type definition"
	, syntax_code          = [":: ... :== ..."]
	, syntax_description   = "Defines a new type name for an existing type."
	, syntax_doc_locations = [CLR 7 "5.3" "_Toc311798052"]
	, syntax_examples      = [EX "TypeDef" ":: String :== {#Char}"]
	})
bs_synonym_abstract = (["synonym", ":=="],
	{ syntax_title         = "abstract synonym type definition"
	, syntax_code          = [":: ... (:== ...)"]
	, syntax_description   = "Defines a new type name for an existing type, while the type behaves as an abstract type for the programmer. This allows compiler optimisations on abstract types."
	, syntax_doc_locations = [CLR 7 "5.4.1" "_Toc311798054"]
	, syntax_examples      = [EX "TypeDef" ":: Stack a (:== [a])"]
	})

bs_update_array = (["&", "{*&*[\\e]*=*}"],
	{ syntax_title         = "array update"
	, syntax_code          =
		[ "{ a & [i]=x, [j]=y, ... } // Updates a by setting index i to x, j to y, ..."
		, "# a & [i]=x, [j]=y, ...   // Same as # a = {a & [i]=x, [j]=y, ...}" // See https://clean.cs.ru.nl/Clean_2.3
		]
	, syntax_description   = "Updates an array by creating a copy and replacing one or more elements."
	, syntax_doc_locations = [CLR 6 "4.4.1" "_Toc311798032"]
	, syntax_examples      = []
	})
bs_update_record = (["&", "{*&*=*}"],
	{ syntax_title         = "record update"
	, syntax_code          =
		[ "{ r & f1=x, f2=y, ... } // Updates r by setting f1 to x, f2 to y, ..."
		, "# r & f1=x, f2=y, ...   // Same as # r = {r & f1=x, f2=y, ...}" // See https://clean.cs.ru.nl/Clean_2.3
		]
	, syntax_description   = "Updates a record by creating a copy and replacing one or more fields."
	, syntax_doc_locations = [CLR 7 "5.2.1" "_Toc311798049"]
	, syntax_examples      = []
	})

bs_where_class = (["where"],
	{ syntax_title         = "where"
	, syntax_code          = ["where"]
	, syntax_description   = "Introduces the members of a {{`class`}} definition."
	, syntax_doc_locations = [CLR 8 "6.1"   "_Toc311798056"]
	, syntax_examples      = [EX "ClassDef" "class Arith a        // Class definition\nwhere\n\t(+) infixl 6 :: a a -> a\n\t(-) infixl 6 :: a a -> a"] // TODO highlighting
	})
bs_where_instance = (["where"],
	{ syntax_title         = "where"
	, syntax_code          = ["where"]
	, syntax_description   = "Introduces the implementation of an {{`instance`}}."
	, syntax_doc_locations = [CLR 8 "6.1"   "_Toc311798056"]
	, syntax_examples      = [EX "Function" "instance Arith Int   // Instance definition\nwhere\n\t(+) x y = // ...\n\t(-) x y = // ..."]
	})
bs_where_local = (["where"],
	{ syntax_title         = "where"
	, syntax_code          = ["where"]
	, syntax_description   = "Introduces local definitions. For guard-local definitions, see {{`with`}}."
	, syntax_doc_locations = [CLR 5 "3.5.2" "_Toc311798004"]
	, syntax_examples      = [EXs "Function" "macro" "primes = sieve [2..] // Local definitions\nwhere\n\tsieve [pr:r] = [pr:sieve (filter pr r)]"]
	})

bs_with = (["with"],
	{ syntax_title         = "with"
	, syntax_code          = ["with"]
	, syntax_description   = "Introduces guard-local definitions. For function-local definitions, see {{`where`}}."
	, syntax_doc_locations = [CLR 5 "3.5.3" "_Toc311798005"]
	, syntax_examples      = [EXs "Function" "macro" "f x y\n| guard1 = alt1\n\twith local = expr1\n| guard2 = alt2\n\twith local = expr2"]
	})

bs_zf = (["ZF-expression", "ZF", "zf", "comprehension", "<-", "<|-", "<-:", "\\\\", ",", "&", "|"],
	{ syntax_title         = "list comprehension"
	, syntax_code          = ["[... \\\\ ... <- ...]"]
	, syntax_description   = "Constructs a list composed of elements drawn from other lists or arrays."
	, syntax_doc_locations = [CLR 6 "4.2.1" "_Toc311798024"]
	, syntax_examples      = map (EXs "Function" "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"
		, "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]                        // <-: for arrays"
		, "castList xs  = [|x \\\\ x <|- xs]                      // The two pipe characters make both xs and the result overloaded lists"
		]
	})


Fix #14

Fix #14

module builddb

// Project libraries
import qualified TypeDB as DB
from TypeDB import ::TypeExtras{..}

// StdEnv
import StdFile, StdList, StdMisc, StdArray, StdBool, StdString, StdTuple

// CleanPlatform
import Data.Maybe, Data.Either, Data.Error, Data.Func, Data.Tuple, Data.Functor
from Text import class Text(concat), 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
import CoclUtils

// frontend
//import Heap, compile, parse, predef
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(NoPos), ::Module{mod_ident,mod_defs}, ::ParsedDefinition(PD_TypeSpec,PD_Instance,PD_Class), ::FunSpecials, ::Priority, ::ParsedModule, ::SymbolType, ::ParsedInstanceAndMembers{..}, ::ParsedInstance{pi_ident,pi_types}, ::Type, ::ClassDef{class_ident,class_args}, ::TypeVar
from scanner import ::Priority(..), ::Assoc(..)
from parse import wantModule

:: CLI = {
	help :: Bool,
	version :: Bool,
	root :: String,
	libs :: [String]}

instance zero CLI where
	zero = { version = False
	       , help = False
	       , root = "/opt/clean/lib/"
	       , libs = [ "StdEnv"
	                , "StdLib"
	                , "ArgEnv"
	                , "Directory"
	                , "Dynamics"
	                , "Gast"
	                , "Generics"
	                , "MersenneTwister"
	                , "TCPIP"
	                , "clean-platform/OS-Independent"
	                , "clean-platform/OS-Linux"
	                , "clean-platform/OS-Linux-32"
	                , "clean-platform/OS-Linux-64"
	                , "clean-platform/OS-Mac"
	                , "clean-platform/OS-Posix"
	                , "clean-platform/OS-Windows"
	                , "clean-platform/OS-Windows-32"
	                , "clean-platform/OS-Windows-64"
	                ]
	       }

VERSION :== "Cloogle's builddb version 0.1\n"
USAGE :== concat [
	VERSION, "\n",
	"Usage: ./builddb [opts] > builddb.json\n\n",
	"\t-h, --help Show this help\n",
	"\t-r PATH    Change the library root to PATH\n",
	"\t-l PATH    Add PATH to the librarypaths relative to the root\n"]

Start w
# (args, w) = getCommandLine w
# (f, w) = stdio w
# (ok, w) = case parseCLI (tl args) of
	(Left e) = fclose (f <<< e) w
	(Right cli)
	| cli.help = fclose (f <<< USAGE) w
	| cli.version = fclose (f <<< VERSION) w
	# (mods, w) = findModules` cli.libs cli.root w
	# (st, w) = init_identifiers newHeap w
	# cache = empty_cache st
	# (db, w) = loop cli.root mods 'DB'.newDb cache w
	# f = 'DB'.saveDb db f
	= fclose f w
| not ok = abort "Couldn't close stdio"
= w
where
	loop :: String [(String,String)] 'DB'.TypeDB *DclCache *World -> *('DB'.TypeDB, *World)
	loop _ [] db _ w = (db,w)
	loop root [(lib,mod):list] db cache w
	# (db, cache, w) = getModuleTypes root mod lib cache db w
	= loop root list db cache w

	parseCLI :: [String] -> Either String CLI
	parseCLI [] = Right zero
	parseCLI [x:a] = case (x,a) of
		("--help", xs) = (\c->{c & help=True}) <$> parseCLI xs
		("--version", xs) = (\c->{c & version=True}) <$> parseCLI xs
		("-l", []) = Left "'-l' requires an argument"
		("-r", []) = Left "'-r' requires an argument"
		("-r", [x:xs]) = (\c->{c & root=x}) <$> parseCLI xs
		("-l", [x:xs]) = (\c->{c & libs=[x:c.libs]}) <$> parseCLI xs
		(x, _) = Left $ "Unknown option '" +++ x +++ "'"

//              Libraries                Library Module
findModules` :: ![String] !String !*World -> *(![(String,String)], !*World)
findModules` [] _ w = ([], w)
findModules` [lib:libs] root w
#! (mods, w) = findModules lib root w
#! (moremods, w) = findModules` libs root w
= (removeDup (mods ++ moremods), w)

findModules :: !String !String !*World -> *(![(String,String)], !*World)
findModules lib root w
#! (fps, w) = readDirectory (root +++ "/" +++ lib) w
| isError fps = ([], w)
#! fps = fromOk fps
#! mods = map (\s->(lib, s%(0,size s-5))) $ filter isDclModule fps
#! (moremods, w) = findModules` (map ((+++) (lib+++"/")) (filter isDirectory fps)) root w
= (removeDup (mods ++ moremods), w)
where
	isDclModule :: String -> Bool
	isDclModule s = s % (size s - 4, size s - 1) == ".dcl"

	isDirectory :: String -> Bool
	isDirectory s = not $ isMember '.' $ fromString s

getModuleTypes :: String String String *DclCache 'DB'.TypeDB *World -> *('DB'.TypeDB, *DclCache, *World)
getModuleTypes root mod lib cache db w
# filename = root +++ "/" +++ lib +++ "/" +++ mkdir mod +++ ".dcl"
# (ok,f,w) = fopen filename FReadText w
| not ok = abort ("Couldn't open file " +++ filename +++ ".\n")
# (mod_id, ht) = putIdentInHashTable mod (IC_Module NoQualifiedIdents) cache.hash_table
  cache = {cache & hash_table=ht}
# ((b1,b2,pm,ht,f),w) = accFiles (wantModule` f "" False mod_id.boxed_ident NoPos True cache.hash_table stderr) w
  cache = {cache & hash_table=ht}
# (ok,w) = fclose f w
| not ok = abort ("Couldn't close file " +++ filename +++ ".\n")
# mod = pm.mod_ident.id_name
# lib = cleanlib mod lib
# db = 'DB'.putTypes (pd_typespecs lib mod pm.mod_defs) db
# db = 'DB'.putInstancess (pd_instances pm.mod_defs) db
# db = 'DB'.putClasses (pd_classes lib mod pm.mod_defs) db
= (db,cache,w)
where
	mkdir :: String -> String
	mkdir s = { if (c == '.') '/' c \\ c <-: s }

	cleanlib :: !String !String -> String // Remove module dirs from lib
	cleanlib mod lib = toString $ cl` (fromString $ mkdir mod) (fromString lib)
	where
		cl` :: ![Char] ![Char] -> [Char]
		cl` mod lib
			| not (isMember '/' mod) = lib
			# mod = reverse $ tl $ dropWhile ((<>)'/') $ reverse mod
			| drop (length lib - length mod) lib == mod
				= take (length lib - length mod - 1) lib
			= lib

	pd_typespecs :: String String [ParsedDefinition] -> [('DB'.FunctionLocation, 'DB'.ExtendedType)]
	pd_typespecs lib mod pds
		= [('DB'.FL lib mod id_name, 'DB'.ET ('T'.toType t) {te_priority=toPrio p})
		   \\ PD_TypeSpec pos id=:{id_name} p (Yes t) funspecs <- pds]
	where
		toPrio :: Priority -> Maybe 'DB'.TE_Priority
		toPrio (Prio LeftAssoc i)  = Just $ 'DB'.LeftAssoc i
		toPrio (Prio RightAssoc i) = Just $ 'DB'.RightAssoc i
		toPrio (Prio NoAssoc i)    = Just $ 'DB'.NoAssoc i
		toPrio _                   = Nothing

	pd_instances :: [ParsedDefinition] -> [('DB'.Class, ['DB'.Type])]
	pd_instances pds
		= [(pi_ident.id_name, map 'T'.toType pi_types)
		   \\ PD_Instance {pim_pi={pi_ident,pi_types}} <- pds]

	pd_classes :: String String [ParsedDefinition]
		-> [('DB'.ClassLocation, ['T'.TypeVar], [('DB'.FunctionName, 'DB'.ExtendedType)])]
	pd_classes lib mod pds
	# pds = filter (\pd->case pd of (PD_Class _ _)=True; _=False) pds
	= map (\(PD_Class {class_ident={id_name},class_args} pds)
		-> let typespecs = pd_typespecs lib mod pds
		in ('DB'.CL lib mod id_name, map 'T'.toTypeVar class_args,
			[(f,et) \\ ('DB'.FL _ _ f, et) <- typespecs])) pds

unigroups :: (Type Type -> Bool) [(a,Type)] -> [([a],Type)]
unigroups f ts = unigroups` ts []
where
	unigroups` [] groups = groups
	unigroups` [(a,t):ts] [] = unigroups` ts [([a],t)]
	unigroups` [(a,t):ts] [(ns,ut):groups]
	| f t ut	= unigroups` ts [([a:ns],ut):groups]
	| otherwise = unigroups` ts [(ns,ut):unigroups` [(a,t)] groups]

(<+) infixr 5 :: a b -> [String] | print a & print b
(<+) a b = print a ++ print b

join :: a [b] -> [String] | print a & print b
join _ [] = []
join a [b:[]] = print b
join a [b:bs] = b <+ a <+ join a bs

alignl :: Int a -> [String] | print a
alignl i s
# s = print s
# len = sum (map size s)
| len >= i = s
| otherwise = s ++ [{' ' \\ i <- [0..i-len]}]

wantModule` :: !*File !{#Char} !Bool !Ident !Position !Bool !*HashTable !*File !*Files
	-> ((!Bool,!Bool,!ParsedModule, !*HashTable, !*File), !*Files)
wantModule` f s b1 i p b2 ht io fs
# (b1,b2,pm,ht,f,fs) = wantModule f s b1 i p b2 ht io fs
= ((b1,b2,pm,ht,f),fs)

module builddb

// Project libraries
import qualified TypeDB as DB
from TypeDB import ::TypeExtras{..}

// StdEnv
import StdFile, StdList, StdMisc, StdArray, StdBool, StdString, StdTuple

// CleanPlatform
import Data.Maybe, Data.Either, Data.Error, Data.Func, Data.Tuple, Data.Functor
from Text import class Text(concat), 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
import CoclUtils

// frontend
//import Heap, compile, parse, predef
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(NoPos), ::Module{mod_ident,mod_defs}, ::ParsedDefinition(PD_TypeSpec,PD_Instance,PD_Class), ::FunSpecials, ::Priority, ::ParsedModule, ::SymbolType, ::ParsedInstanceAndMembers{..}, ::ParsedInstance{pi_ident,pi_types}, ::Type, ::ClassDef{class_ident,class_args}, ::TypeVar
from scanner import ::Priority(..), ::Assoc(..)
from parse import wantModule

:: CLI = {
	help :: Bool,
	version :: Bool,
	root :: String,
	libs :: [String]}

instance zero CLI where
	zero = { version = False
	       , help = False
	       , root = "/opt/clean/lib/"
	       , libs = [ "StdEnv"
	                , "StdLib"
	                , "ArgEnv"
	                , "Directory"
	                , "Dynamics"
	                , "Gast"
	                , "Generics"
	                , "MersenneTwister"
	                , "TCPIP"
	                , "clean-platform/OS-Independent"
	                , "clean-platform/OS-Linux"
	                , "clean-platform/OS-Linux-32"
	                , "clean-platform/OS-Linux-64"
	                , "clean-platform/OS-Mac"
	                , "clean-platform/OS-Posix"
	                , "clean-platform/OS-Windows"
	                , "clean-platform/OS-Windows-32"
	                , "clean-platform/OS-Windows-64"
	                ]
	       }

VERSION :== "Cloogle's builddb version 0.1\n"
USAGE :== concat [
	VERSION, "\n",
	"Usage: ./builddb [opts] > builddb.json\n\n",
	"\t-h, --help Show this help\n",
	"\t-r PATH    Change the library root to PATH\n",
	"\t-l PATH    Add PATH to the librarypaths relative to the root\n"]

Start w
# (args, w) = getCommandLine w
# (f, w) = stdio w
# (ok, w) = case parseCLI (tl args) of
	(Left e) = fclose (f <<< e) w
	(Right cli)
	| cli.help = fclose (f <<< USAGE) w
	| cli.version = fclose (f <<< VERSION) w
	# (mods, w) = findModules` cli.libs cli.root w
	# (st, w) = init_identifiers newHeap w
	# cache = empty_cache st
	# (db, w) = loop mods 'DB'.newDb cache w
	# f = 'DB'.saveDb db f
	= fclose f w
| not ok = abort "Couldn't close stdio"
= w
where
	loop :: [(String,String)] 'DB'.TypeDB *DclCache *World -> *('DB'.TypeDB, *World)
	loop [] db _ w = (db,w)
	loop [(lib,mod):list] db cache w
	# (db, cache, w) = getModuleTypes mod lib cache db w
	= loop list db cache w

	parseCLI :: [String] -> Either String CLI
	parseCLI [] = Right zero
	parseCLI [x:a] = case (x,a) of
		("--help", xs) = (\c->{c & help=True}) <$> parseCLI xs
		("--version", xs) = (\c->{c & version=True}) <$> parseCLI xs
		("-l", []) = Left "'-l' requires an argument"
		("-r", []) = Left "'-r' requires an argument"
		("-r", [x:xs]) = (\c->{c & root=x}) <$> parseCLI xs
		("-l", [x:xs]) = (\c->{c & libs=[x:c.libs]}) <$> parseCLI xs
		(x, _) = Left $ "Unknown option '" +++ x +++ "'"

//              Libraries                Library Module
findModules` :: ![String] !String !*World -> *(![(String,String)], !*World)
findModules` [] _ w = ([], w)
findModules` [lib:libs] root w
#! (mods, w) = findModules lib root w
#! (moremods, w) = findModules` libs root w
= (removeDup (mods ++ moremods), w)

findModules :: !String !String !*World -> *(![(String,String)], !*World)
findModules lib root w
#! (fps, w) = readDirectory (root +++ "/" +++ lib) w
| isError fps = ([], w)
#! fps = fromOk fps
#! mods = map (tuple (root +++ lib)) $ map (\s->s%(0,size s-5)) $ filter isDclModule fps
#! (moremods, w) = findModules` (map ((+++) (lib+++"/")) (filter isDirectory fps)) root w
= (removeDup (mods ++ moremods), w)
where
	isDclModule :: String -> Bool
	isDclModule s = s % (size s - 4, size s - 1) == ".dcl"

	isDirectory :: String -> Bool
	isDirectory s = not $ isMember '.' $ fromString s

getModuleTypes :: String String *DclCache 'DB'.TypeDB *World -> *('DB'.TypeDB, *DclCache, *World)
getModuleTypes mod lib cache db w
# filename = lib +++ "/" +++ mkdir mod +++ ".dcl"
# (ok,f,w) = fopen filename FReadText w
| not ok = abort ("Couldn't open file " +++ filename +++ ".\n")
# (mod_id, ht) = putIdentInHashTable mod (IC_Module NoQualifiedIdents) cache.hash_table
  cache = {cache & hash_table=ht}
# ((b1,b2,pm,ht,f),w) = accFiles (wantModule` f "" False mod_id.boxed_ident NoPos True cache.hash_table stderr) w
  cache = {cache & hash_table=ht}
# (ok,w) = fclose f w
| not ok = abort ("Couldn't close file " +++ filename +++ ".\n")
# mod = pm.mod_ident.id_name
# db = 'DB'.putTypes (pd_typespecs mod pm.mod_defs) db
# db = 'DB'.putInstancess (pd_instances mod pm.mod_defs) db
# db = 'DB'.putClasses (pd_classes mod pm.mod_defs) db
= (db,cache,w)
where
	mkdir :: String -> String
	mkdir s = {if (c == '.') '/' c\\c<-:s}

	pd_typespecs :: String [ParsedDefinition] -> [('DB'.FunctionLocation, 'DB'.ExtendedType)]
	pd_typespecs mod pds
		= [('DB'.FL lib mod id_name, 'DB'.ET ('T'.toType t) {te_priority=toPrio p})
		   \\ PD_TypeSpec pos id=:{id_name} p (Yes t) funspecs <- pds]
	where
		toPrio :: Priority -> Maybe 'DB'.TE_Priority
		toPrio (Prio LeftAssoc i)  = Just $ 'DB'.LeftAssoc i
		toPrio (Prio RightAssoc i) = Just $ 'DB'.RightAssoc i
		toPrio (Prio NoAssoc i)    = Just $ 'DB'.NoAssoc i
		toPrio _                   = Nothing

	pd_instances :: String [ParsedDefinition] -> [('DB'.Class, ['DB'.Type])]
	pd_instances mod pds
		= [(pi_ident.id_name, map 'T'.toType pi_types)
		   \\ PD_Instance {pim_pi={pi_ident,pi_types}} <- pds]

	pd_classes :: String [ParsedDefinition]
		-> [('DB'.ClassLocation, ['T'.TypeVar], [('DB'.FunctionName, 'DB'.ExtendedType)])]
	pd_classes mod pds
	# pds = filter (\pd->case pd of (PD_Class _ _)=True; _=False) pds
	= map (\(PD_Class {class_ident={id_name},class_args} pds)
		-> let typespecs = pd_typespecs mod pds
		in ('DB'.CL lib mod id_name, map 'T'.toTypeVar class_args,
			[(f,et) \\ ('DB'.FL _ _ f, et) <- typespecs])) pds

unigroups :: (Type Type -> Bool) [(a,Type)] -> [([a],Type)]
unigroups f ts = unigroups` ts []
where
	unigroups` [] groups = groups
	unigroups` [(a,t):ts] [] = unigroups` ts [([a],t)]
	unigroups` [(a,t):ts] [(ns,ut):groups]
	| f t ut	= unigroups` ts [([a:ns],ut):groups]
	| otherwise = unigroups` ts [(ns,ut):unigroups` [(a,t)] groups]

(<+) infixr 5 :: a b -> [String] | print a & print b
(<+) a b = print a ++ print b

join :: a [b] -> [String] | print a & print b
join _ [] = []
join a [b:[]] = print b
join a [b:bs] = b <+ a <+ join a bs

alignl :: Int a -> [String] | print a
alignl i s
# s = print s
# len = sum (map size s)
| len >= i = s
| otherwise = s ++ [{' ' \\ i <- [0..i-len]}]

wantModule` :: !*File !{#Char} !Bool !Ident !Position !Bool !*HashTable !*File !*Files
	-> ((!Bool,!Bool,!ParsedModule, !*HashTable, !*File), !*Files)
wantModule` f s b1 i p b2 ht io fs
# (b1,b2,pm,ht,f,fs) = wantModule f s b1 i p b2 ht io fs
= ((b1,b2,pm,ht,f),fs)


Changing directory now works (Fixes #2)

Changing directory now works (Fixes #2)

implementation module Bot

import StdString
from StdMisc import abort
from StdTuple import snd

import System.Process, Data.Error, System._Posix
from Data.List import isnull

runBot :: Bot !*World -> (Maybe String, *World)
runBot bot world
# (err, world) = runProcessIO ("./" +++ bot.name) [] (Just "bots") world
| isError err = abort ("Could not start bot: " +++ bot.name +++ "\n" +++ snd (fromError err))
# (handle, io) = fromOk err
# (err, world) = writePipe (fromMaybe "" bot.input) io.stdIn world
| isError err = abort ("Could not write to stdIn of " +++ bot.name +++ "\n" +++ snd (fromError err))
# (err, world) = closePipe io.stdIn world
| isError err = abort "Could not close stdIn pipe"
# (err, world) = waitForProcess handle world
# (result, world) = readStdOut io.stdOut world
# (err, world) = closePipe io.stdOut world
| isError err = abort "Could not close stdOut pipe"
| isnull bot.children = (Nothing, world)
= (result, world)
where
	readStdOut :: ReadPipe !*World -> (Maybe String, *World)
	readStdOut pipe world
	# (err, world) = readPipeNonBlocking pipe world
	| isError err = abort "Could not read stdOut"
	# result = fromOk err
	| result == "" = (Nothing, world)
	= (Just result, world)

implementation module Bot

import StdString
from StdMisc import abort
from StdTuple import snd

import System.Process, Data.Error, System._Posix
from Data.List import isnull

runBot :: Bot !*World -> (Maybe String, *World)
runBot bot world
# (err, world) = runProcessIO ("bots/" +++ bot.name) [] (Just "bots/") world
| isError err = abort ("Could not start bot: " +++ bot.name +++ "\n" +++ snd (fromError err))
# (handle, io) = fromOk err
# (err, world) = writePipe (fromMaybe "" bot.input) io.stdIn world
| isError err = abort ("Could not write to stdIn of " +++ bot.name +++ "\n" +++ snd (fromError err))
# (err, world) = closePipe io.stdIn world
| isError err = abort "Could not close stdIn pipe"
# (err, world) = waitForProcess handle world
# (result, world) = readStdOut io.stdOut world
# (err, world) = closePipe io.stdOut world
| isError err = abort "Could not close stdOut pipe"
| isnull bot.children = (Nothing, world)
= (result, world)
where
	readStdOut :: ReadPipe !*World -> (Maybe String, *World)
	readStdOut pipe world
	# (err, world) = readPipeNonBlocking pipe world
	| isError err = abort "Could not read stdOut"
	# result = fromOk err
	| result == "" = (Nothing, world)
	= (Just result, world)


Make cache keys more general now that name search is case insensitive

module CloogleServer

import StdArray
import StdBool
import StdFile
from StdFunc import id, o
import StdList
import StdMisc
import StdOrdList
import StdOverloaded
import StdString
import StdTuple

from TCPIP import :: IPAddress, :: Port, instance toString IPAddress

import Control.Applicative
import Control.Monad
import Data.Error
import qualified Data.Foldable as Foldable
from Data.Foldable import class Foldable
from Data.Func import $, hyperstrict, instance Functor ((->) r), mapSt, seqSt
import Data.Functor
from Data.List import permutations
import Data.Maybe
import Data.Tuple
import System._Posix
import System.CommandLine
import System.Time
from Text import class Text(concat,toLowerCase), instance Text String, <+
import Text.JSON

import Cloogle
import Type
import CloogleDB
import Search

import SimpleTCPServer
import Cache
import Memory

MAX_RESULTS    :== 15
CACHE_PREFETCH :== 5

:: RequestCacheKey
	= { c_unify            :: Maybe Type
	  , c_name             :: Maybe String
	  , c_className        :: Maybe String
	  , c_typeName         :: Maybe String
	  , c_modules          :: Maybe [String]
	  , c_libraries        :: Maybe [String]
	  , c_include_builtins :: Bool
	  , c_include_core     :: Bool
	  , c_include_apps     :: Bool
	  , c_page             :: Int
	  }

derive JSONEncode Kind, Type, RequestCacheKey, TypeRestriction
derive JSONDecode Kind, Type, RequestCacheKey, TypeRestriction
instance toString RequestCacheKey
where toString rck = toString $ toJSON rck

toRequestCacheKey :: !*CloogleDB !Request -> *(!RequestCacheKey, !*CloogleDB)
toRequestCacheKey db r
# (allsyns,db) = allTypeSynonyms db
= (
	{ c_unify            = snd <$>
		prepare_unification True allsyns <$>
		(parseType o fromString =<< r.unify)
	, c_name             = toLowerCase <$> r.name
	, c_className        = toLowerCase <$> r.className
	, c_typeName         = toLowerCase <$> r.typeName
	, c_modules          = sort <$> r.modules
	, c_libraries        = sort <$> r.libraries
	, c_include_builtins = fromJust (r.include_builtins <|> Just DEFAULT_INCLUDE_BUILTINS)
	, 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
	, name             = k.c_name
	, className        = k.c_className
	, typeName         = k.c_typeName
	, 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
	}

:: Options =
	{ port         :: Int
	, help         :: Bool
	, reload_cache :: Bool
	}

instance zero Options where zero = {port=31215, help=False, reload_cache=False}

parseOptions :: Options [String] -> MaybeErrorString Options
parseOptions opt [] = Ok opt
parseOptions opt ["-p":p:rest] = case (toInt p, p) of
	(0, "0") -> Error "Cannot use port 0"
	(0, p)   -> Error $ "'" <+ p <+ "' is not an integer"
	(p, _)   -> parseOptions {Options | opt & port=p} rest
parseOptions opt ["-h":rest] = parseOptions {opt & help=True} rest
parseOptions opt ["--help":rest] = parseOptions {opt & help=True} rest
parseOptions opt ["--reload-cache":rest] = parseOptions {opt & reload_cache=True} rest
parseOptions opt [arg:_] = Error $ "Unknown option '" <+ arg <+ "'"

Start w
# (cmdline, w) = getCommandLine w
# opts = parseOptions zero (tl cmdline)
| isError opts
	# (io,w) = stdio w
	# io = io <<< fromError opts <<< "\n"
	# (_,w) = fclose io w
	= w
# opts = fromOk opts
| opts.help = help (hd cmdline) w
# w = disableSwap w
#! (_,f,w) = fopen "types.json" FReadText 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
	, logger            = Just log
	, port              = opts.Options.port
	, connect_timeout   = Just 3600000 // 1h
	, keepalive_timeout = Just 5000    // 5s
	} db w
where
	help :: String *World -> *World
	help pgm w
	# (io, w) = stdio w
	# io = io <<< "Usage: " <<< pgm <<< " [--reload-cache] [-p <port>] [-h] [--help]\n"
	= snd $ fclose io w

	disableSwap :: *World -> *World
	disableSwap w
	# (ok,w) = mlockall (MCL_CURRENT bitor MCL_FUTURE) w
	| ok = w
	# (err,w) = errno w
	# (io,w) = stdio w
	# io = io <<< "Could not lock memory (" <<< err <<< "); process may get swapped out\n"
	= snd $ fclose io 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 key {r & return = if (r.return == 0) 1 r.return} db w
		| isJust name && size (fromJust name) > 40
			= respond key (err InvalidName "Function name too long") db w
		| isJust name && any isSpace (fromString $ fromJust name)
			= respond key (err InvalidName "Name cannot contain spaces") db w
		| isJust unify && isNothing (parseType $ fromString $ fromJust unify)
			= respond key (err InvalidType "Couldn't parse type") db w
		// Results
		#! drop_n = fromJust (page <|> pure 0) * MAX_RESULTS
		#! (res,db) = search request db
		#! results = drop drop_n res
		#! more = max 0 (length results - MAX_RESULTS)
		// Suggestions
		#! (suggestions,db) = case unify >>= parseType o fromString of
			Just t -> suggs name t db
			Nothing -> (Nothing, db)
		#! (db,w) = seqSt
			(\(req,res) (db,w) -> let (k,db`) = toRequestCacheKey db req in (db`,cachePages k CACHE_PREFETCH 0 zero res w))
			(fromMaybe [] suggestions)
			(db,w)
		#! suggestions
			= sortBy (\a b -> snd a > snd b) <$>
			  filter ((<) (length results) o snd) <$>
			  map (appSnd length) <$> suggestions
		#! (results,nextpages) = splitAt MAX_RESULTS results
		// Response
		#! response = if (isEmpty results)
			(err NoResults "No results")
			{ zero
		    & data           = results
		    , more_available = Just more
		    , suggestions    = suggestions
		    }
		// Save page prefetches
		#! w = cachePages key CACHE_PREFETCH 1 response nextpages w
		// Save cache file
		= respond key response db w
	where
		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
		cachePages key 0 _  _ _  w = w
		cachePages key npages i response results w
		# w = writeCache Brief req` resp` w
		= cachePages key (npages - 1) (i + 1) response keep w
		where
			req` = { key & c_page = key.c_page + i }
			resp` =
				{ response
				& more_available = Just $ max 0 (length results - MAX_RESULTS)
				, data = give
				}
			(give,keep) = splitAt MAX_RESULTS results

	suggs :: !(Maybe String) !Type !*CloogleDB -> *(Maybe [(Request, [Result])], *CloogleDB)
	suggs n (Func is r cc) db | length is < 3
	= appFst Just $ mapSt (\r -> appFst (tuple r) o search r o resetDB) reqs db
	where
		reqs = [{zero & name=n, unify=Just $ concat $ print False $ Func is` r cc}
			\\ is` <- permutations is | is` <> is]
	suggs _ _ db = (Nothing, db)

	reloadCache :: !CloogleDB -> *World -> *World
	reloadCache db = uncurry (flip (foldl (flip search))) o allCacheKeys LongTerm
	where
		search :: !RequestCacheKey -> *World -> *World
		search r = thd3 o handle db (Just $ fromRequestCacheKey r) o removeFromCache LongTerm r

	doInBackground :: (*World -> *World) *World -> *World
	doInBackground f w
	#! (pid,w) = fork w
	| pid  < 0 = abort "fork failed\n"
	| pid  > 0 = w // Parent: return directly
	| pid == 0 = snd $ exit 0 $ f w // Child: do function

:: LogMemory =
	{ mem_ip         :: IPAddress
	, mem_time_start :: Tm
	, mem_time_end   :: Tm
	, mem_request    :: Maybe Request
	}

instance zero LogMemory
where
	zero =
		{ mem_ip         = undef
		, mem_time_start = undef
		, mem_time_end   = undef
		, mem_request    = undef
		}

:: LogMessage` :== LogMessage (Maybe Request) Response CacheKey

:: LogEntry =
	{ ip            :: String
	, time_start    :: (String, Int)
	, time_end      :: (String, Int)
	, request       :: Maybe Request
	, cachekey      :: String
	, response_code :: Int
	, results       :: Int
	}

derive JSONEncode LogEntry

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)
# (io,w)  = stdio w
# io      = io <<< toString (toJSON $ makeLogEntry msg mem) <<< "\n"
= (Just mem, snd (fclose io w))
where
	needslog = case msg of (Sent _ _) = True; _ = False

	updateMemory :: LogMessage` LogMemory *World -> *(LogMemory, *World)
	updateMemory (Connected ip) s w = ({s & mem_ip=ip}, w)
	updateMemory (Received r)   s w
	# (t,w) = localTime w
	= ({s & mem_time_start=t, mem_request=r}, w)
	updateMemory (Sent _ _)     s w
	# (t,w) = localTime w
	= ({s & mem_time_end=t}, w)
	updateMemory _                   s w = (s,w)

	makeLogEntry :: LogMessage` LogMemory -> LogEntry
	makeLogEntry (Sent response ck) mem =
		{ ip            = toString mem.mem_ip
		, time_start    = (toString mem.mem_time_start, toInt $ timeGm mem.mem_time_start)
		, time_end      = (toString mem.mem_time_end, toInt $ timeGm mem.mem_time_end)
		, request       = mem.mem_request
		, cachekey      = ck
		, response_code = response.return
		, results       = length response.data
		}

err :: CloogleError String -> Response
err c m = { return         = toInt c
          , data           = []
          , msg            = m
          , more_available = Nothing
          , suggestions    = Nothing
          }

module CloogleServer

import StdArray
import StdBool
import StdFile
from StdFunc import id, o
import StdList
import StdMisc
import StdOrdList
import StdOverloaded
import StdString
import StdTuple

from TCPIP import :: IPAddress, :: Port, instance toString IPAddress

import Control.Applicative
import Control.Monad
import Data.Error
import qualified Data.Foldable as Foldable
from Data.Foldable import class Foldable
from Data.Func import $, hyperstrict, instance Functor ((->) r), mapSt, seqSt
import Data.Functor
from Data.List import permutations
import Data.Maybe
import Data.Tuple
import System._Posix
import System.CommandLine
import System.Time
from Text import class Text(concat), instance Text String, <+
import Text.JSON

import Cloogle
import Type
import CloogleDB
import Search

import SimpleTCPServer
import Cache
import Memory

MAX_RESULTS    :== 15
CACHE_PREFETCH :== 5

:: RequestCacheKey
	= { c_unify            :: Maybe Type
	  , c_name             :: Maybe String
	  , c_className        :: Maybe String
	  , c_typeName         :: Maybe String
	  , c_modules          :: Maybe [String]
	  , c_libraries        :: Maybe [String]
	  , c_include_builtins :: Bool
	  , c_include_core     :: Bool
	  , c_include_apps     :: Bool
	  , c_page             :: Int
	  }

derive JSONEncode Kind, Type, RequestCacheKey, TypeRestriction
derive JSONDecode Kind, Type, RequestCacheKey, TypeRestriction
instance toString RequestCacheKey
where toString rck = toString $ toJSON rck

toRequestCacheKey :: !*CloogleDB !Request -> *(!RequestCacheKey, !*CloogleDB)
toRequestCacheKey db r
# (allsyns,db) = allTypeSynonyms db
= (
	{ c_unify            = snd <$>
		prepare_unification True allsyns <$>
		(parseType o fromString =<< r.unify)
	, c_name             = r.name
	, c_className        = r.className
	, c_typeName         = r.typeName
	, c_modules          = sort <$> r.modules
	, c_libraries        = sort <$> r.libraries
	, c_include_builtins = fromJust (r.include_builtins <|> Just DEFAULT_INCLUDE_BUILTINS)
	, 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
	, name             = k.c_name
	, className        = k.c_className
	, typeName         = k.c_typeName
	, 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
	}

:: Options =
	{ port         :: Int
	, help         :: Bool
	, reload_cache :: Bool
	}

instance zero Options where zero = {port=31215, help=False, reload_cache=False}

parseOptions :: Options [String] -> MaybeErrorString Options
parseOptions opt [] = Ok opt
parseOptions opt ["-p":p:rest] = case (toInt p, p) of
	(0, "0") -> Error "Cannot use port 0"
	(0, p)   -> Error $ "'" <+ p <+ "' is not an integer"
	(p, _)   -> parseOptions {Options | opt & port=p} rest
parseOptions opt ["-h":rest] = parseOptions {opt & help=True} rest
parseOptions opt ["--help":rest] = parseOptions {opt & help=True} rest
parseOptions opt ["--reload-cache":rest] = parseOptions {opt & reload_cache=True} rest
parseOptions opt [arg:_] = Error $ "Unknown option '" <+ arg <+ "'"

Start w
# (cmdline, w) = getCommandLine w
# opts = parseOptions zero (tl cmdline)
| isError opts
	# (io,w) = stdio w
	# io = io <<< fromError opts <<< "\n"
	# (_,w) = fclose io w
	= w
# opts = fromOk opts
| opts.help = help (hd cmdline) w
# w = disableSwap w
#! (_,f,w) = fopen "types.json" FReadText 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
	, logger            = Just log
	, port              = opts.Options.port
	, connect_timeout   = Just 3600000 // 1h
	, keepalive_timeout = Just 5000    // 5s
	} db w
where
	help :: String *World -> *World
	help pgm w
	# (io, w) = stdio w
	# io = io <<< "Usage: " <<< pgm <<< " [--reload-cache] [-p <port>] [-h] [--help]\n"
	= snd $ fclose io w

	disableSwap :: *World -> *World
	disableSwap w
	# (ok,w) = mlockall (MCL_CURRENT bitor MCL_FUTURE) w
	| ok = w
	# (err,w) = errno w
	# (io,w) = stdio w
	# io = io <<< "Could not lock memory (" <<< err <<< "); process may get swapped out\n"
	= snd $ fclose io 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 key {r & return = if (r.return == 0) 1 r.return} db w
		| isJust name && size (fromJust name) > 40
			= respond key (err InvalidName "Function name too long") db w
		| isJust name && any isSpace (fromString $ fromJust name)
			= respond key (err InvalidName "Name cannot contain spaces") db w
		| isJust unify && isNothing (parseType $ fromString $ fromJust unify)
			= respond key (err InvalidType "Couldn't parse type") db w
		// Results
		#! drop_n = fromJust (page <|> pure 0) * MAX_RESULTS
		#! (res,db) = search request db
		#! results = drop drop_n res
		#! more = max 0 (length results - MAX_RESULTS)
		// Suggestions
		#! (suggestions,db) = case unify >>= parseType o fromString of
			Just t -> suggs name t db
			Nothing -> (Nothing, db)
		#! (db,w) = seqSt
			(\(req,res) (db,w) -> let (k,db`) = toRequestCacheKey db req in (db`,cachePages k CACHE_PREFETCH 0 zero res w))
			(fromMaybe [] suggestions)
			(db,w)
		#! suggestions
			= sortBy (\a b -> snd a > snd b) <$>
			  filter ((<) (length results) o snd) <$>
			  map (appSnd length) <$> suggestions
		#! (results,nextpages) = splitAt MAX_RESULTS results
		// Response
		#! response = if (isEmpty results)
			(err NoResults "No results")
			{ zero
		    & data           = results
		    , more_available = Just more
		    , suggestions    = suggestions
		    }
		// Save page prefetches
		#! w = cachePages key CACHE_PREFETCH 1 response nextpages w
		// Save cache file
		= respond key response db w
	where
		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
		cachePages key 0 _  _ _  w = w
		cachePages key npages i response results w
		# w = writeCache Brief req` resp` w
		= cachePages key (npages - 1) (i + 1) response keep w
		where
			req` = { key & c_page = key.c_page + i }
			resp` =
				{ response
				& more_available = Just $ max 0 (length results - MAX_RESULTS)
				, data = give
				}
			(give,keep) = splitAt MAX_RESULTS results

	suggs :: !(Maybe String) !Type !*CloogleDB -> *(Maybe [(Request, [Result])], *CloogleDB)
	suggs n (Func is r cc) db | length is < 3
	= appFst Just $ mapSt (\r -> appFst (tuple r) o search r o resetDB) reqs db
	where
		reqs = [{zero & name=n, unify=Just $ concat $ print False $ Func is` r cc}
			\\ is` <- permutations is | is` <> is]
	suggs _ _ db = (Nothing, db)

	reloadCache :: !CloogleDB -> *World -> *World
	reloadCache db = uncurry (flip (foldl (flip search))) o allCacheKeys LongTerm
	where
		search :: !RequestCacheKey -> *World -> *World
		search r = thd3 o handle db (Just $ fromRequestCacheKey r) o removeFromCache LongTerm r

	doInBackground :: (*World -> *World) *World -> *World
	doInBackground f w
	#! (pid,w) = fork w
	| pid  < 0 = abort "fork failed\n"
	| pid  > 0 = w // Parent: return directly
	| pid == 0 = snd $ exit 0 $ f w // Child: do function

:: LogMemory =
	{ mem_ip         :: IPAddress
	, mem_time_start :: Tm
	, mem_time_end   :: Tm
	, mem_request    :: Maybe Request
	}

instance zero LogMemory
where
	zero =
		{ mem_ip         = undef
		, mem_time_start = undef
		, mem_time_end   = undef
		, mem_request    = undef
		}

:: LogMessage` :== LogMessage (Maybe Request) Response CacheKey

:: LogEntry =
	{ ip            :: String
	, time_start    :: (String, Int)
	, time_end      :: (String, Int)
	, request       :: Maybe Request
	, cachekey      :: String
	, response_code :: Int
	, results       :: Int
	}

derive JSONEncode LogEntry

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)
# (io,w)  = stdio w
# io      = io <<< toString (toJSON $ makeLogEntry msg mem) <<< "\n"
= (Just mem, snd (fclose io w))
where
	needslog = case msg of (Sent _ _) = True; _ = False

	updateMemory :: LogMessage` LogMemory *World -> *(LogMemory, *World)
	updateMemory (Connected ip) s w = ({s & mem_ip=ip}, w)
	updateMemory (Received r)   s w
	# (t,w) = localTime w
	= ({s & mem_time_start=t, mem_request=r}, w)
	updateMemory (Sent _ _)     s w
	# (t,w) = localTime w
	= ({s & mem_time_end=t}, w)
	updateMemory _                   s w = (s,w)

	makeLogEntry :: LogMessage` LogMemory -> LogEntry
	makeLogEntry (Sent response ck) mem =
		{ ip            = toString mem.mem_ip
		, time_start    = (toString mem.mem_time_start, toInt $ timeGm mem.mem_time_start)
		, time_end      = (toString mem.mem_time_end, toInt $ timeGm mem.mem_time_end)
		, request       = mem.mem_request
		, cachekey      = ck
		, response_code = response.return
		, results       = length response.data
		}

err :: CloogleError String -> Response
err c m = { return         = toInt c
          , data           = []
          , msg            = m
          , more_available = Nothing
          , suggestions    = Nothing
          }