Fix cache

Fix cache

module CloogleServer

import StdArray
import StdBool
import StdFile
import StdList
import StdOrdList
import StdOverloaded
import StdString
import StdTuple
from StdFunc import o, flip, const
from StdMisc import abort

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

from Data.Func import $
import Data.List
import Data.Tuple
import Data.Maybe
import System.CommandLine
import Data.Functor
import Control.Applicative
import Control.Monad
from Text import class Text(concat,trim,indexOf,toLowerCase),
	instance Text String, instance + String
import Text.JSON

import System.Time

from SimpleTCPServer import :: LogMessage{..}, serve, :: Logger
import qualified SimpleTCPServer
import TypeDB
import Type
import Cache
import Cloogle

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], Bool)
	  , c_page      :: Maybe Int
	  }

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

toRequestCacheKey :: Request -> RequestCacheKey
toRequestCacheKey r =
	{ c_unify     = r.unify >>= parseType o fromString
	, c_name      = r.name
	, c_className = r.className
	, c_typeName  = r.typeName
	, c_modules   = sort <$> r.modules
	, c_libraries = appFst sort <$> r.libraries
	, c_page      = r.page
	}

Start w
# (io, w) = stdio w
# (cmdline, w) = getCommandLine w
| length cmdline <> 2 = help io w
# [_,port:_] = cmdline
# port = toInt port
# (db, io) = openDb io
# (_, w) = fclose io w
| isNothing db = abort "stdin does not have a TypeDB\n"
#! db = fromJust db
= serve (handle db) (Just log) port w
where
	help :: *File *World -> *World
	help io w
	# io = io <<< "Usage: ./CloogleServer <port>\n"
	= snd $ fclose io w

	handle :: !TypeDB !(Maybe Request) !*World -> *(!Response, CacheKey, !*World)
	handle _ Nothing w = (err CLOOGLE_E_INVALIDINPUT "Couldn't parse input", "", w)
	handle db (Just request=:{unify,name,page}) w
		//Check cache
		# (mbResponse, w) = readCache key w
		| isJust mbResponse
			# r = fromJust mbResponse
			= ({r & return = if (r.return == 0) 1 r.return}, cacheKey request, w)
		| isJust name && size (fromJust name) > 40
			= respond (err CLOOGLE_E_INVALIDNAME "Function name too long") w
		| isJust name && any isSpace (fromString $ fromJust name)
			= respond (err CLOOGLE_E_INVALIDNAME "Name cannot contain spaces") w
		| isJust unify && isNothing (parseType $ fromString $ fromJust unify)
			= respond (err CLOOGLE_E_INVALIDTYPE "Couldn't parse type") w
		// Results
		# drop_n = fromJust (page <|> pure 0) * MAX_RESULTS
		# results = drop drop_n $ sort $ search request db
		# more = max 0 (length results - MAX_RESULTS)
		// Suggestions
		# mbType = unify >>= parseType o fromString
		# suggestions
			= sortBy (\a b -> snd a > snd b) <$>
			  filter ((<)(length results) o snd) <$>
			  (mbType >>= \t -> suggs name t db)
		# (results,nextpages) = splitAt MAX_RESULTS results
		// Response
		# response = if (isEmpty results)
			(err CLOOGLE_E_NORESULTS "No results")
			{ return = 0
		    , msg = "Success"
		    , data           = results
		    , more_available = Just more
		    , suggestions    = suggestions
		    }
		// Save page prefetches
		# w = cachePages CACHE_PREFETCH 1 response nextpages w
		// Save cache file
		= respond response w
	where
		key = toRequestCacheKey request

		respond :: Response *World -> *(Response, CacheKey, *World)
		respond r w = (r, cacheKey key, writeCache LongTerm key r w)

		cachePages :: Int Int Response [Result] *World -> *World
		cachePages _ _  _ [] w = w
		cachePages 0 _  _ _  w = w
		cachePages npages i response results w
		# w = writeCache Brief req` resp` w
		= cachePages (npages - 1) (i + 1) response keep w
		where
			req` = { key & c_page = ((+) i) <$> (key.c_page <|> pure 0) }
			resp` =
				{ response
				& more_available = Just $ max 0 (length results - MAX_RESULTS)
				, data = give
				}
			(give,keep) = splitAt MAX_RESULTS results

	suggs :: !(Maybe String) !Type !TypeDB -> Maybe [(Request, Int)]
	suggs n (Func is r cc) db
		| length is < 3
			= Just [let t` = concat $ print False $ Func is` r cc in
			        let request = {zero & name=n, unify=Just t`} in
			        (request, length $ search request db)
			        \\ is` <- permutations is | is` <> is]
	suggs _ _ _ = Nothing

	search :: !Request !TypeDB -> [Result]
	search {unify,name,className,typeName,modules,libraries,page} db
		# db = case libraries of
			(Just ls) = filterLocations (isLibMatch ls) db
			Nothing   = db
		# db = case modules of
			(Just ms) = filterLocations (isModMatch ms) db
			Nothing   = db
		| isJust className
			# className = fromJust className
			# classes = findClass className db
			= map (flip makeClassResult db) classes
		| isJust typeName
			# typeName = fromJust typeName
			# types = findType typeName db
			= [makeTypeResult (Just typeName) l td db \\ (l,td) <- types]
		# mbType = prepare_unification True <$> (unify >>= parseType o fromString)
		// Search normal functions
		# filts = catMaybes [ (\t _ -> isUnifiable t) <$> mbType
		                    , (\n loc _ -> isNameMatch (size n*2/3) n loc) <$> name
		                    ]
		# funs = map (\f -> makeFunctionResult name mbType Nothing f db) $ findFunction`` filts db
		// Search macros
		# macros = case (isNothing mbType,name) of
			(True,Just n) = findMacro` (\loc _ -> isNameMatch (size n*2/3) n loc) db
			_             = []
		# macros = map (\(lhs,rhs) -> makeMacroResult name lhs rhs) macros
		// Search class members
		# filts = catMaybes [ (\t _ _ _ _->isUnifiable t) <$> mbType
		                    , (\n (Location lib mod _ _ _) _ _ f _ -> isNameMatch
		                      (size n*2/3) n (Location lib mod Nothing Nothing f)) <$> name
		                    ]
		# members = findClassMembers`` filts db
		# members = map (\(Location lib mod line iclline cls,vs,_,f,et) -> makeFunctionResult name mbType
			(Just {cls_name=cls,cls_vars=vs}) (Location lib mod line iclline f,et) db) members
		// Search types
		# lcName = if (isJust mbType && isType (fromJust mbType))
			(let (Type name _) = fromJust mbType in Just $ toLowerCase name)
			(toLowerCase <$> name)
		# types = case (isNothing mbType,lcName) of
			(True,Just n) = findType` (\loc _ -> toLowerCase (getName loc) == n) db
			_             = []
		# types = map (\(tl,td) -> makeTypeResult name tl td db) types
		// Search classes
		# classes = case (isNothing mbType, toLowerCase <$> name) of
			(True, Just c) = findClass` (\loc _ _ _ -> toLowerCase (getName loc) == c) db
			_              = []
		# classes = map (flip makeClassResult db) classes
		// Merge results
		= sort $ funs ++ members ++ types ++ classes ++ macros

	makeClassResult :: (Location, [TypeVar], ClassContext, [(Name,ExtendedType)])
		TypeDB -> Result
	makeClassResult rec=:(Builtin _, _, _, _) db
		= ClassResult
		  ( { library  = ""
		    , filename = ""
		    , dcl_line = Nothing
		    , icl_line = Nothing
		    , modul    = ""
		    , distance = -100
		    , builtin  = Just True
		    }
		  , makeClassResultExtras rec db
		  )
	makeClassResult rec=:(Location lib mod line iclline cls, vars, cc, funs) db
		= ClassResult
		  ( { library  = lib
		    , filename = modToFilename mod
		    , dcl_line = line
		    , icl_line = iclline
		    , modul    = mod
		    , distance = -100
		    , builtin  = Nothing
		    }
		  , makeClassResultExtras rec db
		  )
	makeClassResultExtras :: (Location, [TypeVar], ClassContext, [(Name,ExtendedType)])
		TypeDB -> ClassResultExtras
	makeClassResultExtras (l, vars, cc, funs) db
		= { class_name = cls
		  , class_heading = foldl ((+) o (flip (+) " ")) cls vars +
		      if (isEmpty cc) "" " | " + concat (print False cc)
		  , class_funs = [print_fun fun \\ fun <- funs]
		  , class_instances
		      = sortBy (\(a,_) (b,_) -> a < b)
		          [([concat (print False t) \\ t <- ts], map loc ls)
		          \\ (ts,ls) <- getInstances cls db]
		  }
	where
		cls = case l of
			Builtin c = c
			Location _ _ _ _ c = c

		print_fun :: (Name,ExtendedType) -> String
		print_fun f=:(_,ET _ et) = fromJust $
			et.te_representation <|> (pure $ concat $ print False f)

	makeTypeResult :: (Maybe String) Location TypeDef TypeDB -> Result
	makeTypeResult mbName (Location lib mod line iclline t) td db
		= TypeResult
		  ( { library  = lib
		    , filename = modToFilename mod
		    , dcl_line = line
		    , icl_line = iclline
		    , modul    = mod
		    , distance
		        = if (isNothing mbName) -100 (levenshtein` t (fromJust mbName))
		    , builtin  = Nothing
		    }
		  , { type             = concat $ print False td
		    , type_instances   = map (appSnd3 (map (concat o (print False)))) $
		        map (appThd3 (map loc)) $ getTypeInstances t db
		    , type_derivations = map (appSnd (map loc)) $ getTypeDerivations t db
		    }
		  )
	makeTypeResult mbName (Builtin t) td db
		= TypeResult
		  ( { library  = ""
		    , filename = ""
		    , dcl_line = Nothing
		    , icl_line = Nothing
		    , modul    = ""
		    , distance
		        = if (isNothing mbName) -100 (levenshtein` t (fromJust mbName))
		    , builtin  = Just True
		    }
		  , { type             = concat $ print False td
		    , type_instances   = map (appSnd3 (map (concat o (print False)))) $
		        map (appThd3 (map loc)) $ getTypeInstances t db
		    , type_derivations = map (appSnd (map loc)) $ getTypeDerivations t db
		    }
		  )

	makeMacroResult :: (Maybe String) Location Macro -> Result
	makeMacroResult mbName (Location lib mod line iclline m) mac
		= MacroResult
		  ( { library  = lib
		    , filename = modToFilename mod
		    , dcl_line = line
		    , icl_line = iclline
		    , modul    = mod
		    , distance
		        = if (isNothing mbName) -100 (levenshtein` (fromJust mbName) m)
		    , builtin  = Nothing
		    }
		  , { macro_name = m
		    , macro_representation = mac.macro_as_string
		    }
		  )

	makeFunctionResult :: (Maybe String) (Maybe Type) (Maybe ShortClassResult)
		(Location, ExtendedType) TypeDB -> Result
	makeFunctionResult
		orgsearch orgsearchtype mbCls (fl, et=:(ET type tes)) db
		= FunctionResult
		  ( { library  = lib
		    , filename = modToFilename mod
		    , dcl_line = line
		    , icl_line = iclline
		    , modul    = mod
		    , distance = distance
		    , builtin  = builtin
		    }
		  , { func     = fromJust (tes.te_representation <|>
		                           (pure $ concat $ print False (fname,et)))
		    , unifier  = toStrUnifier <$> finish_unification <$>
		        (orgsearchtype >>= unify [] (prepare_unification False type))
		    , cls      = mbCls
		    , constructor_of = if tes.te_isconstructor
		        (let (Func _ r _) = type in Just $ concat $ print False r)
		        Nothing
		    , recordfield_of = if tes.te_isrecordfield
		        (let (Func [t:_] _ _) = type in Just $ concat $ print False t)
		        Nothing
		    , generic_derivations
		        = let derivs = getDerivations fname db in
		          const (sortBy (\(a,_) (b,_) -> a < b)
				    [(concat $ print False d, map loc ls) \\ (d,ls) <- derivs]) <$>
		          tes.te_generic_vars
		    }
		  )
	where
		(lib,mod,fname,line,iclline,builtin) = case fl of
			(Location l m ln iln f) = (l,  m,  f, ln,      iln,     Nothing)
			(Builtin f)             = ("", "", f, Nothing, Nothing, Just True)

		toStrUnifier :: Unifier -> StrUnifier
		toStrUnifier (tvas1, tvas2) = (map toStr tvas1, map toStr tvas2)
		where toStr (var, type) = (var, concat $ print False type)

		toStrPriority :: (Maybe Priority) -> String
		toStrPriority p = case print False p of [] = ""; ss = concat [" ":ss]

		distance
			| isNothing orgsearch || fromJust orgsearch == ""
				| isNothing orgsearchtype = 0
				# orgsearchtype = fromJust orgsearchtype
				# (Just (ass1, ass2)) = finish_unification <$>
					unify [] orgsearchtype (prepare_unification False type)
				= penalty + toInt (sum [typeComplexity t \\ (_,t)<-ass1 ++ ass2 | not (isVar t)])
			# orgsearch = fromJust orgsearch
			= penalty + levenshtein` orgsearch fname
		where
			penalty
			| tes.te_isrecordfield = 2
			| tes.te_isconstructor = 1
			| otherwise            = 0

			typeComplexity :: Type -> Real
			typeComplexity (Type _ ts) = 1.2 * foldr ((+) o typeComplexity) 1.0 ts
			typeComplexity (Func is r _) = 2.0 * foldr ((+) o typeComplexity) 1.0 [r:is]
			typeComplexity (Var _) = 1.0
			typeComplexity (Cons _ ts) = 1.2 * foldr ((+) o typeComplexity) 1.0 ts
			typeComplexity (Uniq t) = 3.0 + typeComplexity t

	levenshtein` :: String String -> Int
	levenshtein` a b = if (indexOf a b == -1) 0 -100 + levenshtein [c \\ c <-: a] [c \\ c <-: b]

	modToFilename :: String -> String
	modToFilename mod = (toString $ reverse $ takeWhile ((<>)'.')
	                              $ reverse $ fromString mod) + ".dcl"

	isUnifiable :: Type ExtendedType -> Bool
	isUnifiable t1 (ET t2 _) = isJust (unify [] t1 (prepare_unification False t2))

	isNameMatch :: !Int !String Location -> Bool
	isNameMatch maxdist n1 loc
		# (n1, n2) = ({toLower c \\ c <-: n1}, {toLower c \\ c <-: getName loc})
		= n1 == "" || indexOf n1 n2 <> -1 || levenshtein [c \\ c <-: n1] [c \\ c <-: n2] <= maxdist

	isModMatch :: ![String] Location -> Bool
	isModMatch mods (Location _ mod _ _ _) = isMember mod mods
	isModMatch _    (Builtin _)            = False

	isLibMatch :: (![String], !Bool) Location -> Bool
	isLibMatch (libs,_) (Location lib _ _ _ _) = any (\l -> indexOf l lib == 0) libs
	isLibMatch (_,blti) (Builtin _)            = blti

	loc :: Location -> LocationResult
	loc (Location lib mod ln iln _) = (lib, mod, ln, iln)

	log :: (LogMessage (Maybe Request) Response CacheKey) IPAddress *World
		-> *(IPAddress, *World)
	log msg s w
	| not needslog = (newS msg s, w)
	# (tm,w) = localTime w
	# (io,w) = stdio w
	# io = io <<< trim (toString tm) <<< " " <<< msgToString msg s
	= (newS msg s, snd (fclose io w))
	where
		needslog = case msg of (Received _) = True; (Sent _ _) = True; _ = False

	newS :: (LogMessage (Maybe Request) Response CacheKey) IPAddress -> IPAddress
	newS m s = case m of (Connected ip) = ip; _ = s

	msgToString :: (LogMessage (Maybe Request) Response CacheKey) IPAddress -> String
	msgToString (Received Nothing) ip
		= toString ip + " <-- Nothing\n"
	msgToString (Received (Just a)) ip
		= toString ip + " <-- " + toString a + "\n"
	msgToString (Sent {return,data,msg,more_available} ck) ip
		= toString ip + " --> " + toString (length data)
			+ " results (" + toString return + "; " + msg
			+ if (isJust more_available) ("; " + toString (fromJust more_available) + " more") ""
			+ "; cache: " + ck + ")\n"
	msgToString _ _ = ""

module CloogleServer

import StdArray
import StdBool
import StdFile
import StdList
import StdOrdList
import StdOverloaded
import StdString
import StdTuple
from StdFunc import o, flip, const
from StdMisc import abort

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

from Data.Func import $
import Data.List
import Data.Tuple
import Data.Maybe
import System.CommandLine
import Data.Functor
import Control.Applicative
import Control.Monad
from Text import class Text(concat,trim,indexOf,toLowerCase),
	instance Text String, instance + String
import Text.JSON

import System.Time

from SimpleTCPServer import :: LogMessage{..}, serve, :: Logger
import qualified SimpleTCPServer
import TypeDB
import Type
import Cache
import Cloogle

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], Bool)
	  , c_page      :: Maybe Int
	  }

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

toRequestCacheKey :: Request -> RequestCacheKey
toRequestCacheKey r =
	{ c_unify     = r.unify >>= parseType o fromString
	, c_name      = r.name
	, c_className = r.className
	, c_typeName  = r.typeName
	, c_modules   = sort <$> r.modules
	, c_libraries = appFst sort <$> r.libraries
	, c_page      = r.page
	}

Start w
# (io, w) = stdio w
# (cmdline, w) = getCommandLine w
| length cmdline <> 2 = help io w
# [_,port:_] = cmdline
# port = toInt port
# (db, io) = openDb io
# (_, w) = fclose io w
| isNothing db = abort "stdin does not have a TypeDB\n"
#! db = fromJust db
= serve (handle db) (Just log) port w
where
	help :: *File *World -> *World
	help io w
	# io = io <<< "Usage: ./CloogleServer <port>\n"
	= snd $ fclose io w

	handle :: !TypeDB !(Maybe Request) !*World -> *(!Response, CacheKey, !*World)
	handle _ Nothing w = (err CLOOGLE_E_INVALIDINPUT "Couldn't parse input", "", w)
	handle db (Just request=:{unify,name,page}) w
		//Check cache
		# (mbResponse, w) = readCache request w
		| isJust mbResponse
			# r = fromJust mbResponse
			= ({r & return = if (r.return == 0) 1 r.return}, cacheKey request, w)
		| isJust name && size (fromJust name) > 40
			= respond (err CLOOGLE_E_INVALIDNAME "Function name too long") w
		| isJust name && any isSpace (fromString $ fromJust name)
			= respond (err CLOOGLE_E_INVALIDNAME "Name cannot contain spaces") w
		| isJust unify && isNothing (parseType $ fromString $ fromJust unify)
			= respond (err CLOOGLE_E_INVALIDTYPE "Couldn't parse type") w
		// Results
		# drop_n = fromJust (page <|> pure 0) * MAX_RESULTS
		# results = drop drop_n $ sort $ search request db
		# more = max 0 (length results - MAX_RESULTS)
		// Suggestions
		# mbType = unify >>= parseType o fromString
		# suggestions
			= sortBy (\a b -> snd a > snd b) <$>
			  filter ((<)(length results) o snd) <$>
			  (mbType >>= \t -> suggs name t db)
		# (results,nextpages) = splitAt MAX_RESULTS results
		// Response
		# response = if (isEmpty results)
			(err CLOOGLE_E_NORESULTS "No results")
			{ return = 0
		    , msg = "Success"
		    , data           = results
		    , more_available = Just more
		    , suggestions    = suggestions
		    }
		// Save page prefetches
		# w = cachePages CACHE_PREFETCH 1 response nextpages w
		// Save cache file
		= respond response w
	where
		key = toRequestCacheKey request

		respond :: Response *World -> *(Response, CacheKey, *World)
		respond r w = (r, cacheKey key, writeCache LongTerm key r w)

		cachePages :: Int Int Response [Result] *World -> *World
		cachePages _ _  _ [] w = w
		cachePages 0 _  _ _  w = w
		cachePages npages i response results w
		# w = writeCache Brief req` resp` w
		= cachePages (npages - 1) (i + 1) response keep w
		where
			req` = { key & c_page = ((+) i) <$> (key.c_page <|> pure 0) }
			resp` =
				{ response
				& more_available = Just $ max 0 (length results - MAX_RESULTS)
				, data = give
				}
			(give,keep) = splitAt MAX_RESULTS results

	suggs :: !(Maybe String) !Type !TypeDB -> Maybe [(Request, Int)]
	suggs n (Func is r cc) db
		| length is < 3
			= Just [let t` = concat $ print False $ Func is` r cc in
			        let request = {zero & name=n, unify=Just t`} in
			        (request, length $ search request db)
			        \\ is` <- permutations is | is` <> is]
	suggs _ _ _ = Nothing

	search :: !Request !TypeDB -> [Result]
	search {unify,name,className,typeName,modules,libraries,page} db
		# db = case libraries of
			(Just ls) = filterLocations (isLibMatch ls) db
			Nothing   = db
		# db = case modules of
			(Just ms) = filterLocations (isModMatch ms) db
			Nothing   = db
		| isJust className
			# className = fromJust className
			# classes = findClass className db
			= map (flip makeClassResult db) classes
		| isJust typeName
			# typeName = fromJust typeName
			# types = findType typeName db
			= [makeTypeResult (Just typeName) l td db \\ (l,td) <- types]
		# mbType = prepare_unification True <$> (unify >>= parseType o fromString)
		// Search normal functions
		# filts = catMaybes [ (\t _ -> isUnifiable t) <$> mbType
		                    , (\n loc _ -> isNameMatch (size n*2/3) n loc) <$> name
		                    ]
		# funs = map (\f -> makeFunctionResult name mbType Nothing f db) $ findFunction`` filts db
		// Search macros
		# macros = case (isNothing mbType,name) of
			(True,Just n) = findMacro` (\loc _ -> isNameMatch (size n*2/3) n loc) db
			_             = []
		# macros = map (\(lhs,rhs) -> makeMacroResult name lhs rhs) macros
		// Search class members
		# filts = catMaybes [ (\t _ _ _ _->isUnifiable t) <$> mbType
		                    , (\n (Location lib mod _ _ _) _ _ f _ -> isNameMatch
		                      (size n*2/3) n (Location lib mod Nothing Nothing f)) <$> name
		                    ]
		# members = findClassMembers`` filts db
		# members = map (\(Location lib mod line iclline cls,vs,_,f,et) -> makeFunctionResult name mbType
			(Just {cls_name=cls,cls_vars=vs}) (Location lib mod line iclline f,et) db) members
		// Search types
		# lcName = if (isJust mbType && isType (fromJust mbType))
			(let (Type name _) = fromJust mbType in Just $ toLowerCase name)
			(toLowerCase <$> name)
		# types = case (isNothing mbType,lcName) of
			(True,Just n) = findType` (\loc _ -> toLowerCase (getName loc) == n) db
			_             = []
		# types = map (\(tl,td) -> makeTypeResult name tl td db) types
		// Search classes
		# classes = case (isNothing mbType, toLowerCase <$> name) of
			(True, Just c) = findClass` (\loc _ _ _ -> toLowerCase (getName loc) == c) db
			_              = []
		# classes = map (flip makeClassResult db) classes
		// Merge results
		= sort $ funs ++ members ++ types ++ classes ++ macros

	makeClassResult :: (Location, [TypeVar], ClassContext, [(Name,ExtendedType)])
		TypeDB -> Result
	makeClassResult rec=:(Builtin _, _, _, _) db
		= ClassResult
		  ( { library  = ""
		    , filename = ""
		    , dcl_line = Nothing
		    , icl_line = Nothing
		    , modul    = ""
		    , distance = -100
		    , builtin  = Just True
		    }
		  , makeClassResultExtras rec db
		  )
	makeClassResult rec=:(Location lib mod line iclline cls, vars, cc, funs) db
		= ClassResult
		  ( { library  = lib
		    , filename = modToFilename mod
		    , dcl_line = line
		    , icl_line = iclline
		    , modul    = mod
		    , distance = -100
		    , builtin  = Nothing
		    }
		  , makeClassResultExtras rec db
		  )
	makeClassResultExtras :: (Location, [TypeVar], ClassContext, [(Name,ExtendedType)])
		TypeDB -> ClassResultExtras
	makeClassResultExtras (l, vars, cc, funs) db
		= { class_name = cls
		  , class_heading = foldl ((+) o (flip (+) " ")) cls vars +
		      if (isEmpty cc) "" " | " + concat (print False cc)
		  , class_funs = [print_fun fun \\ fun <- funs]
		  , class_instances
		      = sortBy (\(a,_) (b,_) -> a < b)
		          [([concat (print False t) \\ t <- ts], map loc ls)
		          \\ (ts,ls) <- getInstances cls db]
		  }
	where
		cls = case l of
			Builtin c = c
			Location _ _ _ _ c = c

		print_fun :: (Name,ExtendedType) -> String
		print_fun f=:(_,ET _ et) = fromJust $
			et.te_representation <|> (pure $ concat $ print False f)

	makeTypeResult :: (Maybe String) Location TypeDef TypeDB -> Result
	makeTypeResult mbName (Location lib mod line iclline t) td db
		= TypeResult
		  ( { library  = lib
		    , filename = modToFilename mod
		    , dcl_line = line
		    , icl_line = iclline
		    , modul    = mod
		    , distance
		        = if (isNothing mbName) -100 (levenshtein` t (fromJust mbName))
		    , builtin  = Nothing
		    }
		  , { type             = concat $ print False td
		    , type_instances   = map (appSnd3 (map (concat o (print False)))) $
		        map (appThd3 (map loc)) $ getTypeInstances t db
		    , type_derivations = map (appSnd (map loc)) $ getTypeDerivations t db
		    }
		  )
	makeTypeResult mbName (Builtin t) td db
		= TypeResult
		  ( { library  = ""
		    , filename = ""
		    , dcl_line = Nothing
		    , icl_line = Nothing
		    , modul    = ""
		    , distance
		        = if (isNothing mbName) -100 (levenshtein` t (fromJust mbName))
		    , builtin  = Just True
		    }
		  , { type             = concat $ print False td
		    , type_instances   = map (appSnd3 (map (concat o (print False)))) $
		        map (appThd3 (map loc)) $ getTypeInstances t db
		    , type_derivations = map (appSnd (map loc)) $ getTypeDerivations t db
		    }
		  )

	makeMacroResult :: (Maybe String) Location Macro -> Result
	makeMacroResult mbName (Location lib mod line iclline m) mac
		= MacroResult
		  ( { library  = lib
		    , filename = modToFilename mod
		    , dcl_line = line
		    , icl_line = iclline
		    , modul    = mod
		    , distance
		        = if (isNothing mbName) -100 (levenshtein` (fromJust mbName) m)
		    , builtin  = Nothing
		    }
		  , { macro_name = m
		    , macro_representation = mac.macro_as_string
		    }
		  )

	makeFunctionResult :: (Maybe String) (Maybe Type) (Maybe ShortClassResult)
		(Location, ExtendedType) TypeDB -> Result
	makeFunctionResult
		orgsearch orgsearchtype mbCls (fl, et=:(ET type tes)) db
		= FunctionResult
		  ( { library  = lib
		    , filename = modToFilename mod
		    , dcl_line = line
		    , icl_line = iclline
		    , modul    = mod
		    , distance = distance
		    , builtin  = builtin
		    }
		  , { func     = fromJust (tes.te_representation <|>
		                           (pure $ concat $ print False (fname,et)))
		    , unifier  = toStrUnifier <$> finish_unification <$>
		        (orgsearchtype >>= unify [] (prepare_unification False type))
		    , cls      = mbCls
		    , constructor_of = if tes.te_isconstructor
		        (let (Func _ r _) = type in Just $ concat $ print False r)
		        Nothing
		    , recordfield_of = if tes.te_isrecordfield
		        (let (Func [t:_] _ _) = type in Just $ concat $ print False t)
		        Nothing
		    , generic_derivations
		        = let derivs = getDerivations fname db in
		          const (sortBy (\(a,_) (b,_) -> a < b)
				    [(concat $ print False d, map loc ls) \\ (d,ls) <- derivs]) <$>
		          tes.te_generic_vars
		    }
		  )
	where
		(lib,mod,fname,line,iclline,builtin) = case fl of
			(Location l m ln iln f) = (l,  m,  f, ln,      iln,     Nothing)
			(Builtin f)             = ("", "", f, Nothing, Nothing, Just True)

		toStrUnifier :: Unifier -> StrUnifier
		toStrUnifier (tvas1, tvas2) = (map toStr tvas1, map toStr tvas2)
		where toStr (var, type) = (var, concat $ print False type)

		toStrPriority :: (Maybe Priority) -> String
		toStrPriority p = case print False p of [] = ""; ss = concat [" ":ss]

		distance
			| isNothing orgsearch || fromJust orgsearch == ""
				| isNothing orgsearchtype = 0
				# orgsearchtype = fromJust orgsearchtype
				# (Just (ass1, ass2)) = finish_unification <$>
					unify [] orgsearchtype (prepare_unification False type)
				= penalty + toInt (sum [typeComplexity t \\ (_,t)<-ass1 ++ ass2 | not (isVar t)])
			# orgsearch = fromJust orgsearch
			= penalty + levenshtein` orgsearch fname
		where
			penalty
			| tes.te_isrecordfield = 2
			| tes.te_isconstructor = 1
			| otherwise            = 0

			typeComplexity :: Type -> Real
			typeComplexity (Type _ ts) = 1.2 * foldr ((+) o typeComplexity) 1.0 ts
			typeComplexity (Func is r _) = 2.0 * foldr ((+) o typeComplexity) 1.0 [r:is]
			typeComplexity (Var _) = 1.0
			typeComplexity (Cons _ ts) = 1.2 * foldr ((+) o typeComplexity) 1.0 ts
			typeComplexity (Uniq t) = 3.0 + typeComplexity t

	levenshtein` :: String String -> Int
	levenshtein` a b = if (indexOf a b == -1) 0 -100 + levenshtein [c \\ c <-: a] [c \\ c <-: b]

	modToFilename :: String -> String
	modToFilename mod = (toString $ reverse $ takeWhile ((<>)'.')
	                              $ reverse $ fromString mod) + ".dcl"

	isUnifiable :: Type ExtendedType -> Bool
	isUnifiable t1 (ET t2 _) = isJust (unify [] t1 (prepare_unification False t2))

	isNameMatch :: !Int !String Location -> Bool
	isNameMatch maxdist n1 loc
		# (n1, n2) = ({toLower c \\ c <-: n1}, {toLower c \\ c <-: getName loc})
		= n1 == "" || indexOf n1 n2 <> -1 || levenshtein [c \\ c <-: n1] [c \\ c <-: n2] <= maxdist

	isModMatch :: ![String] Location -> Bool
	isModMatch mods (Location _ mod _ _ _) = isMember mod mods
	isModMatch _    (Builtin _)            = False

	isLibMatch :: (![String], !Bool) Location -> Bool
	isLibMatch (libs,_) (Location lib _ _ _ _) = any (\l -> indexOf l lib == 0) libs
	isLibMatch (_,blti) (Builtin _)            = blti

	loc :: Location -> LocationResult
	loc (Location lib mod ln iln _) = (lib, mod, ln, iln)

	log :: (LogMessage (Maybe Request) Response CacheKey) IPAddress *World
		-> *(IPAddress, *World)
	log msg s w
	| not needslog = (newS msg s, w)
	# (tm,w) = localTime w
	# (io,w) = stdio w
	# io = io <<< trim (toString tm) <<< " " <<< msgToString msg s
	= (newS msg s, snd (fclose io w))
	where
		needslog = case msg of (Received _) = True; (Sent _ _) = True; _ = False

	newS :: (LogMessage (Maybe Request) Response CacheKey) IPAddress -> IPAddress
	newS m s = case m of (Connected ip) = ip; _ = s

	msgToString :: (LogMessage (Maybe Request) Response CacheKey) IPAddress -> String
	msgToString (Received Nothing) ip
		= toString ip + " <-- Nothing\n"
	msgToString (Received (Just a)) ip
		= toString ip + " <-- " + toString a + "\n"
	msgToString (Sent {return,data,msg,more_available} ck) ip
		= toString ip + " --> " + toString (length data)
			+ " results (" + toString return + "; " + msg
			+ if (isJust more_available) ("; " + toString (fromJust more_available) + " more") ""
			+ "; cache: " + ck + ")\n"
	msgToString _ _ = ""


Document push_a_b ABC instruction

Document push_a_b ABC instruction

implementation module Builtin.ABC

import _SystemArray
import StdList
import StdMisc

import Text

import Cloogle.API
import Cloogle.DB

builtin_abc_instructions :: [ABCInstructionEntry]
builtin_abc_instructions =
	[ i_create
	: arith_instructions ++
	  stack_operations ++
	  branches ++
	  miscellaneous ++
	  directives ++
	  [{zero & aie_instruction=i} \\ i <- other_instructions]
	]

instance zero ABCInstructionEntry
where
	zero =
		{ aie_instruction = undef
		, aie_arguments   = []
		, aie_description = "There is no documentation for this ABC instruction yet."
		}

LABEL    :== ABCArgument ABCTypeLabel        False
LABEL_   :== ABCArgument ABCTypeLabel        True
A_OFFSET :== ABCArgument ABCTypeAStackOffset False
B_OFFSET :== ABCArgument ABCTypeBStackOffset False
STRING   :== ABCArgument ABCTypeString       False
STRING_  :== ABCArgument ABCTypeString       True
BOOL     :== ABCArgument ABCTypeBool         False
BOOL_    :== ABCArgument ABCTypeBool         True
CHAR     :== ABCArgument ABCTypeChar         False
CHAR_    :== ABCArgument ABCTypeChar         True
INT      :== ABCArgument ABCTypeInt          False
INT_     :== ABCArgument ABCTypeInt          True
REAL     :== ABCArgument ABCTypeReal         False
REAL_    :== ABCArgument ABCTypeReal         True

i_create :: ABCInstructionEntry
i_create =
	{ zero
	& aie_instruction = "create"
	, aie_description = "Creates a new empty node and pushes its address to the A-stack."
	}

arith_instructions :: [ABCInstructionEntry]
arith_instructions =
	[ arith1 "absR"    "Real" "absolute value"
	, arith1 "acosR"   "Real" "arccosine"
	, arith1 "asinR"   "Real" "arcsine"
	, arith1 "atanR"   "Real" "arctangent"
	, arith1 "cosR"    "Real" "cosine"
	, arith1 "entierR" "Real" "(Int) entier (floor)"
	, arith1 "expR"    "Real" "exponential function (e^r)"
	, arith1 "lnR"     "Real" "natural logarithm"
	, arith1 "log10R"  "Real" "base-10 logarithm"
	, arith1 "notB"    "Bool" "logical negation"
	, arith1 "sinR"    "Real" "sine"
	, arith1 "sqrtR"   "Real" "square root"
	, arith1 "tanR"    "Real" "tangent"

	, op1 "decI" "Int"  "Decrements"
	, op1 "incI" "Int"  "Increments"
	, op1 "negI" "Int"  "Negates"
	, op1 "negR" "Real" "Negates"
	, op1 "not%" "Int"  "Bitwise negates"

	, op2 "addI"    "Int"  "Sums"
	, op2 "addR"    "Real" "Sums"
	, op2 "andB"    "Bool" "Logically conjuncts"
	, op2 "and%"    "Int"  "Bitwise conjuncts"
	, op2 "divI"    "Int"  "Divides"
	, op2 "divR"    "Real" "Divides"
	, op2 "eqB"     "Bool" "Checks equality on"
	, op2 "eqC"     "Char" "Checks equality on"
	, op2 "eqI"     "Int"  "Checks equality on"
	, op2 "eqR"     "Real" "Checks equality on"
	, i_eqAC_a
	, op2 "gtC"     "Char" "Checks greater-than on"
	, op2 "gtI"     "Int"  "Checks greater-than on"
	, op2 "gtR"     "Real" "Checks greater-than on"
	, op2 "ltC"     "Char" "Checks less-than on"
	, op2 "ltI"     "Int"  "Checks less-than on"
	, op2 "ltR"     "Real" "Checks less-than on"
	, op2 "mulI"    "Int"  "Multiplies"
	, op2 "mulR"    "Real" "Multiplies"
	, op2 "orB"     "Bool" "Logically disjuncts"
	, op2 "or%"     "Int"  "Bitwise disjuncts"
	, op2 "powR"    "Real" "Raises to the power on"
	, op2 "remI"    "Int"  "Computes the remainder after division of"
	, op2 "rotl%"   "Int"  "Bitwise left-rotate on"
	, op2 "rotr%"   "Int"  "Bitwise right-rotate on"
	, op2 "shiftl%" "Int"  "Bitwise left-shift on"
	, op2 "shiftr%" "Int"  "Bitwise right-shift on"
	, op2 "subI"    "Int"  "Subtracts"
	, op2 "subR"    "Real" "Subtracts"
	, op2 "xor%"    "Int"  "Bitwise XOR on"

	, eq_arg "Bool" BOOL 'A'
	, eq_arg "Bool" BOOL 'B'
	, eq_arg "Char" CHAR 'A'
	, eq_arg "Char" CHAR 'B'
	, eq_arg "Int"  INT  'A'
	, eq_arg "Int"  INT  'B'
	, eq_arg "Real" REAL 'A'
	, eq_arg "Real" REAL 'B'

	, convert "CtoI"  "Char" "Int"
	, convert "CtoAC" "Char" "String"
	, convert "ItoC"  "Int"  "Char"
	, convert "ItoR"  "Int"  "Real"
	, convert "RtoI"  "Real" "Int"
	]
where
	arith1 :: !String !String !String -> ABCInstructionEntry
	arith1 instr type description =
		{ zero
		& aie_instruction = instr
		, aie_description = "Computes the " + description + " of the " + type + " on top of the B-stack."
		}

	op1 :: !String !String !String -> ABCInstructionEntry
	op1 instr type description =
		{ zero
		& aie_instruction = instr
		, aie_description = description + " the " + type + " on top of the B-stack."
		}

	op2 :: !String !String !String -> ABCInstructionEntry
	op2 instr type description =
		{ zero
		& aie_instruction = instr
		, aie_description = description + " the two " + type + "s on top of the B-stack."
		}

	eq_arg :: !String !ABCArgument !Char -> ABCInstructionEntry
	eq_arg type arg stack =
		{ zero
		& aie_instruction = {'e','q',type.[0],'_',toLower stack}
		, aie_arguments   = [if (stack == 'A') A_OFFSET B_OFFSET, arg]
		, aie_description = "Checks equality between the " + {stack} + "-stack element and the second argument."
		}

	convert :: !String !String !String -> ABCInstructionEntry
	convert instr fr to =
		{ zero
		& aie_instruction = instr
		, aie_description = "Converts the " + fr + " on top of the B-stack to " + to + "."
		}

	i_eqAC_a =
		{ zero
		& aie_instruction = "eqAC_a"
		, aie_arguments   = [STRING]
		, aie_description = "Checks that the string on top of the A-stack equals the argument string."
		}

stack_operations :: [ABCInstructionEntry]
stack_operations =
	[ push    "Bool" BOOL
	, push    "Char" CHAR
	, push    "Int"  INT
	, push    "Real" REAL
	, push_a  "Bool"
	, push_a  "Char"
	, push_a  "Int"
	, push_a  "Real"
	, build   "Bool" BOOL
	, build   "Char" CHAR
	, build   "Int"  INT
	, build   "Real" REAL
	, i_buildAC
	, build_b "Bool"
	, build_b "Char"
	, build_b "Int"
	, build_b "Real"
	, i_create_array
	, i_create_array_
	, i_eq_desc
	, i_eq_desc_b
	, i_eq_nulldesc
	, i_pop_a
	, i_pop_b
	, i_push_a
	, i_push_b
	, i_push_a_b
	]
where
	push :: !String !ABCArgument -> ABCInstructionEntry
	push type arg =
		{ zero
		& aie_instruction = "push" + {type.[0]}
		, aie_arguments   = [arg]
		, aie_description = "Pushes the " + type + " argument to the B-stack."
		}

	push_a :: !String -> ABCInstructionEntry
	push_a type =
		{ zero
		& aie_instruction = "push" + {type.[0]} + "_a"
		, aie_arguments   = [INT]
		, aie_description = "Pushes the " + type + " from the nth position on the A-stack to the B-stack."
		}

	build :: !String !ABCArgument -> ABCInstructionEntry
	build type arg =
		{ zero
		& aie_instruction = "build" + {type.[0]}
		, aie_arguments   = [arg]
		, aie_description = "Builds a " + type + "-node with the argument as value on the A-stack."
		}

	build_b :: !String -> ABCInstructionEntry
	build_b type =
		{ zero
		& aie_instruction = "build" + {type.[0]} + "_b"
		, aie_arguments   = [INT]
		, aie_description = "Builds a " + type + "-node with the value on the nth position of the B-stack on the A-stack."
		}

	i_buildAC =
		{ zero
		& aie_instruction = "buildAC"
		, aie_arguments   = [STRING]
		, aie_description = "Pushes the argument string to the A-stack."
		}

	i_create_array =
		{ zero
		& aie_instruction = "create_array"
		, aie_arguments   = [LABEL, A_OFFSET, B_OFFSET]
		, aie_description = join " "
			[ "Creates an array on the A-stack."
			, "The elements have type `label` (which can be `_` for any A-stack type)."
			, "The last two arguments indicate the stack sizes of the elements."
			, "The size and initial value are popped from the B and A stacks."
			]
		}
	i_create_array_ =
		{ zero
		& aie_instruction = "create_array_"
		, aie_arguments   = [LABEL, A_OFFSET, B_OFFSET]
		, aie_description = join " "
			[ "Creates an array on the A-stack."
			, "The elements have type `label` (which can be `_` for any A-stack type)."
			, "The last two arguments indicate the stack sizes of the elements."
			, "The size is popped from the B-stack; the elements are initialised as `_Nil` regardless of the type."
			]
		}

	i_eq_desc =
		{ zero
		& aie_instruction = "eq_desc"
		, aie_arguments   = [LABEL, INT, A_OFFSET]
		, aie_description = join " "
			[ "Checks that the indicated node on the A-stack matches the descriptor given by the label."
			, "The `int` argument is the arity of the descriptor."
			]
		}
	i_eq_desc_b =
		{ zero
		& aie_instruction = "eq_desc_b"
		, aie_arguments   = [LABEL, A_OFFSET]
		, aie_description = join " "
			[ "The indicated node on the A-stack is assumed to be an array."
			, "The instruction checks that the array is of the type indicated by `label`."
			]
		}
	i_eq_nulldesc =
		{ zero
		& aie_instruction = "eq_nulldesc"
		, aie_arguments   = [LABEL, A_OFFSET]
		, aie_description = "Checks that the indicated node on the A-stack matches the descriptor given by the label, ignoring arity."
		}

	i_pop_a =
		{ zero
		& aie_instruction = "pop_a"
		, aie_arguments   = [A_OFFSET]
		, aie_description = "Pops elements off the A-stack until the referenced element."
		}
	i_pop_b =
		{ zero
		& aie_instruction = "pop_b"
		, aie_arguments   = [B_OFFSET]
		, aie_description = "Pops elements off the B-stack until the referenced element."
		}
	i_push_a =
		{ zero
		& aie_instruction = "push_a"
		, aie_arguments   = [A_OFFSET]
		, aie_description = "Pushes the referenced A-stack element on the A-stack."
		}
	i_push_b =
		{ zero
		& aie_instruction = "push_b"
		, aie_arguments   = [B_OFFSET]
		, aie_description = "Pushes the referenced B-stack element on the B-stack."
		}
	i_push_a_b =
		{ zero
		& aie_instruction = "push_a_b"
		, aie_arguments   = [A_OFFSET, B_OFFSET]
		, aie_description = "Pushes the A-stack element as an integer (i.e., a pointer to the heap) on the B-stack."
		}

branches :: [ABCInstructionEntry]
branches =
	[ i_jmp
	, i_jmp_false
	, i_jmp_true
	, i_jsr
	, i_jsr_eval
	, i_rtn
	]
where
	i_jmp =
		{ zero
		& aie_instruction = "jmp"
		, aie_arguments   = [LABEL]
		, aie_description = "Unconditional jump to a label."
		}
	i_jmp_false =
		{ zero
		& aie_instruction = "jmp_false"
		, aie_arguments   = [LABEL]
		, aie_description = "Jump to a label if the Bool on top of the B-stack is false."
		}
	i_jmp_true =
		{ zero
		& aie_instruction = "jmp_true"
		, aie_arguments   = [LABEL]
		, aie_description = "Jump to a label if the Bool on top of the B-stack is true."
		}
	i_jsr =
		{ zero
		& aie_instruction = "jsr"
		, aie_arguments   = [LABEL]
		, aie_description = "Subroutine jump to a label. {{`rtn`}} returns to the instruction after this `jsr`."
		}
	i_jsr_eval =
		{ zero
		& aie_instruction = "jsr_eval"
		, aie_arguments   = [A_OFFSET, LABEL]
		, aie_description = "Subroutine jump to evaluate the indicated A-stack element. {{`rtn`}} returns to the instruction after this `jsr_eval`."
		}
	i_rtn =
		{ zero
		& aie_instruction = "rtn"
		, aie_description = "Returns from a subroutine call (e.g. {{`jsr`}})."
		}

miscellaneous :: [ABCInstructionEntry]
miscellaneous =
	[ i_ccall
	, i_centry
	, i_get_node_arity
	, i_halt
	, i_instruction
	, i_load_i
	, i_load_si16
	, i_load_si32
	, i_load_ui8
	, i_no_op
	, i_push_r_arg_t
	, i_push_t_r_a
	, i_push_t_r_args
	]
where
	i_ccall =
		{ zero
		& aie_instruction = "ccall"
		, aie_arguments   = [LABEL, STRING]
		, aie_description = join "\n"
			[ "Calls a C function."
			, "Some of this is documented in https://svn.cs.ru.nl/repos/clean-tools/trunk/htoclean/CallingCFromClean.html"
			, "The first argument is the name of the function, the second is the signature."
			, "\n"
			, "The signature has to be of the form `flags?input?sep output(sep state)?`, where"
			, "  - sep    can be either `-` or `:`."
			, "  - flags  can be `G` and/or `P`. `G` saves the state in global variables and is needed when the called C function will call Clean functions. `P` lets the callee pop arguments (necessary on 32-bit Windows)."
			, "  - input  is a number of input argument types (allowed: `IpRrSsAOF`)."
			, "  - output is a number of output argument types (allowed: `VIpRrSsAOF`)."
			, "  - state  is a carried state that is not passed to the C function, for example used to thread {{`World`}} in ccalls (allowed: `IpRSA`)."
			, "\n"
			, "Input, output and state argument types can be:"
			, "  - `I`    for integers"
			, "  - `p`    for pointers (e.g. from {{`System.Pointer`}}; on most systems this is identical to `I`)"
			, "  - [`Rr`] for reals"
			, "  - `S`    for Clean Strings (`{#Char}`). If used as input type this passes a pointer to the string's length (number of characters). The actual array is at offset 4/8 (32/64 bit). If this is used as output type, the C function has to return a pointer to the string's length, followed by the actual string. A copy of the string will be created in the Clean heap, and this copy will be used by Clean. If the string was allocated in C, for example using malloc, it should be deallocated in C when it no longer used, it is not automatically deallocated by Clean."
			, "  - `s`    for the characters of a Clean String (handy to use in conjuction with {{`packString`}}, as the string is not null-terminated). The length (number of characters) is at offset -4/-8. (32/64 bit)."
			, "  - `A`    for A-stack elements. A pointer to the third block of the node is passed. For arrays, this is a pointer to the elements. The size of the array is one word higher in the block."
			, "  - [`OF`] for function pointers"
			, "  - `V`    for `void`, packs the following argument types in a tuple (e.g. `VIR` means `(Int, Real)`)"
			]
		}
	i_centry =
		{ zero
		& aie_instruction = "centry"
		, aie_arguments   = [LABEL, LABEL, STRING]
		, aie_description = join "\n"
			[ "Adds code to call a Clean function from C."
			, "Usually it is not needed to write this instruction yourself."
			, "It is generated with the `foreign export` construct.\n"
			, "The first label is the name of the C function to generate."
			, "The second label is the Clean function to link it to.\n"
			, "The string argument indicates the type."
			, "For more information, see {{`ccall`}}."
			]
		}

	i_get_node_arity =
		{ zero
		& aie_instruction = "get_node_arity"
		, aie_arguments   = [A_OFFSET]
		, aie_description = "Pushes the arity of the descriptor of the referenced A-stack element to the B-stack."
		}

	i_halt =
		{ zero
		& aie_instruction = "halt"
		, aie_description = "Terminates the program immediately."
		}

	i_instruction =
		{ zero
		& aie_instruction = "instruction"
		, aie_arguments   = [INT]
		, aie_description = "Adds the raw argument as a word in the generated object file."
		}

	i_load_i =
		{ zero
		& aie_instruction = "load_i"
		, aie_arguments   = [INT]
		, aie_description = join "\n\n"
			[ "Take the top of the B-stack as a pointer and read an integer from that pointer with the argument as offset."
			, "See also {{`load_si16`}}, {{`load_si32`}}, {{`load_ui8`}}."
			]
		}
	i_load_si16 =
		{ zero
		& aie_instruction = "load_si16"
		, aie_arguments   = [INT]
		, aie_description = join "\n\n"
			[ "Take the top of the B-stack as a pointer and read a 16-bit signed integer from that pointer with the argument as offset."
			, "See also {{`load_i}}, {{`load_si32`}}, {{`load_ui8`}}."
			]
		}
	i_load_si32 =
		{ zero
		& aie_instruction = "load_si32"
		, aie_arguments   = [INT]
		, aie_description = join "\n\n"
			[ "Take the top of the B-stack as a pointer and read a 32-bit signed integer from that pointer with the argument as offset."
			, "This instruction is only available on 64-bit systems. On 32-bit systems, {{`load_i`}} has the same effect."
			, "See also {{`load_i`}}, {{`load_si16`}}, {{`load_ui8`}}."
			]
		}
	i_load_ui8 =
		{ zero
		& aie_instruction = "load_ui8"
		, aie_arguments   = [INT]
		, aie_description = join "\n\n"
			[ "Take the top of the B-stack as a pointer and read a 8-bit unsigned integer from that pointer with the argument as offset."
			, "See also {{`load_i`}}, {{`load_si16`}}, {{`load_si32`}}."
			]
		}

	i_no_op =
		{ zero
		& aie_instruction = "no_op"
		, aie_description = join "\n"
			[ "Do nothing. This is for example useful in the `cast` function:\n"
			, "```clean"
			, "cast :: .a -> .b"
			, "cast _ = code {"
			, "\tno_op"
			, "}"
			, "```"
			]
		}

	i_push_r_arg_t =
		{ zero
		& aie_instruction = "push_r_arg_t"
		, aie_description = join " "
			[ "Gets the *n*th element from the type string of a record."
			, "The type string is on top of the B-stack; *n* below that."
			]
		}
	i_push_t_r_a =
		{ zero
		& aie_instruction = "push_t_r_a"
		, aie_arguments   = [A_OFFSET]
		, aie_description = "Push the address of the type string of the referenced record to the B-stack."
		}
	i_push_t_r_args =
		{ zero
		& aie_instruction = "push_t_r_args"
		, aie_description = "Pops a record from the A-stack, pushes its members in reversed order to both of the stacks, then pushes the address of the type string to the B-stack."
		}

directives :: [ABCInstructionEntry]
directives =
	[ d_d
	, d_n
	, d_nu
	, d_o
	, d_export
	, d_inline
	, d_module
	, d_depend
	, d_end
	, d_endinfo
	, d_start
	]
where
	d_d =
		{ zero
		& aie_instruction = ".d"
		, aie_arguments   = [A_OFFSET, B_OFFSET, STRING_]
		, aie_description = concat
			[ "Indicates how many stack elements are on the stack when a jump follows."
			, "The first integer is the number of elements on the A-stack; the second that of B-stack elements."
			, "The optional third argument indicates the type of the B-stack elements, e.g. `bbi` for two booleans and an integer."
			]
		}
	d_n =
		{ zero
		& aie_instruction = ".n"
		, aie_arguments   = [A_OFFSET, LABEL]
		, aie_description = concat
			[ "Indicates the arity of node entry labels."
			, "The label is the label of the corresponding descriptor, or `_` if it does not exist."
			, "\n\nThere are some special cases:\n\n"
			, "- An arity of `-1` is for tuple selectors;\n"
			, "- An arity of `-2` is for indirection nodes;\n"
			, "- An arity of `-3` is for record selectors of basic types;\n"
			, "- An arity of `-4` is for record selectors of non-basic types.\n\n"
			, "See also {{`.nu`}}."
			]
		}
	d_nu =
		{ zero
		& aie_instruction = ".nu"
		, aie_arguments   = [A_OFFSET, B_OFFSET, LABEL]
		, aie_description = concat
			[ "Indicates the arity of node entry labels with arguments on the B-stack (otherwise, {{`.n`}} is used)."
			, "The first integer is the number of A-stack arguments; the second the number of B-stack arguments."
			, "The label is the label of the corresponding descriptor, or `_` if it does not exist."
			]
		}
	d_o =
		{ zero
		& aie_instruction = ".o"
		, aie_arguments   = [A_OFFSET, B_OFFSET, STRING_]
		, aie_description = concat
			[ "Indicates how many stack elements are 'given back' to a calling function when a {{`rtn`}} follows."
			, "The first integer is the number of elements on the A-stack; the second that of B-stack elements."
			, "The optional third argument indicates the type of the B-stack elements, e.g. `bbi` for two booleans and an integer."
			]
		}

	d_export =
		{ zero
		& aie_instruction = ".export"
		, aie_arguments   = [LABEL]
		, aie_description = "Exports a label (allows linking)."
		}
	d_inline =
		{ zero
		& aie_instruction = ".inline"
		, aie_arguments   = [LABEL]
		, aie_description = "Indicates that a label can (should) be inlined (usually for performance reasons)."
		}

	d_module =
		{ zero
		& aie_instruction = ".module"
		, aie_arguments   = [LABEL, STRING]
		, aie_description = "Indicates the name of the module, and its label in the data segment."
		}
	d_depend =
		{ zero
		& aie_instruction = ".depend"
		, aie_arguments   = [STRING]
		, aie_description = "Indicates a module that this module depends on."
		}
	d_end =
		{ zero
		& aie_instruction = ".end"
		, aie_description = "Indicates the end of the ABC file."
		}
	d_endinfo =
		{ zero
		& aie_instruction = ".endinfo"
		, aie_description = "Indicates the end of the metadata in the ABC file."
		}
	d_start =
		{ zero
		& aie_instruction = ".start"
		, aie_arguments   = [LABEL]
		, aie_description = "Indicates the label to start execution at."
		}

/**
 * Instructions without documentation yet
 */
other_instructions :: [String]
other_instructions =
	[ "add_args"
	, "addLU"
	, "build"
	, "buildF_b"
	, "buildh"
	, "build_r"
	, "build_u"
	, "catS"
	, "call"
	, "cmpS"
	, "ceilingR"
	, "copy_graph"
	, "code_channelP"
	, "create_channel"
	, "currentP"
	, "del_args"
	, "divLU"
	, "divU"
	, "eqD_b"
	, "eq_symbol"
	, "exit_false"
	, "fill"
	, "fill1"
	, "fill2"
	, "fill3"
	, "fill1_r"
	, "fill2_r"
	, "fill3_r"
	, "fillcaf"
	, "fillcp"
	, "fillcp_u"
	, "fill_u"
	, "fillh"
	, "fillB"
	, "fillB_b"
	, "fillC"
	, "fillC_b"
	, "fillF_b"
	, "fillI"
	, "fillI_b"
	, "fillR"
	, "fillR_b"
	, "fill_a"
	, "fill_r"
	, "floordivI"
	, "getWL"
	, "get_desc_arity"
	, "get_desc_flags_b"
	, "get_desc0_number"
	, "gtU"
	, "in"
	, "is_record"
	, "ItoP"
	, "jmp_ap"
	, "jmp_ap_upd"
	, "jmp_upd"
	, "jmp_eval"
	, "jmp_eval_upd"
	, "jmp_not_eqZ"
	, "jrsr"
	, "jsr_ap"
	, "ltU"
	, "modI"
	, "mulUUL"
	, "new_ext_reducer"
	, "new_int_reducer"
	, "newP"
	, "out"
	, "print"
	, "printD"
	, "print_char"
	, "print_int"
	, "print_real"
	, "print_r_arg"
	, "print_sc"
	, "print_symbol"
	, "print_symbol_sc"
	, "pushcaf"
	, "push_finalizers"
	, "pushA_a"
	, "pushD"
	, "pushD_a"
	, "pushF_a"
	, "pushL"
	, "pushLc"
	, "pushzs"
	, "push_arg"
	, "push_arg_b"
	, "push_args"
	, "push_args_u"
	, "push_array"
	, "push_arraysize"
	, "push_b_a"
	, "push_node"
	, "push_node_u"
	, "push_a_r_args"
	, "push_r_args"
	, "push_r_args_a"
	, "push_r_args_b"
	, "push_r_args_u"
	, "push_r_arg_D"
	, "push_r_arg_u"
	, "push_wl_args"
	, "pushZ"
	, "pushZR"
	, "putWL"
	, "randomP"
	, "release"
	, "remU"
	, "replace"
	, "repl_arg"
	, "repl_args"
	, "repl_args_b"
	, "repl_r_args"
	, "repl_r_args_a"
	, "select"
	, "send_graph"
	, "send_request"
	, "set_continue"
	, "set_defer"
	, "set_entry"
	, "set_finalizers"
	, "setwait"
	, "shiftrU"
	, "sincosR"
	, "sliceS"
	, "stop_reducer"
	, "subLU"
	, "addIo"
	, "mulIo"
	, "subIo"
	, "suspend"
	, "testcaf"
	, "truncateR"
	, "update_a"
	, "updatepop_a"
	, "update_b"
	, "updatepop_b"
	, "updateS"
	, "update"
	, ".algtype"
	, ".caf"
	, ".code"
	, ".comp"
	, ".a"
	, ".desc"
	, ".desc0"
	, ".descn"
	, ".descexp"
	, ".descs"
	, ".keep"
	, ".impdesc"
	, ".implab"
	, ".implib"
	, ".impmod"
	, ".impobj"
	, ".newlocallabel"
	, ".n_string"
	, ".pb"
	, ".pd"
	, ".pe"
	, ".pl"
	, ".pld"
	, ".pn"
	, ".pt"
	, ".record"
	, ".string"
	]

implementation module Builtin.ABC

import _SystemArray
import StdList
import StdMisc

import Text

import Cloogle.API
import Cloogle.DB

builtin_abc_instructions :: [ABCInstructionEntry]
builtin_abc_instructions =
	[ i_create
	: arith_instructions ++
	  stack_operations ++
	  branches ++
	  miscellaneous ++
	  directives ++
	  [{zero & aie_instruction=i} \\ i <- other_instructions]
	]

instance zero ABCInstructionEntry
where
	zero =
		{ aie_instruction = undef
		, aie_arguments   = []
		, aie_description = "There is no documentation for this ABC instruction yet."
		}

LABEL    :== ABCArgument ABCTypeLabel        False
LABEL_   :== ABCArgument ABCTypeLabel        True
A_OFFSET :== ABCArgument ABCTypeAStackOffset False
B_OFFSET :== ABCArgument ABCTypeBStackOffset False
STRING   :== ABCArgument ABCTypeString       False
STRING_  :== ABCArgument ABCTypeString       True
BOOL     :== ABCArgument ABCTypeBool         False
BOOL_    :== ABCArgument ABCTypeBool         True
CHAR     :== ABCArgument ABCTypeChar         False
CHAR_    :== ABCArgument ABCTypeChar         True
INT      :== ABCArgument ABCTypeInt          False
INT_     :== ABCArgument ABCTypeInt          True
REAL     :== ABCArgument ABCTypeReal         False
REAL_    :== ABCArgument ABCTypeReal         True

i_create :: ABCInstructionEntry
i_create =
	{ zero
	& aie_instruction = "create"
	, aie_description = "Creates a new empty node and pushes its address to the A-stack."
	}

arith_instructions :: [ABCInstructionEntry]
arith_instructions =
	[ arith1 "absR"    "Real" "absolute value"
	, arith1 "acosR"   "Real" "arccosine"
	, arith1 "asinR"   "Real" "arcsine"
	, arith1 "atanR"   "Real" "arctangent"
	, arith1 "cosR"    "Real" "cosine"
	, arith1 "entierR" "Real" "(Int) entier (floor)"
	, arith1 "expR"    "Real" "exponential function (e^r)"
	, arith1 "lnR"     "Real" "natural logarithm"
	, arith1 "log10R"  "Real" "base-10 logarithm"
	, arith1 "notB"    "Bool" "logical negation"
	, arith1 "sinR"    "Real" "sine"
	, arith1 "sqrtR"   "Real" "square root"
	, arith1 "tanR"    "Real" "tangent"

	, op1 "decI" "Int"  "Decrements"
	, op1 "incI" "Int"  "Increments"
	, op1 "negI" "Int"  "Negates"
	, op1 "negR" "Real" "Negates"
	, op1 "not%" "Int"  "Bitwise negates"

	, op2 "addI"    "Int"  "Sums"
	, op2 "addR"    "Real" "Sums"
	, op2 "andB"    "Bool" "Logically conjuncts"
	, op2 "and%"    "Int"  "Bitwise conjuncts"
	, op2 "divI"    "Int"  "Divides"
	, op2 "divR"    "Real" "Divides"
	, op2 "eqB"     "Bool" "Checks equality on"
	, op2 "eqC"     "Char" "Checks equality on"
	, op2 "eqI"     "Int"  "Checks equality on"
	, op2 "eqR"     "Real" "Checks equality on"
	, i_eqAC_a
	, op2 "gtC"     "Char" "Checks greater-than on"
	, op2 "gtI"     "Int"  "Checks greater-than on"
	, op2 "gtR"     "Real" "Checks greater-than on"
	, op2 "ltC"     "Char" "Checks less-than on"
	, op2 "ltI"     "Int"  "Checks less-than on"
	, op2 "ltR"     "Real" "Checks less-than on"
	, op2 "mulI"    "Int"  "Multiplies"
	, op2 "mulR"    "Real" "Multiplies"
	, op2 "orB"     "Bool" "Logically disjuncts"
	, op2 "or%"     "Int"  "Bitwise disjuncts"
	, op2 "powR"    "Real" "Raises to the power on"
	, op2 "remI"    "Int"  "Computes the remainder after division of"
	, op2 "rotl%"   "Int"  "Bitwise left-rotate on"
	, op2 "rotr%"   "Int"  "Bitwise right-rotate on"
	, op2 "shiftl%" "Int"  "Bitwise left-shift on"
	, op2 "shiftr%" "Int"  "Bitwise right-shift on"
	, op2 "subI"    "Int"  "Subtracts"
	, op2 "subR"    "Real" "Subtracts"
	, op2 "xor%"    "Int"  "Bitwise XOR on"

	, eq_arg "Bool" BOOL 'A'
	, eq_arg "Bool" BOOL 'B'
	, eq_arg "Char" CHAR 'A'
	, eq_arg "Char" CHAR 'B'
	, eq_arg "Int"  INT  'A'
	, eq_arg "Int"  INT  'B'
	, eq_arg "Real" REAL 'A'
	, eq_arg "Real" REAL 'B'

	, convert "CtoI"  "Char" "Int"
	, convert "CtoAC" "Char" "String"
	, convert "ItoC"  "Int"  "Char"
	, convert "ItoR"  "Int"  "Real"
	, convert "RtoI"  "Real" "Int"
	]
where
	arith1 :: !String !String !String -> ABCInstructionEntry
	arith1 instr type description =
		{ zero
		& aie_instruction = instr
		, aie_description = "Computes the " + description + " of the " + type + " on top of the B-stack."
		}

	op1 :: !String !String !String -> ABCInstructionEntry
	op1 instr type description =
		{ zero
		& aie_instruction = instr
		, aie_description = description + " the " + type + " on top of the B-stack."
		}

	op2 :: !String !String !String -> ABCInstructionEntry
	op2 instr type description =
		{ zero
		& aie_instruction = instr
		, aie_description = description + " the two " + type + "s on top of the B-stack."
		}

	eq_arg :: !String !ABCArgument !Char -> ABCInstructionEntry
	eq_arg type arg stack =
		{ zero
		& aie_instruction = {'e','q',type.[0],'_',toLower stack}
		, aie_arguments   = [if (stack == 'A') A_OFFSET B_OFFSET, arg]
		, aie_description = "Checks equality between the " + {stack} + "-stack element and the second argument."
		}

	convert :: !String !String !String -> ABCInstructionEntry
	convert instr fr to =
		{ zero
		& aie_instruction = instr
		, aie_description = "Converts the " + fr + " on top of the B-stack to " + to + "."
		}

	i_eqAC_a =
		{ zero
		& aie_instruction = "eqAC_a"
		, aie_arguments   = [STRING]
		, aie_description = "Checks that the string on top of the A-stack equals the argument string."
		}

stack_operations :: [ABCInstructionEntry]
stack_operations =
	[ push    "Bool" BOOL
	, push    "Char" CHAR
	, push    "Int"  INT
	, push    "Real" REAL
	, push_a  "Bool"
	, push_a  "Char"
	, push_a  "Int"
	, push_a  "Real"
	, build   "Bool" BOOL
	, build   "Char" CHAR
	, build   "Int"  INT
	, build   "Real" REAL
	, i_buildAC
	, build_b "Bool"
	, build_b "Char"
	, build_b "Int"
	, build_b "Real"
	, i_create_array
	, i_create_array_
	, i_eq_desc
	, i_eq_desc_b
	, i_eq_nulldesc
	, i_pop_a
	, i_pop_b
	, i_push_a
	, i_push_b
	]
where
	push :: !String !ABCArgument -> ABCInstructionEntry
	push type arg =
		{ zero
		& aie_instruction = "push" + {type.[0]}
		, aie_arguments   = [arg]
		, aie_description = "Pushes the " + type + " argument to the B-stack."
		}

	push_a :: !String -> ABCInstructionEntry
	push_a type =
		{ zero
		& aie_instruction = "push" + {type.[0]} + "_a"
		, aie_arguments   = [INT]
		, aie_description = "Pushes the " + type + " from the nth position on the A-stack to the B-stack."
		}

	build :: !String !ABCArgument -> ABCInstructionEntry
	build type arg =
		{ zero
		& aie_instruction = "build" + {type.[0]}
		, aie_arguments   = [arg]
		, aie_description = "Builds a " + type + "-node with the argument as value on the A-stack."
		}

	build_b :: !String -> ABCInstructionEntry
	build_b type =
		{ zero
		& aie_instruction = "build" + {type.[0]} + "_b"
		, aie_arguments   = [INT]
		, aie_description = "Builds a " + type + "-node with the value on the nth position of the B-stack on the A-stack."
		}

	i_buildAC =
		{ zero
		& aie_instruction = "buildAC"
		, aie_arguments   = [STRING]
		, aie_description = "Pushes the argument string to the A-stack."
		}

	i_create_array =
		{ zero
		& aie_instruction = "create_array"
		, aie_arguments   = [LABEL, A_OFFSET, B_OFFSET]
		, aie_description = join " "
			[ "Creates an array on the A-stack."
			, "The elements have type `label` (which can be `_` for any A-stack type)."
			, "The last two arguments indicate the stack sizes of the elements."
			, "The size and initial value are popped from the B and A stacks."
			]
		}
	i_create_array_ =
		{ zero
		& aie_instruction = "create_array_"
		, aie_arguments   = [LABEL, A_OFFSET, B_OFFSET]
		, aie_description = join " "
			[ "Creates an array on the A-stack."
			, "The elements have type `label` (which can be `_` for any A-stack type)."
			, "The last two arguments indicate the stack sizes of the elements."
			, "The size is popped from the B-stack; the elements are initialised as `_Nil` regardless of the type."
			]
		}

	i_eq_desc =
		{ zero
		& aie_instruction = "eq_desc"
		, aie_arguments   = [LABEL, INT, A_OFFSET]
		, aie_description = join " "
			[ "Checks that the indicated node on the A-stack matches the descriptor given by the label."
			, "The `int` argument is the arity of the descriptor."
			]
		}
	i_eq_desc_b =
		{ zero
		& aie_instruction = "eq_desc_b"
		, aie_arguments   = [LABEL, A_OFFSET]
		, aie_description = join " "
			[ "The indicated node on the A-stack is assumed to be an array."
			, "The instruction checks that the array is of the type indicated by `label`."
			]
		}
	i_eq_nulldesc =
		{ zero
		& aie_instruction = "eq_nulldesc"
		, aie_arguments   = [LABEL, A_OFFSET]
		, aie_description = "Checks that the indicated node on the A-stack matches the descriptor given by the label, ignoring arity."
		}

	i_pop_a =
		{ zero
		& aie_instruction = "pop_a"
		, aie_arguments   = [A_OFFSET]
		, aie_description = "Pops elements off the A-stack until the referenced element."
		}
	i_pop_b =
		{ zero
		& aie_instruction = "pop_b"
		, aie_arguments   = [B_OFFSET]
		, aie_description = "Pops elements off the B-stack until the referenced element."
		}
	i_push_a =
		{ zero
		& aie_instruction = "push_a"
		, aie_arguments   = [A_OFFSET]
		, aie_description = "Pushes the referenced A-stack element on the A-stack."
		}
	i_push_b =
		{ zero
		& aie_instruction = "push_b"
		, aie_arguments   = [B_OFFSET]
		, aie_description = "Pushes the referenced B-stack element on the B-stack."
		}

branches :: [ABCInstructionEntry]
branches =
	[ i_jmp
	, i_jmp_false
	, i_jmp_true
	, i_jsr
	, i_jsr_eval
	, i_rtn
	]
where
	i_jmp =
		{ zero
		& aie_instruction = "jmp"
		, aie_arguments   = [LABEL]
		, aie_description = "Unconditional jump to a label."
		}
	i_jmp_false =
		{ zero
		& aie_instruction = "jmp_false"
		, aie_arguments   = [LABEL]
		, aie_description = "Jump to a label if the Bool on top of the B-stack is false."
		}
	i_jmp_true =
		{ zero
		& aie_instruction = "jmp_true"
		, aie_arguments   = [LABEL]
		, aie_description = "Jump to a label if the Bool on top of the B-stack is true."
		}
	i_jsr =
		{ zero
		& aie_instruction = "jsr"
		, aie_arguments   = [LABEL]
		, aie_description = "Subroutine jump to a label. {{`rtn`}} returns to the instruction after this `jsr`."
		}
	i_jsr_eval =
		{ zero
		& aie_instruction = "jsr_eval"
		, aie_arguments   = [A_OFFSET, LABEL]
		, aie_description = "Subroutine jump to evaluate the indicated A-stack element. {{`rtn`}} returns to the instruction after this `jsr_eval`."
		}
	i_rtn =
		{ zero
		& aie_instruction = "rtn"
		, aie_description = "Returns from a subroutine call (e.g. {{`jsr`}})."
		}

miscellaneous :: [ABCInstructionEntry]
miscellaneous =
	[ i_ccall
	, i_centry
	, i_get_node_arity
	, i_halt
	, i_instruction
	, i_load_i
	, i_load_si16
	, i_load_si32
	, i_load_ui8
	, i_no_op
	, i_push_r_arg_t
	, i_push_t_r_a
	, i_push_t_r_args
	]
where
	i_ccall =
		{ zero
		& aie_instruction = "ccall"
		, aie_arguments   = [LABEL, STRING]
		, aie_description = join "\n"
			[ "Calls a C function."
			, "Some of this is documented in https://svn.cs.ru.nl/repos/clean-tools/trunk/htoclean/CallingCFromClean.html"
			, "The first argument is the name of the function, the second is the signature."
			, "\n"
			, "The signature has to be of the form `flags?input?sep output(sep state)?`, where"
			, "  - sep    can be either `-` or `:`."
			, "  - flags  can be `G` and/or `P`. `G` saves the state in global variables and is needed when the called C function will call Clean functions. `P` lets the callee pop arguments (necessary on 32-bit Windows)."
			, "  - input  is a number of input argument types (allowed: `IpRrSsAOF`)."
			, "  - output is a number of output argument types (allowed: `VIpRrSsAOF`)."
			, "  - state  is a carried state that is not passed to the C function, for example used to thread {{`World`}} in ccalls (allowed: `IpRSA`)."
			, "\n"
			, "Input, output and state argument types can be:"
			, "  - `I`    for integers"
			, "  - `p`    for pointers (e.g. from {{`System.Pointer`}}; on most systems this is identical to `I`)"
			, "  - [`Rr`] for reals"
			, "  - `S`    for Clean Strings (`{#Char}`). If used as input type this passes a pointer to the string's length (number of characters). The actual array is at offset 4/8 (32/64 bit). If this is used as output type, the C function has to return a pointer to the string's length, followed by the actual string. A copy of the string will be created in the Clean heap, and this copy will be used by Clean. If the string was allocated in C, for example using malloc, it should be deallocated in C when it no longer used, it is not automatically deallocated by Clean."
			, "  - `s`    for the characters of a Clean String (handy to use in conjuction with {{`packString`}}, as the string is not null-terminated). The length (number of characters) is at offset -4/-8. (32/64 bit)."
			, "  - `A`    for A-stack elements. A pointer to the third block of the node is passed. For arrays, this is a pointer to the elements. The size of the array is one word higher in the block."
			, "  - [`OF`] for function pointers"
			, "  - `V`    for `void`, packs the following argument types in a tuple (e.g. `VIR` means `(Int, Real)`)"
			]
		}
	i_centry =
		{ zero
		& aie_instruction = "centry"
		, aie_arguments   = [LABEL, LABEL, STRING]
		, aie_description = join "\n"
			[ "Adds code to call a Clean function from C."
			, "Usually it is not needed to write this instruction yourself."
			, "It is generated with the `foreign export` construct.\n"
			, "The first label is the name of the C function to generate."
			, "The second label is the Clean function to link it to.\n"
			, "The string argument indicates the type."
			, "For more information, see {{`ccall`}}."
			]
		}

	i_get_node_arity =
		{ zero
		& aie_instruction = "get_node_arity"
		, aie_arguments   = [A_OFFSET]
		, aie_description = "Pushes the arity of the descriptor of the referenced A-stack element to the B-stack."
		}

	i_halt =
		{ zero
		& aie_instruction = "halt"
		, aie_description = "Terminates the program immediately."
		}

	i_instruction =
		{ zero
		& aie_instruction = "instruction"
		, aie_arguments   = [INT]
		, aie_description = "Adds the raw argument as a word in the generated object file."
		}

	i_load_i =
		{ zero
		& aie_instruction = "load_i"
		, aie_arguments   = [INT]
		, aie_description = join "\n\n"
			[ "Take the top of the B-stack as a pointer and read an integer from that pointer with the argument as offset."
			, "See also {{`load_si16`}}, {{`load_si32`}}, {{`load_ui8`}}."
			]
		}
	i_load_si16 =
		{ zero
		& aie_instruction = "load_si16"
		, aie_arguments   = [INT]
		, aie_description = join "\n\n"
			[ "Take the top of the B-stack as a pointer and read a 16-bit signed integer from that pointer with the argument as offset."
			, "See also {{`load_i}}, {{`load_si32`}}, {{`load_ui8`}}."
			]
		}
	i_load_si32 =
		{ zero
		& aie_instruction = "load_si32"
		, aie_arguments   = [INT]
		, aie_description = join "\n\n"
			[ "Take the top of the B-stack as a pointer and read a 32-bit signed integer from that pointer with the argument as offset."
			, "This instruction is only available on 64-bit systems. On 32-bit systems, {{`load_i`}} has the same effect."
			, "See also {{`load_i`}}, {{`load_si16`}}, {{`load_ui8`}}."
			]
		}
	i_load_ui8 =
		{ zero
		& aie_instruction = "load_ui8"
		, aie_arguments   = [INT]
		, aie_description = join "\n\n"
			[ "Take the top of the B-stack as a pointer and read a 8-bit unsigned integer from that pointer with the argument as offset."
			, "See also {{`load_i`}}, {{`load_si16`}}, {{`load_si32`}}."
			]
		}

	i_no_op =
		{ zero
		& aie_instruction = "no_op"
		, aie_description = join "\n"
			[ "Do nothing. This is for example useful in the `cast` function:\n"
			, "```clean"
			, "cast :: .a -> .b"
			, "cast _ = code {"
			, "\tno_op"
			, "}"
			, "```"
			]
		}

	i_push_r_arg_t =
		{ zero
		& aie_instruction = "push_r_arg_t"
		, aie_description = join " "
			[ "Gets the *n*th element from the type string of a record."
			, "The type string is on top of the B-stack; *n* below that."
			]
		}
	i_push_t_r_a =
		{ zero
		& aie_instruction = "push_t_r_a"
		, aie_arguments   = [A_OFFSET]
		, aie_description = "Push the address of the type string of the referenced record to the B-stack."
		}
	i_push_t_r_args =
		{ zero
		& aie_instruction = "push_t_r_args"
		, aie_description = "Pops a record from the A-stack, pushes its members in reversed order to both of the stacks, then pushes the address of the type string to the B-stack."
		}

directives :: [ABCInstructionEntry]
directives =
	[ d_d
	, d_n
	, d_nu
	, d_o
	, d_export
	, d_inline
	, d_module
	, d_depend
	, d_end
	, d_endinfo
	, d_start
	]
where
	d_d =
		{ zero
		& aie_instruction = ".d"
		, aie_arguments   = [A_OFFSET, B_OFFSET, STRING_]
		, aie_description = concat
			[ "Indicates how many stack elements are on the stack when a jump follows."
			, "The first integer is the number of elements on the A-stack; the second that of B-stack elements."
			, "The optional third argument indicates the type of the B-stack elements, e.g. `bbi` for two booleans and an integer."
			]
		}
	d_n =
		{ zero
		& aie_instruction = ".n"
		, aie_arguments   = [A_OFFSET, LABEL]
		, aie_description = concat
			[ "Indicates the arity of node entry labels."
			, "The label is the label of the corresponding descriptor, or `_` if it does not exist."
			, "\n\nThere are some special cases:\n\n"
			, "- An arity of `-1` is for tuple selectors;\n"
			, "- An arity of `-2` is for indirection nodes;\n"
			, "- An arity of `-3` is for record selectors of basic types;\n"
			, "- An arity of `-4` is for record selectors of non-basic types.\n\n"
			, "See also {{`.nu`}}."
			]
		}
	d_nu =
		{ zero
		& aie_instruction = ".nu"
		, aie_arguments   = [A_OFFSET, B_OFFSET, LABEL]
		, aie_description = concat
			[ "Indicates the arity of node entry labels with arguments on the B-stack (otherwise, {{`.n`}} is used)."
			, "The first integer is the number of A-stack arguments; the second the number of B-stack arguments."
			, "The label is the label of the corresponding descriptor, or `_` if it does not exist."
			]
		}
	d_o =
		{ zero
		& aie_instruction = ".o"
		, aie_arguments   = [A_OFFSET, B_OFFSET, STRING_]
		, aie_description = concat
			[ "Indicates how many stack elements are 'given back' to a calling function when a {{`rtn`}} follows."
			, "The first integer is the number of elements on the A-stack; the second that of B-stack elements."
			, "The optional third argument indicates the type of the B-stack elements, e.g. `bbi` for two booleans and an integer."
			]
		}

	d_export =
		{ zero
		& aie_instruction = ".export"
		, aie_arguments   = [LABEL]
		, aie_description = "Exports a label (allows linking)."
		}
	d_inline =
		{ zero
		& aie_instruction = ".inline"
		, aie_arguments   = [LABEL]
		, aie_description = "Indicates that a label can (should) be inlined (usually for performance reasons)."
		}

	d_module =
		{ zero
		& aie_instruction = ".module"
		, aie_arguments   = [LABEL, STRING]
		, aie_description = "Indicates the name of the module, and its label in the data segment."
		}
	d_depend =
		{ zero
		& aie_instruction = ".depend"
		, aie_arguments   = [STRING]
		, aie_description = "Indicates a module that this module depends on."
		}
	d_end =
		{ zero
		& aie_instruction = ".end"
		, aie_description = "Indicates the end of the ABC file."
		}
	d_endinfo =
		{ zero
		& aie_instruction = ".endinfo"
		, aie_description = "Indicates the end of the metadata in the ABC file."
		}
	d_start =
		{ zero
		& aie_instruction = ".start"
		, aie_arguments   = [LABEL]
		, aie_description = "Indicates the label to start execution at."
		}

/**
 * Instructions without documentation yet
 */
other_instructions :: [String]
other_instructions =
	[ "add_args"
	, "addLU"
	, "build"
	, "buildF_b"
	, "buildh"
	, "build_r"
	, "build_u"
	, "catS"
	, "call"
	, "cmpS"
	, "ceilingR"
	, "copy_graph"
	, "code_channelP"
	, "create_channel"
	, "currentP"
	, "del_args"
	, "divLU"
	, "divU"
	, "eqD_b"
	, "eq_symbol"
	, "exit_false"
	, "fill"
	, "fill1"
	, "fill2"
	, "fill3"
	, "fill1_r"
	, "fill2_r"
	, "fill3_r"
	, "fillcaf"
	, "fillcp"
	, "fillcp_u"
	, "fill_u"
	, "fillh"
	, "fillB"
	, "fillB_b"
	, "fillC"
	, "fillC_b"
	, "fillF_b"
	, "fillI"
	, "fillI_b"
	, "fillR"
	, "fillR_b"
	, "fill_a"
	, "fill_r"
	, "floordivI"
	, "getWL"
	, "get_desc_arity"
	, "get_desc_flags_b"
	, "get_desc0_number"
	, "gtU"
	, "in"
	, "is_record"
	, "ItoP"
	, "jmp_ap"
	, "jmp_ap_upd"
	, "jmp_upd"
	, "jmp_eval"
	, "jmp_eval_upd"
	, "jmp_not_eqZ"
	, "jrsr"
	, "jsr_ap"
	, "ltU"
	, "modI"
	, "mulUUL"
	, "new_ext_reducer"
	, "new_int_reducer"
	, "newP"
	, "out"
	, "print"
	, "printD"
	, "print_char"
	, "print_int"
	, "print_real"
	, "print_r_arg"
	, "print_sc"
	, "print_symbol"
	, "print_symbol_sc"
	, "pushcaf"
	, "push_finalizers"
	, "pushA_a"
	, "pushD"
	, "pushD_a"
	, "pushF_a"
	, "pushL"
	, "pushLc"
	, "pushzs"
	, "push_a_b"
	, "push_arg"
	, "push_arg_b"
	, "push_args"
	, "push_args_u"
	, "push_array"
	, "push_arraysize"
	, "push_b_a"
	, "push_node"
	, "push_node_u"
	, "push_a_r_args"
	, "push_r_args"
	, "push_r_args_a"
	, "push_r_args_b"
	, "push_r_args_u"
	, "push_r_arg_D"
	, "push_r_arg_u"
	, "push_wl_args"
	, "pushZ"
	, "pushZR"
	, "putWL"
	, "randomP"
	, "release"
	, "remU"
	, "replace"
	, "repl_arg"
	, "repl_args"
	, "repl_args_b"
	, "repl_r_args"
	, "repl_r_args_a"
	, "select"
	, "send_graph"
	, "send_request"
	, "set_continue"
	, "set_defer"
	, "set_entry"
	, "set_finalizers"
	, "setwait"
	, "shiftrU"
	, "sincosR"
	, "sliceS"
	, "stop_reducer"
	, "subLU"
	, "addIo"
	, "mulIo"
	, "subIo"
	, "suspend"
	, "testcaf"
	, "truncateR"
	, "update_a"
	, "updatepop_a"
	, "update_b"
	, "updatepop_b"
	, "updateS"
	, "update"
	, ".algtype"
	, ".caf"
	, ".code"
	, ".comp"
	, ".a"
	, ".desc"
	, ".desc0"
	, ".descn"
	, ".descexp"
	, ".descs"
	, ".keep"
	, ".impdesc"
	, ".implab"
	, ".implib"
	, ".impmod"
	, ".impobj"
	, ".newlocallabel"
	, ".n_string"
	, ".pb"
	, ".pd"
	, ".pe"
	, ".pl"
	, ".pld"
	, ".pn"
	, ".pt"
	, ".record"
	, ".string"
	]