Added modules to builddb statistics

Added modules to builddb statistics

module builddb

// Project libraries
import qualified TypeDB as DB
from TypeDB import ::TypeExtras{..}, ::Macro{..}, ::ModuleInfo{..},
	instance zero TypeExtras, instance zero ModuleInfo

// StdEnv
from StdFunc import const, flip, o
import StdFile, StdList, StdMisc, StdArray, StdBool, StdString, StdTuple

// CleanPlatform
import Data.Maybe, Data.Either, Data.Error, Data.Func, Data.Tuple, Data.Functor
import Control.Applicative, Control.Monad
from Text import class Text(concat,replaceSubString,indexOf,startsWith),
	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,
	instance print Type, instance print Priority
from Type import qualified ::TypeDef{..}, ::Constructor{..}
import CoclUtils

// CleanPrettyPrint
import CleanPrettyPrint

// frontend
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(..), ::LineNr, ::FileName, ::FunctName,
	::Module{mod_ident,mod_defs},
	::ParsedDefinition(PD_TypeSpec,PD_Instance,PD_Class,PD_Type,PD_Generic,PD_Derive,PD_Function),
	::FunSpecials, ::Priority, ::ParsedModule, ::SymbolType,
	::ParsedInstanceAndMembers{..}, ::ParsedInstance{pi_ident,pi_pos,pi_types},
	::Type, ::ClassDef{class_ident,class_pos,class_args,class_context},
	::TypeVar, ::ParsedTypeDef, ::TypeDef{td_pos,td_ident},
	::GenericDef{gen_ident,gen_pos,gen_type,gen_vars},
	::GenericCaseDef{gc_type,gc_pos,gc_gcf}, ::GenericCaseFunctions(GCF), ::GCF,
	::FunKind(FK_Macro),
	::Rhs, ::ParsedExpr
from scanner import ::Priority(..), ::Assoc(..)
from parse import wantModule

:: CLI = { help    :: Bool
         , version :: Bool
         , root    :: String
         , libs    :: [(String, String -> Bool)]
         , exclude :: [String]
         }

instance zero CLI where
	zero = { version = False
	       , help    = False
	       , root    = "/opt/clean/lib/"
	       , libs    = [ ("StdEnv", const False)
	                   , ("StdLib", const False)
	                   , ("ArgEnv", const False)
	                   , ("Directory", const False)
	                   , ("Dynamics", const False)
	                   , ("Gast", const False)
	                   , ("Generics", const False)
	                   , ("MersenneTwister", const False)
	                   , ("TCPIP", const False)
	                   , ("clean-platform/OS-Independent", const False)
	                   , ("clean-platform/OS-Linux", const False)
	                   , ("clean-platform/OS-Linux-32", const False)
	                   , ("clean-platform/OS-Linux-64", const False)
	                   , ("clean-platform/OS-Mac", const False)
	                   , ("clean-platform/OS-Posix", const False)
	                   , ("clean-platform/OS-Windows", const False)
	                   , ("clean-platform/OS-Windows-32", const False)
	                   , ("clean-platform/OS-Windows-64", const False)
	                   , ("iTasks-SDK/Dependencies/graph_copy", const False)
	                   , ("iTasks-SDK/Dependencies/clean-sapl/src", const False)
	                   , ("iTasks-SDK/Server", startsWith "iTasks._Framework")
	                   , ("iTasks-SDK/Tests", const False)
	                   , ("ObjectIO", not o startsWith "Std")
	                   , ("SoccerFun/Game", const False)
	                   , ("SoccerFun/Gui", const False)
	                   , ("SoccerFun/StdLibExt", const False)
	                   , ("SoccerFun/StdReferee", const False)
	                   , ("SoccerFun/StdTeam", const False)
	                   ]
	       , exclude = [ "StdEnv/_startup"
	                   , "StdEnv/_system"
	                   , "clean-platform/OS-Independent/Deprecated"
	                   , "iTasks-SDK/Server/lib"
	                   , "SoccerFun/StdReferee/RefereeCoach_"
	                   , "SoccerFun/StdTeam/Team_"
	                   ]
	       }

VERSION :== "Cloogle's builddb version 0.1\n"
USAGE :== concat [
	VERSION, "\n",
	"Usage: ./builddb [opts] > types.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
	# (modss, w)  = mapSt (flip (uncurry $ findModules cli.exclude cli.root) "") cli.libs w
	# mods        = flatten modss
	# (st, w)     = init_identifiers newHeap w
	# cache       = empty_cache st
	# (db, w)     = loop cli.root mods 'DB'.newDb cache w
	# db          = 'DB'.putFunctions predefFunctions db
	# db          = 'DB'.putClasses predefClasses db
	# db          = 'DB'.putTypes predefTypes db
	# io          = stderr
	# io          = printStats db io
	# (ok1,w)     = fclose io w
	# f           = 'DB'.saveDb db f
	# (ok2,w)     = fclose f w
	= (ok1 && ok2,w)
| not ok = abort "Couldn't close stdio"
= w
where
	loop :: String [(String,String,Bool)] 'DB'.TypeDB
		*DclCache *World -> *('DB'.TypeDB, *World)
	loop _ [] db _ w = (db,w)
	loop root [(lib,mod,iscore):list] db cache w
	# (db, cache, w) = getModuleTypes root mod lib iscore cache db w
	# w = snd (fclose (stderr <<< lib <<< ": " <<< mod <<< "\n") 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,const False):c.libs]}) <$> parseCLI xs
		(x, _) = Left $ "Unknown option '" +++ x +++ "'"

	printStats :: !'DB'.TypeDB !*File -> *File
	printStats db f = f
		<<< "+-------------+------+\n"
		<<< "| Modules     | " <<< modules <<< " |\n"
		<<< "| Functions   | " <<< funs    <<< " |\n"
		<<< "| Types       | " <<< types   <<< " |\n"
		<<< "| Macros      | " <<< macros  <<< " |\n"
		<<< "| Classes     | " <<< classes <<< " |\n"
		<<< "| Instances   | " <<< insts   <<< " |\n"
		<<< "| Derivations | " <<< derives <<< " |\n"
		<<< "+-------------+------+\n"
	where
		[modules,funs,macros,types,classes,insts,derives:_]
			= map (pad 4)
				[ 'DB'.moduleCount db
				, 'DB'.functionCount db
				, 'DB'.macroCount db
				, 'DB'.typeCount db
				, 'DB'.classCount db
				, 'DB'.instanceCount db
				, 'DB'.deriveCount db
				]
		pad n i = {' ' \\ _ <- [0..n-size (toString i)-1]} +++ toString i

predefFunctions :: [('DB'.Location, 'DB'.ExtendedType)]
predefFunctions
	= [ ( 'DB'.Builtin "if"
	    , 'DB'.ET ('T'.Func ['T'.Type "Bool" [], 'T'.Var "a", 'T'.Var "a"] ('T'.Var "a") []) zero
	    )
	  , ( 'DB'.Builtin "dynamic"
	    , 'DB'.ET ('T'.Func ['T'.Var "a"] ('T'.Type "Dynamic" []) []) zero
	    )
	  ]

predefClasses :: [('DB'.Location, ['T'.TypeVar], 'T'.ClassContext, [('DB'.Name, 'DB'.ExtendedType)])]
predefClasses
	= [ ( 'DB'.Builtin "TC", ["v"], [], [])
	  ]

predefTypes :: [('DB'.Location, 'T'.TypeDef)]
predefTypes
	= [ ( 'DB'.Builtin "Bool"
	    , { deft
	      & 'Type'.td_name = "Bool"
	      , 'Type'.td_rhs  = 'T'.TDRCons False
	        [ { defc & 'Type'.cons_name="False" }
	        , { defc & 'Type'.cons_name="True" }
	        ]
	      }
	    )
	  , ( 'DB'.Builtin "Int",     { deft & 'Type'.td_name = "Int"     } )
	  , ( 'DB'.Builtin "Real",    { deft & 'Type'.td_name = "Real"    } )
	  , ( 'DB'.Builtin "Char",    { deft & 'Type'.td_name = "Char"    } )
	  , ( 'DB'.Builtin "String",  { deft & 'Type'.td_name = "String",
	      'Type'.td_rhs = 'T'.TDRSynonym ('T'.Type "_#Array" ['T'.Type "Char" []]) } )
	  , ( 'DB'.Builtin "Dynamic", { deft & 'Type'.td_name = "Dynamic" } )
	  , ( 'DB'.Builtin "File",    { deft & 'Type'.td_name = "File"    } )
	  , ( 'DB'.Builtin "World",   { deft & 'Type'.td_name = "World",
	                                       'Type'.td_uniq = True      } )
	  ]
where
	deft = {'Type'.td_name="", 'Type'.td_uniq=False, 'Type'.td_args=[], 'Type'.td_rhs='T'.TDRAbstract}
	defc = {'Type'.cons_name="", 'Type'.cons_args=[], 'Type'.cons_exi_vars=[], 'Type'.cons_context=[], 'Type'.cons_priority=Nothing}

//             Exclude   Root    Library        Check for core       Base module
findModules :: ![String] !String !'DB'.Library ('DB'.Module -> Bool) !String !*World
	-> *(![('DB'.Library, 'DB'.Module, Bool)], !*World)
findModules ex root lib iscore base w
| any (\e -> indexOf e path <> -1) ex = ([], w)
#! (fps, w)   = readDirectory path w
| isError fps = ([], w)
#! fps        = fromOk fps
#! mods       = map (\s -> let mod = basedot +++ s % (0, size s - 5) in
	(lib, mod, iscore mod)) $ filter included $ filter isDclModule fps
#! (moremodss,w) = mapSt (\d -> findModules ex root lib iscore (basedot +++ d)) (filter isDirectory fps) w
= (removeDup (mods ++ flatten moremodss), w)
where
	path = root +++ "/" +++ lib +++ if (base == "") "" "/" +++ replaceSubString "." "/" base
	basedot = if (base == "") "" (base +++ ".")

	included :: String -> Bool
	included s = not (any (\e -> indexOf e (path +++ "/" +++ s) <> -1) ex)

	isDclModule :: String -> Bool
	isDclModule s = s % (size s - 4, size s - 1) == ".dcl"

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

getModuleTypes :: String 'DB'.Module 'DB'.Library Bool
	*DclCache 'DB'.TypeDB *World -> *('DB'.TypeDB, *DclCache, *World)
getModuleTypes root mod lib iscore cache db w
# (Right dcl,cache,w) = readModule False cache w
# (icl,cache,w) = readModule True cache w
# icl = case icl of (Left _) = Nothing; (Right x) = Just x
# mod = dcl.mod_ident.id_name
# lib = cleanlib mod lib
# db  = 'DB'.putFunctions (pd_typespecs lib mod dcl.mod_defs icl) db
# db  = 'DB'.putInstances (pd_instances lib mod dcl.mod_defs icl) db
# db  = 'DB'.putClasses (pd_classes lib mod dcl.mod_defs icl) db
# typedefs = pd_types lib mod dcl.mod_defs icl
# db  = 'DB'.putTypes typedefs db
# db  = 'DB'.putFunctions (flatten $ map constructor_functions typedefs) db
# db  = 'DB'.putFunctions (flatten $ map record_functions typedefs) db
# db  = 'DB'.putFunctions (pd_generics lib mod dcl.mod_defs) db
# db  = 'DB'.putDerivationss (pd_derivations lib mod dcl.mod_defs) db
# db  = 'DB'.putMacros (pd_macros lib mod dcl.mod_defs) db
# db  = 'DB'.putModule lib mod {zero & is_core=iscore} 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_macros :: String String [ParsedDefinition] -> [('DB'.Location, 'DB'.Macro)]
	pd_macros lib mod dcl
		= [( 'DB'.Location lib mod (toLine pos) Nothing id.id_name
		   , { macro_as_string = priostring id +++ cpp pd
		     , macro_extras = {zero & te_priority = findPrio id >>= 'T'.toMaybePriority}
		     }
		   ) \\ pd=:(PD_Function pos id isinfix args rhs FK_Macro) <- dcl]
	where
		priostring :: Ident -> String
		priostring id = case findTypeSpec id dcl of
			Nothing    = ""
			(Just pri) = cpp pri +++ "\n"

		findPrio :: Ident -> Maybe Priority
		findPrio id = (\(PD_TypeSpec _ _ p _ _) -> p) <$> findTypeSpec id dcl

		findTypeSpec :: Ident [ParsedDefinition] -> Maybe ParsedDefinition
		findTypeSpec _  []          = Nothing
		findTypeSpec id [pd=:(PD_TypeSpec _ id` prio _ _):dcl]
		| id`.id_name == id.id_name = Just pd
		findTypeSpec id [_:dcl]     = findTypeSpec id dcl

	pd_derivations :: String String [ParsedDefinition]
		-> [('DB'.Name, [('DB'.Type, 'DB'.Location)])]
	pd_derivations lib mod dcl
		= [( id.id_name
		   , [('T'.toType gc_type, 'DB'.Location lib mod (toLine gc_pos) Nothing "")]
		   ) \\ PD_Derive gcdefs <- dcl, {gc_type,gc_pos,gc_gcf=GCF id _} <- gcdefs]

	pd_generics :: String String [ParsedDefinition]
		-> [('DB'.Location, 'DB'.ExtendedType)]
	pd_generics lib mod dcl
		= [( 'DB'.Location lib mod (toLine gen_pos) Nothing id_name
		   , 'DB'.ET ('T'.toType gen_type)
		       {zero & te_generic_vars=Just $ map 'T'.toTypeVar gen_vars
		             , te_representation=Just $ cpp gen}
		   ) \\ gen=:(PD_Generic {gen_ident={id_name},gen_pos,gen_type,gen_vars}) <- dcl]

	pd_typespecs :: String String [ParsedDefinition] (Maybe ParsedModule)
		-> [('DB'.Location, 'DB'.ExtendedType)]
	pd_typespecs lib mod dcl icl
		= [( 'DB'.Location lib mod (toLine pos) (findIclLine id_name =<< icl) id_name
		   , 'DB'.ET ('T'.toType t)
		       { zero & te_priority = 'T'.toMaybePriority p
		              , te_representation = Just $ cpp ts}
		   ) \\ ts=:(PD_TypeSpec pos id=:{id_name} p (Yes t) funspecs) <- dcl]
	where
		findIclLine :: String ParsedModule -> Maybe Int
		findIclLine name {mod_defs=pms}
			= case [pos \\ PD_TypeSpec pos id _ _ _ <- pms | id.id_name == name] of
				[FunPos _ l _:_] = Just l
				[LinePos _ l:_] = Just l
				_ = Nothing

	pd_instances :: String String [ParsedDefinition] (Maybe ParsedModule)
		-> [('DB'.Class, ['DB'.Type], 'DB'.Location)]
	pd_instances lib mod dcl icl
		= [( id_name
		   , map 'T'.toType pi_types
		   , 'DB'.Location lib mod (toLine pi_pos) (findIclLine id_name =<< icl) ""
		   ) \\ PD_Instance {pim_pi={pi_ident={id_name},pi_types,pi_pos}} <- dcl]
	where
		findIclLine :: String ParsedModule -> Maybe Int
		findIclLine name {mod_defs=pms}
			= case [pi_pos \\ PD_Instance {pim_pi={pi_pos,pi_ident}} <- pms | pi_ident.id_name == name] of
				[LinePos _ l:_] = Just l
				_ = Nothing

	pd_classes :: String String [ParsedDefinition] (Maybe ParsedModule)
		-> [('DB'.Location, ['T'.TypeVar], 'T'.ClassContext,
			[('DB'.Name, 'DB'.ExtendedType)])]
	pd_classes lib mod dcl icl
	# dcl = filter (\pd->case pd of (PD_Class _ _)=True; _=False) dcl
	= map (\(PD_Class {class_ident={id_name},class_pos,class_args,class_context} dcl)
		-> let typespecs = pd_typespecs lib mod dcl icl
		in ('DB'.Location lib mod (toLine class_pos) (findIclLine id_name =<< icl) id_name
		   , map 'T'.toTypeVar class_args
		   , flatten $ map 'T'.toClassContext class_context
		   , [(f,et) \\ ('DB'.Location _ _ _ _ f, et) <- typespecs])) dcl
	where
		findIclLine :: String ParsedModule -> Maybe Int
		findIclLine name {mod_defs=pms}
			= case [class_pos \\ PD_Class {class_ident,class_pos} _ <- pms | class_ident.id_name == name] of
				[LinePos _ l:_] = Just l
				_ = Nothing

	pd_types :: String String [ParsedDefinition] (Maybe ParsedModule)
		-> [('DB'.Location, 'DB'.TypeDef)]
	pd_types lib mod dcl icl
		= [let name = 'T'.td_name td in
			('DB'.Location lib mod (toLine ptd.td_pos) (findIclLine name =<< icl) name, td)
		   \\ PD_Type ptd <- dcl, td <- ['T'.toTypeDef ptd]]
	where
		findIclLine :: String ParsedModule -> Maybe Int
		findIclLine name {mod_defs=pms}
			= case [td_pos \\ PD_Type {td_ident,td_pos} <- pms | td_ident.id_name == name] of
				[LinePos _ l:_] = Just l
				_ = Nothing

	constructor_functions :: ('DB'.Location, 'DB'.TypeDef)
		-> [('DB'.Location, 'DB'.ExtendedType)]
	constructor_functions ('DB'.Location lib mod line iclline _, td)
		= [('DB'.Location lib mod line iclline c, 'DB'.ET f
			{zero & te_isconstructor=True
			      , te_representation=Just $ concat $
			          [c] ++ print_prio p ++ [" :: "] ++ print False f
			      , te_priority=p})
		   \\ (c,f,p) <- 'T'.constructorsToFunctions td]
	where
		print_prio :: (Maybe 'T'.Priority) -> [String]
		print_prio Nothing  = []
		print_prio (Just p) = [" "] ++ print False p

	record_functions :: ('DB'.Location, 'DB'.TypeDef)
		-> [('DB'.Location, 'DB'.ExtendedType)]
	record_functions ('DB'.Location lib mod line iclline _, td)
		= [('DB'.Location lib mod line iclline f, 'DB'.ET t
			{zero & te_isrecordfield=True
			      , te_representation=Just $ concat $ [".", f, " :: " : print False t]})
			\\ (f,t) <- 'T'.recordsToFunctions td]

	toLine :: Position -> 'DB'.LineNr
	toLine (FunPos _ l _) = Just l
	toLine (LinePos _ l)  = Just l
	toLine _              = Nothing

	readModule :: Bool *DclCache *World -> *(Either String ParsedModule, *DclCache, *World)
	readModule icl cache w
	# filename = root +++ "/" +++ lib +++ "/" +++ mkdir mod +++ if icl ".icl" ".dcl"
	# (ok,f,w) = fopen filename FReadText w
	| not ok = (Left $ "Couldn't open " +++ filename, cache, w)
	# (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 "" icl mod_id.boxed_ident NoPos True cache.hash_table stderr) w
	  cache = {cache & hash_table=ht}
	# (ok,w) = fclose f w
	| not ok = (Left $ "Couldn't open " +++ filename, cache, w)
	= (Right pm, cache, w)

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{..}, ::Macro{..}, ::ModuleInfo{..},
	instance zero TypeExtras, instance zero ModuleInfo

// StdEnv
from StdFunc import const, flip, o
import StdFile, StdList, StdMisc, StdArray, StdBool, StdString, StdTuple

// CleanPlatform
import Data.Maybe, Data.Either, Data.Error, Data.Func, Data.Tuple, Data.Functor
import Control.Applicative, Control.Monad
from Text import class Text(concat,replaceSubString,indexOf,startsWith),
	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,
	instance print Type, instance print Priority
from Type import qualified ::TypeDef{..}, ::Constructor{..}
import CoclUtils

// CleanPrettyPrint
import CleanPrettyPrint

// frontend
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(..), ::LineNr, ::FileName, ::FunctName,
	::Module{mod_ident,mod_defs},
	::ParsedDefinition(PD_TypeSpec,PD_Instance,PD_Class,PD_Type,PD_Generic,PD_Derive,PD_Function),
	::FunSpecials, ::Priority, ::ParsedModule, ::SymbolType,
	::ParsedInstanceAndMembers{..}, ::ParsedInstance{pi_ident,pi_pos,pi_types},
	::Type, ::ClassDef{class_ident,class_pos,class_args,class_context},
	::TypeVar, ::ParsedTypeDef, ::TypeDef{td_pos,td_ident},
	::GenericDef{gen_ident,gen_pos,gen_type,gen_vars},
	::GenericCaseDef{gc_type,gc_pos,gc_gcf}, ::GenericCaseFunctions(GCF), ::GCF,
	::FunKind(FK_Macro),
	::Rhs, ::ParsedExpr
from scanner import ::Priority(..), ::Assoc(..)
from parse import wantModule

:: CLI = { help    :: Bool
         , version :: Bool
         , root    :: String
         , libs    :: [(String, String -> Bool)]
         , exclude :: [String]
         }

instance zero CLI where
	zero = { version = False
	       , help    = False
	       , root    = "/opt/clean/lib/"
	       , libs    = [ ("StdEnv", const False)
	                   , ("StdLib", const False)
	                   , ("ArgEnv", const False)
	                   , ("Directory", const False)
	                   , ("Dynamics", const False)
	                   , ("Gast", const False)
	                   , ("Generics", const False)
	                   , ("MersenneTwister", const False)
	                   , ("TCPIP", const False)
	                   , ("clean-platform/OS-Independent", const False)
	                   , ("clean-platform/OS-Linux", const False)
	                   , ("clean-platform/OS-Linux-32", const False)
	                   , ("clean-platform/OS-Linux-64", const False)
	                   , ("clean-platform/OS-Mac", const False)
	                   , ("clean-platform/OS-Posix", const False)
	                   , ("clean-platform/OS-Windows", const False)
	                   , ("clean-platform/OS-Windows-32", const False)
	                   , ("clean-platform/OS-Windows-64", const False)
	                   , ("iTasks-SDK/Dependencies/graph_copy", const False)
	                   , ("iTasks-SDK/Dependencies/clean-sapl/src", const False)
	                   , ("iTasks-SDK/Server", startsWith "iTasks._Framework")
	                   , ("iTasks-SDK/Tests", const False)
	                   , ("ObjectIO", not o startsWith "Std")
	                   , ("SoccerFun/Game", const False)
	                   , ("SoccerFun/Gui", const False)
	                   , ("SoccerFun/StdLibExt", const False)
	                   , ("SoccerFun/StdReferee", const False)
	                   , ("SoccerFun/StdTeam", const False)
	                   ]
	       , exclude = [ "StdEnv/_startup"
	                   , "StdEnv/_system"
	                   , "clean-platform/OS-Independent/Deprecated"
	                   , "iTasks-SDK/Server/lib"
	                   , "SoccerFun/StdReferee/RefereeCoach_"
	                   , "SoccerFun/StdTeam/Team_"
	                   ]
	       }

VERSION :== "Cloogle's builddb version 0.1\n"
USAGE :== concat [
	VERSION, "\n",
	"Usage: ./builddb [opts] > types.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
	# (modss, w)  = mapSt (flip (uncurry $ findModules cli.exclude cli.root) "") cli.libs w
	# mods        = flatten modss
	# (st, w)     = init_identifiers newHeap w
	# cache       = empty_cache st
	# (db, w)     = loop cli.root mods 'DB'.newDb cache w
	# db          = 'DB'.putFunctions predefFunctions db
	# db          = 'DB'.putClasses predefClasses db
	# db          = 'DB'.putTypes predefTypes db
	# io          = stderr
	# io          = printStats db io
	# (ok1,w)     = fclose io w
	# f           = 'DB'.saveDb db f
	# (ok2,w)     = fclose f w
	= (ok1 && ok2,w)
| not ok = abort "Couldn't close stdio"
= w
where
	loop :: String [(String,String,Bool)] 'DB'.TypeDB
		*DclCache *World -> *('DB'.TypeDB, *World)
	loop _ [] db _ w = (db,w)
	loop root [(lib,mod,iscore):list] db cache w
	# (db, cache, w) = getModuleTypes root mod lib iscore cache db w
	# w = snd (fclose (stderr <<< lib <<< ": " <<< mod <<< "\n") 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,const False):c.libs]}) <$> parseCLI xs
		(x, _) = Left $ "Unknown option '" +++ x +++ "'"

	printStats :: !'DB'.TypeDB !*File -> *File
	printStats db f = f
		<<< "+-------------+------+\n"
		<<< "| Functions   | " <<< funs    <<< " |\n"
		<<< "| Types       | " <<< types   <<< " |\n"
		<<< "| Macros      | " <<< macros  <<< " |\n"
		<<< "| Classes     | " <<< classes <<< " |\n"
		<<< "| Instances   | " <<< insts   <<< " |\n"
		<<< "| Derivations | " <<< derives <<< " |\n"
		<<< "+-------------+------+\n"
	where
		[funs,macros,types,classes,insts,derives:_]
			= map (pad 4)
				[ 'DB'.functionCount db
				, 'DB'.macroCount db
				, 'DB'.typeCount db
				, 'DB'.classCount db
				, 'DB'.instanceCount db
				, 'DB'.deriveCount db
				]
		pad n i = {' ' \\ _ <- [0..n-size (toString i)-1]} +++ toString i

predefFunctions :: [('DB'.Location, 'DB'.ExtendedType)]
predefFunctions
	= [ ( 'DB'.Builtin "if"
	    , 'DB'.ET ('T'.Func ['T'.Type "Bool" [], 'T'.Var "a", 'T'.Var "a"] ('T'.Var "a") []) zero
	    )
	  , ( 'DB'.Builtin "dynamic"
	    , 'DB'.ET ('T'.Func ['T'.Var "a"] ('T'.Type "Dynamic" []) []) zero
	    )
	  ]

predefClasses :: [('DB'.Location, ['T'.TypeVar], 'T'.ClassContext, [('DB'.Name, 'DB'.ExtendedType)])]
predefClasses
	= [ ( 'DB'.Builtin "TC", ["v"], [], [])
	  ]

predefTypes :: [('DB'.Location, 'T'.TypeDef)]
predefTypes
	= [ ( 'DB'.Builtin "Bool"
	    , { deft
	      & 'Type'.td_name = "Bool"
	      , 'Type'.td_rhs  = 'T'.TDRCons False
	        [ { defc & 'Type'.cons_name="False" }
	        , { defc & 'Type'.cons_name="True" }
	        ]
	      }
	    )
	  , ( 'DB'.Builtin "Int",     { deft & 'Type'.td_name = "Int"     } )
	  , ( 'DB'.Builtin "Real",    { deft & 'Type'.td_name = "Real"    } )
	  , ( 'DB'.Builtin "Char",    { deft & 'Type'.td_name = "Char"    } )
	  , ( 'DB'.Builtin "String",  { deft & 'Type'.td_name = "String",
	      'Type'.td_rhs = 'T'.TDRSynonym ('T'.Type "_#Array" ['T'.Type "Char" []]) } )
	  , ( 'DB'.Builtin "Dynamic", { deft & 'Type'.td_name = "Dynamic" } )
	  , ( 'DB'.Builtin "File",    { deft & 'Type'.td_name = "File"    } )
	  , ( 'DB'.Builtin "World",   { deft & 'Type'.td_name = "World",
	                                       'Type'.td_uniq = True      } )
	  ]
where
	deft = {'Type'.td_name="", 'Type'.td_uniq=False, 'Type'.td_args=[], 'Type'.td_rhs='T'.TDRAbstract}
	defc = {'Type'.cons_name="", 'Type'.cons_args=[], 'Type'.cons_exi_vars=[], 'Type'.cons_context=[], 'Type'.cons_priority=Nothing}

//             Exclude   Root    Library        Check for core       Base module
findModules :: ![String] !String !'DB'.Library ('DB'.Module -> Bool) !String !*World
	-> *(![('DB'.Library, 'DB'.Module, Bool)], !*World)
findModules ex root lib iscore base w
| any (\e -> indexOf e path <> -1) ex = ([], w)
#! (fps, w)   = readDirectory path w
| isError fps = ([], w)
#! fps        = fromOk fps
#! mods       = map (\s -> let mod = basedot +++ s % (0, size s - 5) in
	(lib, mod, iscore mod)) $ filter included $ filter isDclModule fps
#! (moremodss,w) = mapSt (\d -> findModules ex root lib iscore (basedot +++ d)) (filter isDirectory fps) w
= (removeDup (mods ++ flatten moremodss), w)
where
	path = root +++ "/" +++ lib +++ if (base == "") "" "/" +++ replaceSubString "." "/" base
	basedot = if (base == "") "" (base +++ ".")

	included :: String -> Bool
	included s = not (any (\e -> indexOf e (path +++ "/" +++ s) <> -1) ex)

	isDclModule :: String -> Bool
	isDclModule s = s % (size s - 4, size s - 1) == ".dcl"

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

getModuleTypes :: String 'DB'.Module 'DB'.Library Bool
	*DclCache 'DB'.TypeDB *World -> *('DB'.TypeDB, *DclCache, *World)
getModuleTypes root mod lib iscore cache db w
# (Right dcl,cache,w) = readModule False cache w
# (icl,cache,w) = readModule True cache w
# icl = case icl of (Left _) = Nothing; (Right x) = Just x
# mod = dcl.mod_ident.id_name
# lib = cleanlib mod lib
# db  = 'DB'.putFunctions (pd_typespecs lib mod dcl.mod_defs icl) db
# db  = 'DB'.putInstances (pd_instances lib mod dcl.mod_defs icl) db
# db  = 'DB'.putClasses (pd_classes lib mod dcl.mod_defs icl) db
# typedefs = pd_types lib mod dcl.mod_defs icl
# db  = 'DB'.putTypes typedefs db
# db  = 'DB'.putFunctions (flatten $ map constructor_functions typedefs) db
# db  = 'DB'.putFunctions (flatten $ map record_functions typedefs) db
# db  = 'DB'.putFunctions (pd_generics lib mod dcl.mod_defs) db
# db  = 'DB'.putDerivationss (pd_derivations lib mod dcl.mod_defs) db
# db  = 'DB'.putMacros (pd_macros lib mod dcl.mod_defs) db
# db  = 'DB'.putModule lib mod {zero & is_core=iscore} 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_macros :: String String [ParsedDefinition] -> [('DB'.Location, 'DB'.Macro)]
	pd_macros lib mod dcl
		= [( 'DB'.Location lib mod (toLine pos) Nothing id.id_name
		   , { macro_as_string = priostring id +++ cpp pd
		     , macro_extras = {zero & te_priority = findPrio id >>= 'T'.toMaybePriority}
		     }
		   ) \\ pd=:(PD_Function pos id isinfix args rhs FK_Macro) <- dcl]
	where
		priostring :: Ident -> String
		priostring id = case findTypeSpec id dcl of
			Nothing    = ""
			(Just pri) = cpp pri +++ "\n"

		findPrio :: Ident -> Maybe Priority
		findPrio id = (\(PD_TypeSpec _ _ p _ _) -> p) <$> findTypeSpec id dcl

		findTypeSpec :: Ident [ParsedDefinition] -> Maybe ParsedDefinition
		findTypeSpec _  []          = Nothing
		findTypeSpec id [pd=:(PD_TypeSpec _ id` prio _ _):dcl]
		| id`.id_name == id.id_name = Just pd
		findTypeSpec id [_:dcl]     = findTypeSpec id dcl

	pd_derivations :: String String [ParsedDefinition]
		-> [('DB'.Name, [('DB'.Type, 'DB'.Location)])]
	pd_derivations lib mod dcl
		= [( id.id_name
		   , [('T'.toType gc_type, 'DB'.Location lib mod (toLine gc_pos) Nothing "")]
		   ) \\ PD_Derive gcdefs <- dcl, {gc_type,gc_pos,gc_gcf=GCF id _} <- gcdefs]

	pd_generics :: String String [ParsedDefinition]
		-> [('DB'.Location, 'DB'.ExtendedType)]
	pd_generics lib mod dcl
		= [( 'DB'.Location lib mod (toLine gen_pos) Nothing id_name
		   , 'DB'.ET ('T'.toType gen_type)
		       {zero & te_generic_vars=Just $ map 'T'.toTypeVar gen_vars
		             , te_representation=Just $ cpp gen}
		   ) \\ gen=:(PD_Generic {gen_ident={id_name},gen_pos,gen_type,gen_vars}) <- dcl]

	pd_typespecs :: String String [ParsedDefinition] (Maybe ParsedModule)
		-> [('DB'.Location, 'DB'.ExtendedType)]
	pd_typespecs lib mod dcl icl
		= [( 'DB'.Location lib mod (toLine pos) (findIclLine id_name =<< icl) id_name
		   , 'DB'.ET ('T'.toType t)
		       { zero & te_priority = 'T'.toMaybePriority p
		              , te_representation = Just $ cpp ts}
		   ) \\ ts=:(PD_TypeSpec pos id=:{id_name} p (Yes t) funspecs) <- dcl]
	where
		findIclLine :: String ParsedModule -> Maybe Int
		findIclLine name {mod_defs=pms}
			= case [pos \\ PD_TypeSpec pos id _ _ _ <- pms | id.id_name == name] of
				[FunPos _ l _:_] = Just l
				[LinePos _ l:_] = Just l
				_ = Nothing

	pd_instances :: String String [ParsedDefinition] (Maybe ParsedModule)
		-> [('DB'.Class, ['DB'.Type], 'DB'.Location)]
	pd_instances lib mod dcl icl
		= [( id_name
		   , map 'T'.toType pi_types
		   , 'DB'.Location lib mod (toLine pi_pos) (findIclLine id_name =<< icl) ""
		   ) \\ PD_Instance {pim_pi={pi_ident={id_name},pi_types,pi_pos}} <- dcl]
	where
		findIclLine :: String ParsedModule -> Maybe Int
		findIclLine name {mod_defs=pms}
			= case [pi_pos \\ PD_Instance {pim_pi={pi_pos,pi_ident}} <- pms | pi_ident.id_name == name] of
				[LinePos _ l:_] = Just l
				_ = Nothing

	pd_classes :: String String [ParsedDefinition] (Maybe ParsedModule)
		-> [('DB'.Location, ['T'.TypeVar], 'T'.ClassContext,
			[('DB'.Name, 'DB'.ExtendedType)])]
	pd_classes lib mod dcl icl
	# dcl = filter (\pd->case pd of (PD_Class _ _)=True; _=False) dcl
	= map (\(PD_Class {class_ident={id_name},class_pos,class_args,class_context} dcl)
		-> let typespecs = pd_typespecs lib mod dcl icl
		in ('DB'.Location lib mod (toLine class_pos) (findIclLine id_name =<< icl) id_name
		   , map 'T'.toTypeVar class_args
		   , flatten $ map 'T'.toClassContext class_context
		   , [(f,et) \\ ('DB'.Location _ _ _ _ f, et) <- typespecs])) dcl
	where
		findIclLine :: String ParsedModule -> Maybe Int
		findIclLine name {mod_defs=pms}
			= case [class_pos \\ PD_Class {class_ident,class_pos} _ <- pms | class_ident.id_name == name] of
				[LinePos _ l:_] = Just l
				_ = Nothing

	pd_types :: String String [ParsedDefinition] (Maybe ParsedModule)
		-> [('DB'.Location, 'DB'.TypeDef)]
	pd_types lib mod dcl icl
		= [let name = 'T'.td_name td in
			('DB'.Location lib mod (toLine ptd.td_pos) (findIclLine name =<< icl) name, td)
		   \\ PD_Type ptd <- dcl, td <- ['T'.toTypeDef ptd]]
	where
		findIclLine :: String ParsedModule -> Maybe Int
		findIclLine name {mod_defs=pms}
			= case [td_pos \\ PD_Type {td_ident,td_pos} <- pms | td_ident.id_name == name] of
				[LinePos _ l:_] = Just l
				_ = Nothing

	constructor_functions :: ('DB'.Location, 'DB'.TypeDef)
		-> [('DB'.Location, 'DB'.ExtendedType)]
	constructor_functions ('DB'.Location lib mod line iclline _, td)
		= [('DB'.Location lib mod line iclline c, 'DB'.ET f
			{zero & te_isconstructor=True
			      , te_representation=Just $ concat $
			          [c] ++ print_prio p ++ [" :: "] ++ print False f
			      , te_priority=p})
		   \\ (c,f,p) <- 'T'.constructorsToFunctions td]
	where
		print_prio :: (Maybe 'T'.Priority) -> [String]
		print_prio Nothing  = []
		print_prio (Just p) = [" "] ++ print False p

	record_functions :: ('DB'.Location, 'DB'.TypeDef)
		-> [('DB'.Location, 'DB'.ExtendedType)]
	record_functions ('DB'.Location lib mod line iclline _, td)
		= [('DB'.Location lib mod line iclline f, 'DB'.ET t
			{zero & te_isrecordfield=True
			      , te_representation=Just $ concat $ [".", f, " :: " : print False t]})
			\\ (f,t) <- 'T'.recordsToFunctions td]

	toLine :: Position -> 'DB'.LineNr
	toLine (FunPos _ l _) = Just l
	toLine (LinePos _ l)  = Just l
	toLine _              = Nothing

	readModule :: Bool *DclCache *World -> *(Either String ParsedModule, *DclCache, *World)
	readModule icl cache w
	# filename = root +++ "/" +++ lib +++ "/" +++ mkdir mod +++ if icl ".icl" ".dcl"
	# (ok,f,w) = fopen filename FReadText w
	| not ok = (Left $ "Couldn't open " +++ filename, cache, w)
	# (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 "" icl mod_id.boxed_ident NoPos True cache.hash_table stderr) w
	  cache = {cache & hash_table=ht}
	# (ok,w) = fclose f w
	| not ok = (Left $ "Couldn't open " +++ filename, cache, w)
	= (Right pm, cache, w)

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)


Add --module-filter and --exclude-builtins to builddb

module builddb

import StdArray
import StdBool
import StdFile
from StdFunc import const, flip, id, o
import StdList
import StdMisc
import StdString
import StdTuple

import Clean.Types
import Control.Monad => qualified join
import Data.Either
import Data.Error
from Data.Func import $, hyperstrict, mapSt
import Data.Functor
import Data.List
import Data.Maybe
import System.CommandLine
import System.File
import System.Options
from Text import class Text(join,startsWith), instance Text String
import Text.GenJSON

import Regex.Match
import Regex.Parse

import Cloogle.DB
from Cloogle.DB.Factory import :: TemporaryDB, newTemporaryDB, finaliseDB,
	findModules, indexModule, constructor_functions, record_functions,
	:: IndexItem, :: SourceURL, :: PathPattern

import Builtin.ABC
import Builtin.Predef
import Builtin.Syntax

:: Options =
	{ root             :: !String
	, libs_file        :: !String
	, module_filter    :: !Maybe Regex
	, include_builtins :: !Bool
	}

derive JSONDecode IndexItem, SourceURL, PathPattern

instance zero Options
where
	zero =
		{ root             = "/opt/clean/lib/"
		, libs_file        = "libs.json"
		, module_filter    = Nothing
		, include_builtins = True
		}

optionDescription :: Option Options
optionDescription = WithHelp True $ Options
	[ Shorthand "-r" "--root" $ Option
		"--root"
		(\dir opts -> Ok {opts & root=dir})
		"PATH"
		"Use PATH as the root directory for libraries (default: /opt/clean/lib)"
	, Shorthand "-l" "--libraries" $ Option
		"--libraries"
		(\file opts -> Ok {opts & libs_file=file})
		"FILE"
		"Use FILE for a list of libraries to index (default: libs.json)"
	, Option
		"--module-filter"
		(\filter opts -> case compile filter of
			Error e -> Error ["Regex parsing failed: " +++ e]
			Ok rgx  -> Ok {opts & module_filter=Just rgx})
		"REGEX"
		"Only index modules matching the regular expression REGEX"
	, Flag
		"--exclude-builtins"
		(\opts -> Ok {opts & include_builtins=False})
		"Exclude builtins from the index"
	]

Start :: *World -> *World
Start w
# ([prog:args], w) = getCommandLine w
# opts = parseOptions optionDescription args zero
| isError opts
	# err = stderr <<< join "\n" (fromError opts) <<< "\n"
	# (_,w) = fclose err w
	= w
# opts = fromOk opts
# (libsf, w) = readFile opts.libs_file w
# libsjson   = fromString $ fromOk libsf
# libs       = case libsjson of
	JSONObject groups -> sequence $ [fromJSON i \\ (_,JSONArray g) <- groups, i <- g]
	_                 -> Nothing
| isError libsf || isNothing libs
	# err = stderr <<< "Could not read " <<< opts.libs_file <<< "\n"
	# (_,w) = fclose err w
	= w
# libs       = fromJust libs
# (mods, w)  = mapSt (flip (findModules opts.root) "") libs w
# mods       = flatten mods
# mods       = case opts.module_filter of
	Just ftr -> filter (\m -> not $ isEmpty $ match ftr $ fromString $ getName m.me_loc) mods
	Nothing  -> mods
#! (db, w)   = loop opts.root mods newTemporaryDB w
#! (ok,w)    = fclose (stderr <<< "Linking database entries; this may take up to 10 minutes...\n") w
| not ok     = abort "Couldn't close stderr\n"
#! db        = finaliseDB (if opts.include_builtins builtins []) db
#! (db,err)  = printStats db stderr
#! (ok1,w)   = fclose err w
#! (f, w)    = stdio w
#! (db,f)    = saveDB db f
#! (ok2,w)   = fclose f w
#! (_,dbg,w) = fopen "typetree.dot" FWriteText w
#! (db,dbg)  = writeTypeTree db dbg
#! (_,w)     = fclose dbg w
= w
where
	loop :: String [ModuleEntry] !TemporaryDB !*World -> *(!TemporaryDB, !*World)
	loop _ [] db w = (db,w)
	loop root [mod:list] db w
	#! (_, w) = fclose (stderr <<< lib <<< ": " <<< modname <<< "\n") w
	#! (db, w) = indexModule False root mod db w
	#! db = hyperstrict db
	= loop root list db w
	where
		lib = fromJust (getLibrary mod.me_loc)
		modname = getName mod.me_loc

	builtins =
		map FunctionEntry builtin_functions ++
		map ClassEntry builtin_classes ++
		map TypeDefEntry builtin_types ++
		map FunctionEntry (concatMap constructor_functions builtin_types) ++
		map FunctionEntry (concatMap record_functions builtin_types) ++
		map SyntaxEntry builtin_syntax ++
		map ABCInstructionEntry builtin_abc_instructions

	printStats :: !*CloogleDB !*File -> *(*CloogleDB, *File)
	printStats db f
	# (s,db) = dbStats db
	= (db, f
		<<< "| Table             | Size  |\n"
		<<< "|-------------------|------:|\n"
		<< "Modules"           <-- s.n_modules
		<< "Functions"         <-- s.n_functions
		<< "With types"        <-- s.n_functions_with_type
		<< "Unique types"      <-- s.n_unique_types
		<< "Type tree depth"   <-- s.type_tree_depth
		<< "Type definitions"  <-- s.n_type_definitions
		<< "Classes"           <-- s.n_classes
		<< "Instances"         <-- s.n_instances
		<< "Derivations"       <-- s.n_derivations
		<< "Syntax constructs" <-- s.n_syntax_constructs
		<< "ABC instructions"  <-- s.n_abc_instructions)
	where
		(<<) infixl :: *File String -> *File
		(<<) f s = f <<< "| " <<< rpad 17 s <<< " | "

		(<--) infixl :: *File Int -> *File
		(<--) f i = f <<< lpad 5 i <<< " |\n"

		lpad n s = {' ' \\ _ <- [0..n-size (toString s)-1]} +++ toString s
		rpad n s = toString s +++ {' ' \\ _ <- [0..n-size (toString s)-1]}

module builddb

import StdArray
import StdBool
import StdFile
from StdFunc import const, flip, id, o
import StdList
import StdMisc
import StdString
import StdTuple

import Clean.Types
import Control.Monad => qualified join
import Data.Either
import Data.Error
from Data.Func import $, hyperstrict, mapSt
import Data.Functor
import Data.List
import Data.Maybe
import System.CommandLine
import System.File
import System.Options
from Text import class Text(join,startsWith), instance Text String
import Text.GenJSON

import Cloogle.DB
from Cloogle.DB.Factory import :: TemporaryDB, newTemporaryDB, finaliseDB,
	findModules, indexModule, constructor_functions, record_functions,
	:: IndexItem, :: SourceURL, :: PathPattern

import Builtin.ABC
import Builtin.Predef
import Builtin.Syntax

:: Options =
	{ root      :: !String
	, libs_file :: !String
	}

derive JSONDecode IndexItem, SourceURL, PathPattern

instance zero Options
where
	zero =
		{ root      = "/opt/clean/lib/"
		, libs_file = "libs.json"
		}

optionDescription :: Option Options
optionDescription = WithHelp True $ Options
	[ Shorthand "-r" "--root" $ Option
		"--root"
		(\dir opts -> Ok {opts & root=dir})
		"PATH"
		"Use PATH as the root directory for libraries (default: /opt/clean/lib)"
	, Shorthand "-l" "--libraries" $ Option
		"--libraries"
		(\file opts -> Ok {opts & libs_file=file})
		"FILE"
		"Use FILE for a list of libraries to index (default: libs.json)"
	]

Start :: *World -> *World
Start w
# (f, w) = stdio w
# ([prog:args], w) = getCommandLine w
# opts = parseOptions optionDescription args zero
| isError opts
	# f = f <<< join "\n" (fromError opts) <<< "\n"
	# (_,w) = fclose f w
	= w
# opts = fromOk opts
# (libsf, w) = readFile opts.libs_file w
# libsjson   = fromString $ fromOk libsf
# libs       = case libsjson of
	JSONObject groups -> sequence $ [fromJSON i \\ (_,JSONArray g) <- groups, i <- g]
	_                 -> Nothing
| isError libsf || isNothing libs
	# err = stderr <<< "Could not read " <<< opts.libs_file <<< "\n"
	# (_,w) = fclose err w
	# (_,w) = fclose f w
	= w
# libs       = fromJust libs
# (mods, w)  = mapSt (flip (findModules opts.root) "") libs w
# mods       = flatten mods
#! (db, w)   = loop opts.root mods newTemporaryDB w
#! (ok,w)    = fclose (stderr <<< "Linking database entries; this may take up to 10 minutes...\n") w
| not ok     = abort "Couldn't close stderr\n"
#! db        = finaliseDB builtins db
#! (db,err)  = printStats db stderr
#! (ok1,w)   = fclose err w
#! (db,f)    = saveDB db f
#! (ok2,w)   = fclose f w
#! (_,dbg,w) = fopen "typetree.dot" FWriteText w
#! (db,dbg)  = writeTypeTree db dbg
#! (_,w)     = fclose dbg w
= w
where
	loop :: String [ModuleEntry] !TemporaryDB !*World -> *(!TemporaryDB, !*World)
	loop _ [] db w = (db,w)
	loop root [mod:list] db w
	#! (_, w) = fclose (stderr <<< lib <<< ": " <<< modname <<< "\n") w
	#! (db, w) = indexModule False root mod db w
	#! db = hyperstrict db
	= loop root list db w
	where
		lib = fromJust (getLibrary mod.me_loc)
		modname = getName mod.me_loc

	builtins =
		map FunctionEntry builtin_functions ++
		map ClassEntry builtin_classes ++
		map TypeDefEntry builtin_types ++
		map FunctionEntry (concatMap constructor_functions builtin_types) ++
		map FunctionEntry (concatMap record_functions builtin_types) ++
		map SyntaxEntry builtin_syntax ++
		map ABCInstructionEntry builtin_abc_instructions

	printStats :: !*CloogleDB !*File -> *(*CloogleDB, *File)
	printStats db f
	# (s,db) = dbStats db
	= (db, f
		<<< "| Table             | Size  |\n"
		<<< "|-------------------|------:|\n"
		<< "Modules"           <-- s.n_modules
		<< "Functions"         <-- s.n_functions
		<< "With types"        <-- s.n_functions_with_type
		<< "Unique types"      <-- s.n_unique_types
		<< "Type tree depth"   <-- s.type_tree_depth
		<< "Type definitions"  <-- s.n_type_definitions
		<< "Classes"           <-- s.n_classes
		<< "Instances"         <-- s.n_instances
		<< "Derivations"       <-- s.n_derivations
		<< "Syntax constructs" <-- s.n_syntax_constructs
		<< "ABC instructions"  <-- s.n_abc_instructions)
	where
		(<<) infixl :: *File String -> *File
		(<<) f s = f <<< "| " <<< rpad 17 s <<< " | "

		(<--) infixl :: *File Int -> *File
		(<--) f i = f <<< lpad 5 i <<< " |\n"

		lpad n s = {' ' \\ _ <- [0..n-size (toString s)-1]} +++ toString s
		rpad n s = toString s +++ {' ' \\ _ <- [0..n-size (toString s)-1]}