Factory.icl

implementation module Cloogle.DB.Factory

import StdArray
import StdBool
import StdDebug
import StdFile
from StdFunc import const, flip, id, o
import StdList
import StdOrdList
import StdOverloadedList
import StdString
import StdTuple

import Control.Applicative
import Control.Monad
import Data.Either
import Data.Error
from Data.Func import $, mapSt, on, `on`
import Data.Functor
import Data.GenDefault
import Data.List
from Data.Map import :: Map
import qualified Data.Map as M
import Data.Maybe
from Data.NGramIndex import :: NGramIndex, newNGramIndex, index
import qualified Data.Set as S
import Data.Tuple
from Database.Native import :: NativeDB, :: Index(..), newDB,
	instance == Index, instance < Index
import qualified Database.Native as DB
import System.Directory
import System.FilePath
from Text import class Text(concat,indexOf,replaceSubString,startsWith),
	instance Text String, <+

from compile import :: DclCache{hash_table}, empty_cache
from Heap import :: Heap, newHeap, sreadPtr
from predef import init_identifiers
from syntax import :: ClassDef{class_args,class_context,class_ident,class_pos},
	:: FileName, :: FunctName, :: FunKind(FK_Macro), :: FunSpecials, :: GCF,
	:: GenericCaseDef{gc_gcf,gc_pos,gc_type}, :: GenericCaseFunctions(GCF,GCFC),
	:: GenericDef{gen_ident,gen_pos,gen_type,gen_vars},
	:: Ident{id_name,id_info}, :: LineNr, :: Module{mod_defs,mod_ident},
	:: Optional(Yes,No), :: SymbolPtr, :: Ptr, :: SymbolTableEntry,
	:: ParsedDefinition(PD_Class,PD_Derive,PD_Function,PD_Generic,PD_Instance,
		PD_Instances,PD_Type,PD_TypeSpec,PD_GenericCase,
		PD_NodeDef,PD_Import),
	:: ParsedExpr(PE_Ident,PE_List),
	:: ParsedInstance{pi_ident,pi_pos,pi_types},
	:: ParsedInstanceAndMembers{pim_pi}, :: ParsedModule, :: ParsedTypeDef,
	:: Position(FunPos,LinePos,NoPos), :: Priority, :: Rhs, :: ATypeVar,
	:: RhsDefsOfType(ConsList,ExtensibleConses,SelectorList,TypeSpec,EmptyRhs,
		AbstractTypeSpec,NewTypeCons,MoreConses),
	:: SymbolTable, :: SymbolTableEntry, :: SymbolType, :: Type, :: BITVECT,
	:: TypeContext, :: TypeDef{td_ident,td_pos,td_rhs}, :: TypeVar,
	:: ParsedConstructor{pc_cons_ident}, :: ParsedSelector{ps_selector_ident},
	:: ParsedImport, :: Import{import_module}

import Clean.PrettyPrint

from Clean.Types import instance == Type
import qualified Clean.Types as T
from Clean.Types.Tree import :: TypeTree, instance zero (TypeTree v), addType
from Clean.Types.Unify import isomorphic_to
import qualified Clean.Types.Unify as TU
from Clean.Types.Util import class print(print), instance print Type,
	instance print Priority
import Clean.Types.CoclTransform

from Clean.Doc import :: ModuleDoc, :: FunctionDoc{vars,description}, :: ClassDoc,
	:: TypeDoc{..}, :: ConstructorDoc, :: ClassMemberDoc, :: Description,
	:: ParseWarning(UsedReturn,IllegalField), :: ParseError,
	generic docBlockToDoc, parseDoc, parseSingleLineDoc, :: DocBlock,
	class docType(..), instance docType FunctionDoc,
	class docConstructors(..), instance docConstructors TypeDoc,
	class docFields(..), instance docFields TypeDoc,
	traceParseError, traceParseWarnings,
	constructorToFunctionDoc, functionToClassMemberDoc, addClassMemberDoc
import Clean.Idents
import Clean.Parse
import Clean.Parse.Comments

from Cloogle.API import :: FunctionKind(..), instance == FunctionKind
import qualified Cloogle.DB as CDB
from Cloogle.DB import
	:: CloogleDB{..}, :: AnnotationKey,
	:: Library,
	:: Location(Builtin,NoLocation),
	:: CleanLangReportLocation,
	:: CloogleEntry(..),
	:: ModuleEntry{..},
	:: FunctionEntry{..},
	:: TypeDefEntry{tde_loc,tde_instances,tde_derivations,tde_usages},
	:: ClassEntry{ce_loc,ce_instances,ce_is_meta,ce_members,ce_usages},
	classContext, :: TypeRestriction,
	:: SyntaxEntry,
	:: InstanceEntry{ie_class,ie_types,ie_locations},
	:: DeriveEntry{..},
	:: ABCInstructionEntry{..}, :: ABCArgument,
	instance zero FunctionEntry, instance zero ModuleEntry,
	class getLocation, instance getLocation CloogleEntry,
	instance == Location,
	location

:: TemporaryDB
	= { temp_functions         :: ![[('CDB'.FunctionEntry, 'S'.Set String)]]
	  , temp_classes           :: ![[('CDB'.ClassEntry, [(String, 'CDB'.FunctionEntry, 'S'.Set String)])]]
	  , temp_instances         :: ![[(!'CDB'.Name, ![(!'CDB'.Type, !String)], !'CDB'.Location)]]
	  , temp_types             :: ![['CDB'.TypeDefEntry]]
	  , temp_derivations       :: ![[(!'CDB'.Name, ![(!'CDB'.Type, !String, !'CDB'.Location)])]]
	  , temp_class_derivations :: ![[(!'CDB'.Name, !'CDB'.Type, !String, !'CDB'.Location)]]
	  , temp_modules           :: ![(ModuleEntry, 'S'.Set String)]
	  }
	  // TODO function usages in instances/derivations

newTemporaryDB :: TemporaryDB
newTemporaryDB
	= { temp_functions         = []
	  , temp_classes           = []
	  , temp_instances         = []
	  , temp_types             = []
	  , temp_derivations       = []
	  , temp_class_derivations = []
	  , temp_modules           = []
	  }

instance < (Maybe a) | < a
where
	< (Just x) (Just y) = x < y
	< (Just _) Nothing  = True
	< _        _        = False

instance < Location
where
	< ('CDB'.Location l1 m1 _ d1 i1 n1) ('CDB'.Location l2 m2 _ d2 i2 n2)
		= ((l1,m1,n1),(d1,i1)) < ((l2,m2,n2), (d2,i2))
	< ('CDB'.Location _ _ _ _ _ _) _
		= True
	< _ ('CDB'.Location _ _ _ _ _ _)
		= False
	< (Builtin a _) (Builtin b _)
		= a < b
	< (Builtin _ _) _
		= True
	< _ _
		= False

class match a :: !a !FilePath -> Bool

instance match PathPattern
where
	match (PStartsWith s) fp = startsWith s fp
	match (PNot p) fp = not (match p fp)
	match PWildcard _ = True

instance match (Maybe m) | match m
where
	match Nothing  s = False
	match (Just m) s = match m s

instance match [PathPattern] where match ps fp = any (flip match fp) ps

finaliseDB :: ![CloogleEntry] !TemporaryDB -> *'CDB'.CloogleDB
finaliseDB extra tdb =
	{ db = 'DB'.mapInPlace link $ newDB entries
	, name_ngrams = foldr (uncurry index) (newNGramIndex 3 True)
		[('CDB'.getName loc, i) \\ (i,e) <- entridxs, Just loc <- ['CDB'.getLocation e]]
	, name_map = foldr (\(name,i) -> flip 'M'.alter name \is -> case is of
			Nothing -> Just [i]
			Just is -> Just [i:is]) 'M'.newMap
		[('CDB'.getName loc, i) \\ (i,e) <- entridxs, Just loc <- ['CDB'.getLocation e]]
	, types = foldr (uncurry addType) zero
		[(snd $ 'TU'.prepare_unification False alwaysUnique synonymmap $ 'T'.removeTypeContexts t,i)
			\\ (i,FunctionEntry fe) <- entridxs, Just t <- [fe.fe_type <|> (docType =<< fe.fe_documentation)]]
	, core = coreidxs
	, apps = appidxs
	, builtins = idxfilter \e -> fromMaybe False ('CDB'.isBuiltin <$> 'CDB'.getLocation e)
	, syntax = idxfilter \e -> e=:(SyntaxEntry _)
	, abc_instrs = idxfilter \e -> e=:(ABCInstructionEntry _)
	, library_map = libmap
	, module_map = modmap
	, derive_map = 'M'.fromList
		$ map (\ds=:[(g,_):_] -> (g,map snd ds))
		$ groupBy ((==) `on` fst) $ sort
		[(de.de_generic, i) \\ (i,DeriveEntry de) <- entridxs]
	, instance_map = 'M'.fromList
		$ map (\is=:[(c,_):_] -> (c,map snd is))
		$ groupBy ((==) `on` fst) $ sort
		[(ie.ie_class, i) \\ (i,InstanceEntry ie) <- entridxs]
	, always_unique = always_unique
	}
where
	link :: !Int !CloogleEntry -> CloogleEntry
	link i e = case e of
		TypeDefEntry tde -> TypeDefEntry
			{ tde
			& tde_instances=idxfilter \e -> case e of
				InstanceEntry ie -> case name of
					"(->)" -> any (\t -> t=:('T'.Func _ _ _) || t=:('T'.Arrow _)) $ concatMap ('T'.subtypes o fst) ie.ie_types
					_      -> or [t == name \\ 'T'.Type t _ <- concatMap ('T'.subtypes o fst) ie.ie_types]
				_                -> False
			, tde_derivations=idxfilter \e -> case e of
				DeriveEntry {de_type='T'.Type t _}   -> t == name
				DeriveEntry {de_type='T'.Arrow _}    -> name == "(->)"
				DeriveEntry {de_type='T'.Func _ _ _} -> name == "(->)"
				_                                    -> False
			, tde_usages=fromMaybe [] ('M'.get name type_usages_map)
			}
			with name = 'T'.td_name $ 'CDB'.getTypeDef tde
		ClassEntry ce -> ClassEntry
			{ ce
			& ce_instances=idxfilter \e -> case e of
				InstanceEntry ie -> ie.ie_class == name
				_                -> False
			, ce_members=idxfilter \e -> case e of
				FunctionEntry fe -> fe.fe_class == Just (Index i)
				_                -> False
			, ce_usages=fromMaybe [] ('M'.get name class_usages_map)
			}
			with name = 'CDB'.getName ce.ce_loc
		FunctionEntry fe -> FunctionEntry
			{ fe
			& fe_derivations=case fe.fe_derivations of
				Nothing -> Nothing
				Just _  -> Just $ idxfilter \e -> case e of
					DeriveEntry de -> de.de_generic == name
					_              -> False
			, fe_usages=fromMaybe [] ('M'.get name function_usages_map)
			}
			with name = 'CDB'.getName fe.fe_loc
		ModuleEntry me -> ModuleEntry
			{ me
			& me_usages=fromMaybe [] ('M'.get name module_usages_map)
			}
			with name = 'CDB'.getName me.me_loc
		e -> e

	make_usage_map :: ([[(a,b)]] -> 'M'.Map a [b]) | <, == a
	make_usage_map = 'M'.fromList
		o map (\gidxs=:[(g,_):_] -> (g,map snd gidxs))
		o groupBy ((==) `on` fst)
		o sortBy ((<) `on` fst)
		o flatten

	type_usages_map = make_usage_map
		[[(t,idx) \\ 'T'.Type t _ <- 'T'.subtypes t] \\ (idx,FunctionEntry {fe_type=Just t}) <- entridxs]

	class_usages_map = make_usage_map
		[[(cls,idx) \\ 'T'.Instance cls _ <- context e] \\ (idx,e) <- entridxs]
	where
		context :: 'CDB'.CloogleEntry -> ['T'.TypeRestriction]
		context (FunctionEntry {fe_type=Just t}) = 'T'.allRestrictions t
		context (TypeDefEntry tde) = 'T'.typeRhsRestrictions $ 'T'.td_rhs $ 'CDB'.getTypeDef tde
		context (ClassEntry ce) = classContext ce
		context _ = []

	function_usages_map = make_usage_map
		[[(g,idx) \\ g <- 'S'.toList globs]
			\\ idx <- fidxs
			 & (fe,globs) <- [(fe, 'S'.newSet) \\ FunctionEntry fe <- extra] ++ function_entries]
	where fidxs = [idx \\ (idx,FunctionEntry _) <- entridxs]

	module_usages_map = make_usage_map
		[[(i,idx) \\ i <- 'S'.toList imps] \\ idx <- midxs & (_, imps) <- tdb.temp_modules]
	where midxs = [idx \\ (idx,ModuleEntry _) <- entridxs]

	function_entries = flatten tdb.temp_functions ++
		[({ fun
		& fe_kind=case fun.fe_kind of Function -> ClassMember; Macro -> ClassMacro
		, fe_loc='CDB'.setName fname cls.ce_loc
		, fe_class=Just $ idxhd \ce -> case ce of
			ClassEntry ce -> ce.ce_loc == cls.ce_loc
			_             -> False
		}, ids) \\ clss <- tdb.temp_classes, (cls,funs) <- clss, (fname,fun,ids) <- funs] ++
		[({ f
		& fe_typedef=Just $ idxhd \tde -> case tde of
			TypeDefEntry tde -> tde.tde_loc == td.tde_loc
			_                -> False
		}, 'S'.newSet) \\ tds <- tdb.temp_types, td <- tds, f <- constructor_functions td ++ record_functions td]

	entries = [e \\ Right e <- entries`]
	entries` = map Right (
		extra ++
		[TypeDefEntry tde \\ tds <- tdb.temp_types, tde <- tds] ++
		[ModuleEntry mod \\ (mod,_) <- tdb.temp_modules] ++
		map ClassEntry classes ++
		map (FunctionEntry o fst) function_entries ++
		// Normal instances
		[InstanceEntry {ie_class=cls,ie_types=types,ie_locations=map thd3 is}
			\\ is=:[(cls,types,_):_] <- groupBy instanceEq
				$ sortBy ((<) `on` (\(c,ts,_) -> (c,map snd ts)))
				$ flatten tdb.temp_instances] ++
		// Derivations
		[DeriveEntry {de_generic=gn, de_type=t, de_type_representation=tr, de_locations=map fth4 ds}
			\\ ds=:[(gn,t,tr,_):_] <- groupBy ((==) `on` (\(g,_,tr,_) -> (g,tr)))
				$ sortBy ((<) `on` (\(g,_,tr,_) -> (g,tr)))
				[(g,t,tr,l) \\ ds <- tdb.temp_derivations, (g,ts) <- ds, (t,tr,l) <- ts]] ++
		[InstanceEntry {ie_class=gn, ie_types=[(t,tr)], ie_locations=map fth4 ds}
			\\ ds=:[(gn,t,tr,_):_] <- groupBy ((==) `on` (\(g,_,tr,_) -> (g,tr)))
				$ sortBy ((<) `on` (\(g,_,tr,_) -> (g,tr)))
				$ flatten tdb.temp_class_derivations]) ++
		// Meta-class instances
		concatMap metainstances classes
	where
		metainstances :: ClassEntry -> [Either String CloogleEntry]
		metainstances {ce_is_meta=False} = []
		metainstances ce = [Left cls:[Right $ InstanceEntry {ie_class=cls,ie_types=[(t,tr)],ie_locations=locs} \\ (t,tr,locs) <- types`]]
		where
			crestrs = [c \\ 'T'.Instance c ['T'.Var _] <- classContext ce | c <> "TC"] // TC class is implicit
			grestrs = [g \\ 'T'.Derivation g ('T'.Var _) <- classContext ce]
			ctypes = [[(hd ie.ie_types,ie.ie_locations) \\ InstanceEntry ie <- entries | ie.ie_class == c && length ie.ie_types == 1] \\ c <- crestrs]
			gtypes = [[((de.de_type,de.de_type_representation),de.de_locations) \\ DeriveEntry de <- entries | de.de_generic == g] \\ g <- grestrs]
			types = case ctypes ++ gtypes of
				[] -> []
				ts -> foldr1 intersect $ map (map fst) ts
			types` = [(t,tr,flatten [locs \\ rts <- ctypes ++ gtypes, ((t`,_),locs) <- rts | t == t`]) \\ (t,tr) <- types]
			cls = 'CDB'.getName ce.ce_loc

			// Ideally we would use entries, but that causes a cycle in spine.
			// So we use entries up to the point where the class itself is defined.
			// This requires keeping an Either where Left holds the class under evaluation.
			// It also requires sorting the classes, see below with contextOrd.
			entries = [e \\ Right e <- takeWhile (\e -> case e of
				Left c  -> c <> cls
				Right _ -> True) entries`]

		classes = sortBy contextOrd [cls \\ clss <- tdb.temp_classes, (cls,_) <- clss]
		where
			contextOrd :: ClassEntry ClassEntry -> Bool
			contextOrd a b = isMember aname [c \\ 'T'.Instance c _ <- classContext b]
			where [aname,bname:_] = map 'CDB'.getName [a.ce_loc,b.ce_loc]

		instanceEq :: (String, [('CDB'.Type, a)], b) (String, [('CDB'.Type, a)], b) -> Bool
		instanceEq (s, ts, _) (s2, ts2, _) = s == s2 && all (uncurry (isomorphic_to)) (zip2 (map fst ts) (map fst ts2))

	entridxs = zip2 [Index i \\ i <- [0..]] entries
	idxfilter f = [idx \\ (idx,e) <- entridxs | f e]
	idxhd = hd o idxfilter

	coreidxs = idxfilter \e -> case 'CDB'.getLocation e of
		Nothing -> False
		Just l -> case ('CDB'.getLibrary l, 'CDB'.getModule l) of
			(Just l, Just m) -> isMember (l,m) coremods
			_                -> False
	where
		coremods = [(fromJust $ 'CDB'.getLibrary me.me_loc, fromJust $ 'CDB'.getModule me.me_loc) \\ (me,_) <- tdb.temp_modules | me.me_is_core]
	appidxs = idxfilter \e -> case 'CDB'.getLocation e of
		Nothing -> False
		Just l -> case ('CDB'.getLibrary l, 'CDB'.getModule l) of
			(Just l, Just m) -> isMember (l,m) appmods
			_                -> False
	where
		appmods = [(fromJust $ 'CDB'.getLibrary me.me_loc, fromJust $ 'CDB'.getModule me.me_loc) \\ (me,_) <- tdb.temp_modules | me.me_is_app]

	libmap = 'M'.fromList
		[(l,idxfilter \e -> case 'CDB'.getLocation e >>= 'CDB'.getLibrary of
			Nothing -> False
			Just l` -> l == l`) \\ l <- libs]
	where libs = removeDup [fromJust ('CDB'.getLibrary me.me_loc) \\ (me,_) <- tdb.temp_modules]
	modmap = 'M'.fromList
		[(m,idxfilter \e -> case 'CDB'.getLocation e >>= 'CDB'.getModule of
			Nothing -> False
			Just m` -> m == m`) \\ m <- mods]
	where mods = removeDup [fromJust ('CDB'.getModule me.me_loc) \\ (me,_) <- tdb.temp_modules]

	synonymmap = 'M'.fromList
		$ map (\syns=:[(t,_):_] -> (t,map snd syns))
		$ groupBy ((==) `on` fst)
		$ sortBy ((<) `on` fst)
		[let td = 'CDB'.getTypeDef tde in ('T'.td_name td, td)
			\\ TypeDefEntry tde <- entries
			| ('T'.td_rhs ('CDB'.getTypeDef tde))=:('T'.TDRSynonym _)]

	always_unique = 'M'.fromList
		[('T'.td_name $ 'CDB'.getTypeDef tde, ()) \\ TypeDefEntry tde <- entries | 'T'.td_uniq $ 'CDB'.getTypeDef tde]
	alwaysUnique = isJust o flip 'M'.get always_unique

findModules :: !String !IndexItem !String !*World -> *(!['CDB'.ModuleEntry], !*World)
findModules root item base w
| match item.pattern_exclude path = ([], w)
#! (fps, w)   = readDirectory fullpath w
| isError fps = ([], w)
#! (Ok fps)   = fps
#! mods       = [makeEntry fn (isMember (replaceSubString ".icl" ".dcl" fn) fps) \\ fn <- fps | isIclModule fn && included fn]
#! (moremodss,w) = mapSt (findModules root item o ((+++) basedot)) (filter isDirectory fps) w
= (removeDupBy (\m -> 'CDB'.getName m.me_loc) (mods ++ flatten moremodss), w)
where
	basedot = if (base == "") "" (base +++ ".")
	path = replaceSubString "." {pathSeparator} base
	fullpath = root </?> item.IndexItem.name </?> path

	(</?>) infixr 5 :: !FilePath !FilePath -> FilePath
	(</?>) "" p  = p
	(</?>) p  "" = p
	(</?>) p1 p2 = p1 </> p2

	makeEntry :: !String !Bool -> 'CDB'.ModuleEntry
	makeEntry fn has_dcl =
		{ me_loc           = location item.IndexItem.name modname (path </?> fn) (if has_dcl (Just 1) Nothing) (Just 1) modname
		, me_is_core       = match item.pattern_core (path </?> fn)
		, me_is_app        = match item.pattern_app  (path </?> fn)
		, me_documentation = Nothing
		, me_usages        = []
		}
	where
		modname = basedot +++ fn % (0, size fn - 5)

	included :: String -> Bool
	included s = not (match item.pattern_exclude (path </?> s))

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

	isDirectory :: (String -> Bool)
	isDirectory = not o isMember '.' o fromString

	removeDupBy :: (a -> b) [a] -> [a] | Eq b
	removeDupBy f [x:xs] = [x:removeDupBy f (filter ((<>) (f x) o f) xs)]
	removeDupBy _ []     = []

indexModule :: !Bool !String !'CDB'.ModuleEntry !TemporaryDB !*World
	-> *(!TemporaryDB, !*World)
indexModule include_locals root mod db w
#! (functions,macros,generics,typedefs,clss,insts,derivs,clsderivs,(modname,mod`,imports),w)
	= findModuleContents include_locals (root </> lib </> mkdir ('CDB'.getName mod.me_loc)) w
#! typedefs = [{td & tde_loc=castLoc modname loc} \\ (loc,td) <- typedefs]
#! db  =
	{ db
	& temp_functions =
		[ [({f & fe_loc=castLoc modname loc},idents) \\ (loc,f,idents) <- functions ++ macros ++ generics]
		: db.temp_functions
		]
	, temp_classes = [[({ce & ce_loc=castLoc modname loc}, fs) \\ (loc,ce,fs) <- clss]:db.temp_classes]
	, temp_types = [typedefs:db.temp_types]
	, temp_instances = [castLocThd3 modname insts:db.temp_instances]
	, temp_derivations = [map (appSnd (castLocThd3 modname)) derivs:db.temp_derivations]
	, temp_class_derivations = [castLocFrth modname clsderivs:db.temp_class_derivations]
	, temp_modules = [({mod & me_loc='CDB'.setModule modname ('CDB'.setName modname mod.me_loc), me_documentation=mod`.me_documentation},imports):db.temp_modules]
	}
= (db,w)
where
	lib = fromJust ('CDB'.getLibrary mod.me_loc)

	castLocThd3 :: String -> ([(a, b, LocationInModule)] -> [(a, b, 'CDB'.Location)])
	castLocThd3 m = map (appThd3 (castLoc m))
	castLocFrth m = map (\(a,b,c,l) -> (a,b,c,castLoc m l))

	castLoc :: String LocationInModule -> 'CDB'.Location
	castLoc m l = location lib m iclpath l.dcl_line l.icl_line $ fromMaybe "" l.LocationInModule.name
	iclpath = mkdir ('CDB'.getName mod.me_loc) +++ ".icl"

	mkdir :: String -> String
	mkdir s = { if (c == '.') '/' c \\ c <-: s }

instance zero LocationInModule
where zero = {dcl_line=Nothing, icl_line=Nothing, name=Nothing}

findModuleContents :: !Bool !String !*World
	-> *( ![(LocationInModule, 'CDB'.FunctionEntry, 'S'.Set String)]
	    , ![(LocationInModule, 'CDB'.FunctionEntry, 'S'.Set String)]
	    , ![(LocationInModule, 'CDB'.FunctionEntry, 'S'.Set String)]
	    , ![(LocationInModule, 'CDB'.TypeDefEntry)]
	    , ![(LocationInModule, 'CDB'.ClassEntry, [(String, 'CDB'.FunctionEntry, 'S'.Set String)])]
	    , ![('CDB'.Name, [('CDB'.Type, String)], LocationInModule)]
	    , ![('CDB'.Name, [('CDB'.Type, String, LocationInModule)])]
	    , ![('CDB'.Name, 'CDB'.Type, String, LocationInModule)]
	    , !('CDB'.Name, 'CDB'.ModuleEntry, 'S'.Set String)
	    , !*World
	    )
findModuleContents include_locals path w
#! (dclcomments,w) = scanComments (path +++ ".dcl") w
#! (dcl,w) = readModule (path +++ ".dcl") w
#! (dclmod,dcl,documentation) = case dcl of
	Error _ -> (zero, [], emptyCollectedComments)
	Ok (dcl,_) -> case dclcomments of
		Error _ -> (zero, dcl.mod_defs, emptyCollectedComments)
		Ok comments -> let coll = collectComments comments dcl in
			( {zero & me_documentation=docParseResultToMaybe (const True) =<< parseDoc <$> getComment dcl.mod_ident coll}
			, dcl.mod_defs
			, coll
			)
#! (icl,w) = readModule (path +++ ".icl") w
#! (icl,modname) = case icl of
	Error _ -> ([], "")
	Ok (icl,syms) -> (icl.mod_defs, icl.mod_ident.id_name)
#! imports = 'S'.fromList [i.import_module.id_name \\ PD_Import is <- dcl ++ icl, i <- is]
#! contents=:(functions,rules,generics,typedefs,clss,insts,derivs,clsderivs) =
	( combine cmpLocFst3  joinLocFstIds pd_typespecs    dcl documentation icl
	, combine cmpLocFst3  joinLocFstIds pd_rewriterules dcl documentation icl
	, combine cmpLocFst3  joinLocFstIds pd_generics     dcl documentation icl
	, combine cmpLocFst   joinTypeDefs  pd_types        dcl documentation icl
	, combine cmpLocFst3  joinLocFst3   pd_classes      dcl documentation icl
	, combine cmpInsts    joinInsts     pd_instances    dcl documentation icl
	, combineDerivs (pd_derivations True dcl) (pd_derivations False icl)
	, combine cmpClsDeriv joinClsDeriv pd_class_derivations dcl documentation icl
	)
#! (functions,rules,generics,typedefs,clss,insts,derivs,clsderivs) =
	if include_locals
	contents
	( filter (hasDcl o fst3)            functions
	, filter (hasDcl o fst3)            rules
	, filter (hasDcl o fst3)            generics
	, filter (hasDcl o fst)             typedefs
	, filter (hasDcl o fst3)            clss
	, filter (hasDcl o thd3)            insts
	, filter (not o isEmpty o snd) (map (appSnd (filter (hasDcl o thd3))) derivs)
	, filter (hasDcl o (\(_,_,_,x)->x)) clsderivs
	) with hasDcl loc = isJust loc.dcl_line
#! rules = filter (\(r,_,_) -> not $ any (\(l,_,_)->fromJust l.LocationInModule.name == fromJust r.LocationInModule.name) functions) rules
= (functions,rules,generics,typedefs,clss,insts,derivs,clsderivs,(modname,dclmod,imports),w)
where
	combine :: (a a -> Bool) (a a -> a)
		(Bool [ParsedDefinition] CollectedComments -> [a])
		![ParsedDefinition] !CollectedComments
		![ParsedDefinition]
		-> [a]
	combine eq join find dcl dclsym [] // Special case for things like _library.dcl
		= find True dcl dclsym
	combine eq join find dcl dclsym icl
		= unionBy eq join (find True dcl dclsym) (find False icl emptyCollectedComments)

	unionBy :: (a a -> Bool) (a a -> a) [a] [a] -> [a]
	unionBy eq join xs []     = xs
	unionBy eq join xs [y:ys] = case partition (eq y) xs of
		([],   xs) -> [y:unionBy eq join xs  ys]
		(found,xs) -> let (foundys,ys`) = partition (eq y) ys in
			[foldr join y (found ++ foundys):unionBy eq join xs ys`]

	cmpLoc x y = x.LocationInModule.name == y.LocationInModule.name

	cmpLocFst :: ((LocationInModule, a) (LocationInModule, a) -> Bool)
	cmpLocFst = cmpLoc `on` fst

	cmpLocFst3 :: ((LocationInModule, a, b) (LocationInModule, a, b) -> Bool)
	cmpLocFst3 = cmpLoc `on` fst3

	joinLocFst :: (LocationInModule, a) (LocationInModule, b) -> (LocationInModule, a)
	joinLocFst (l1,a) (l2,_) = (joinLoc l1 l2, a)

	joinLocFst3 :: (LocationInModule, a, b) (LocationInModule, c, d) -> (LocationInModule, a, b)
	joinLocFst3 (l1,a,b) (l2,_,_) = (joinLoc l1 l2, a, b)

	joinLocFstIds :: (LocationInModule, a, 'S'.Set String) (LocationInModule, b, 'S'.Set String) -> (LocationInModule, a, 'S'.Set String)
	joinLocFstIds (l1,a,idsa) (l2,_,idsb) = (joinLoc l1 l2, a, 'S'.union idsa idsb)

	joinTypeDefs :: (LocationInModule, 'CDB'.TypeDefEntry) (LocationInModule, 'CDB'.TypeDefEntry) -> (LocationInModule, 'CDB'.TypeDefEntry)
	joinTypeDefs (a,t) (b,u) = (joinLoc a b, 'CDB'.mergeTypeDefEntries t u)

	cmpInsts :: (a, b, LocationInModule) (a, b, LocationInModule) -> Bool | == a & == b
	cmpInsts (ca, tsa, _) (cb, tsb, _) = ca == cb && tsa == tsb
	joinInsts (c,ts,la) (_,_,lb) = (c,ts,joinLoc la lb)

	combineDerivs ::
		([('CDB'.Name, [('CDB'.Type, String, LocationInModule)])]
		 [('CDB'.Name, [('CDB'.Type, String, LocationInModule)])]
		 -> [('CDB'.Name, [('CDB'.Type, String, LocationInModule)])])
	combineDerivs = unionBy (on (==) fst) (\(n,ts) (_,us) -> (n,combineTypes ts us))
	where
		combineTypes = unionBy (on (==) fst3) (\(t,s,la) (_,_,lb) -> (t,s,joinLoc la lb))

	cmpClsDeriv :: (a, b, c, LocationInModule) (a, b, c, LocationInModule) -> Bool | == a & == b
	cmpClsDeriv (ca,ta,_,_) (cb,tb,_,_) = ca == cb && ta == tb
	joinClsDeriv (c,t,s,la) (_,_,_,lb) = (c,t,s,joinLoc la lb)

	joinLoc :: LocationInModule LocationInModule -> LocationInModule
	joinLoc a b =
		{ dcl_line = a.dcl_line              <|> b.dcl_line
		, icl_line = a.icl_line              <|> b.icl_line
		, name     = a.LocationInModule.name <|> b.LocationInModule.name
		}

	pd_rewriterules :: !Bool ![ParsedDefinition] !CollectedComments -> [(LocationInModule, 'CDB'.FunctionEntry, 'S'.Set String)]
	pd_rewriterules dcl defs comments
		= [( setLine dcl pos {LocationInModule | zero & name=Just id.id_name}
		   , let doc = findDoc hideIsUsedReturn id comments in
		     trace_type_warning id
		     { zero
		     & fe_kind=Macro
		     , fe_type=(docType =<< doc) <|> pdType pd
		     , fe_representation=Just $ priostring id pd +++ cpp pd
		     , fe_priority=findPrio id >>= 'T'.toMaybePriority
		     , fe_documentation=doc
		     }
		   , (idents ICExpression pd).globals
		   ) \\ pd=:(PD_Function pos id isinfix args rhs _) <- defs]
	where
		priostring :: Ident ParsedDefinition -> String
		priostring id pd = case findTypeSpec id defs of
			Just td -> cpp td +++ "\n"
			Nothing -> case pdType pd of
				Just t  -> id.id_name +++ " :: " +++ concat (print False t) +++ "\n"
				Nothing -> ""

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

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

		trace_type_warning :: !Ident !FunctionEntry -> FunctionEntry
		trace_type_warning id fe
		| isJust (findTypeSpec id defs) = fe
		| isJust fe.fe_type             = fe
		| otherwise                     = trace_n ("Doc warning: expected @type for '" +++ id.id_name +++ "'") fe

	pd_derivations :: !Bool ![ParsedDefinition] -> [('CDB'.Name, [('CDB'.Type, String, LocationInModule)])]
	pd_derivations dcl defs
		= [( id.id_name, [('T'.toType gc_type, cpp gc_type, setLine dcl gc_pos zero)])
			\\ gcdefs <- [ds \\ PD_Derive ds <- defs] ++ [[d] \\ PD_GenericCase d _ <- defs]
			, {gc_type,gc_pos,gc_gcf=GCF id _} <- gcdefs]

	pd_generics :: !Bool ![ParsedDefinition] !CollectedComments -> [(LocationInModule, 'CDB'.FunctionEntry, 'S'.Set String)]
	pd_generics dcl defs comments
		= [( setLine dcl gen_pos {LocationInModule | zero & name=Just id_name}
		   , { zero
		     & fe_type=Just $ 'T'.toType gen_type
		     , fe_generic_vars=Just $ map 'T'.toTypeVar gen_vars
		     , fe_representation=Just $ cpp gen
		     , fe_documentation=findDoc hideIsUsedReturn id comments
		     , fe_derivations=Just []
		     }
		   , 'S'.newSet
		   ) \\ gen=:(PD_Generic {gen_ident=id=:{id_name},gen_pos,gen_type,gen_vars}) <- defs]

	pd_typespecs :: !Bool ![ParsedDefinition] !CollectedComments -> [(LocationInModule, 'CDB'.FunctionEntry, 'S'.Set String)]
	pd_typespecs dcl defs comments
		= [( setLine dcl pos {LocationInModule | zero & name=Just id_name}
		   , { zero
		     & fe_type=Just $ 'T'.toType t
		     , fe_priority = 'T'.toMaybePriority p
		     , fe_representation = Just $ cpp ts
		     , fe_documentation = findDoc hideIsUsedReturn id comments
		     }
		   , (idents ICExpression [pd \\ pd=:(PD_Function _ id _ _ _ _) <- defs | id.id_name == id_name]).globals
		   ) \\ ts=:(PD_TypeSpec pos id=:{id_name} p (Yes t) funspecs) <- defs]

	pd_class_derivations :: !Bool ![ParsedDefinition] CollectedComments -> [('CDB'.Name, 'CDB'.Type, String, LocationInModule)]
	pd_class_derivations dcl defs _
		= [(id.id_name, 'T'.toType gc_type, cpp gc_type, setLine dcl gc_pos zero)
			\\ PD_Derive gcdefs <- defs, {gc_type,gc_pos,gc_gcf=GCFC id _} <- gcdefs]

	pd_instances :: !Bool ![ParsedDefinition] CollectedComments -> [('CDB'.Name, [('CDB'.Type, String)], LocationInModule)]
	pd_instances dcl defs _
		= [(id, types, setLine dcl pos zero) \\ (id,types,pos) <- instances]
	where
		instances = map (appSnd3 (map (\t -> ('T'.toType t, cppp t)))) $
			[(i.pi_ident.id_name, i.pi_types, i.pi_pos) \\ PD_Instance {pim_pi=i} <- defs]
			++ [(i.pi_ident.id_name, i.pi_types, i.pi_pos) \\ PD_Instances pis <- defs, {pim_pi=i} <- pis]

	pd_classes :: !Bool ![ParsedDefinition] !CollectedComments -> [(LocationInModule, 'CDB'.ClassEntry, [(String, 'CDB'.FunctionEntry, 'S'.Set String)])]
	pd_classes dcl defs comments
		= [ let
		      typespecs = pd_typespecs True clsdefs comments
		      macros = [(n,(r,ids)) \\ ({LocationInModule | name=Just n},{fe_representation=Just r},ids) <- pd_rewriterules dcl clsdefs comments]
		      updateRepresentation n fe
		        = { fe
		          & fe_kind=if (isNothing $ lookup n macros) fe.fe_kind Macro
		          , fe_representation=(fst <$> lookup n macros) <|> fe.fe_representation
		          , fe_documentation=if (isSingleFunction typespecs id)
		              ((\d -> {FunctionDoc | d & vars=[]}) <$> findDoc hideIsUsedReturn id comments)
		              fe.fe_documentation
		          }
		      members = [(f,updateRepresentation f et,ids) \\ ({LocationInModule | name=Just f}, et, ids) <- typespecs]
		    in ( setLine dcl class_pos {LocationInModule | zero & name=Just id_name}
		       , 'CDB'.toClass
		         NoLocation
		         (map 'T'.toTypeVar class_args)
		         (all (\(_,fe,_) -> fe.fe_kind == Macro) members)
		         (flatten $ map 'T'.toTypeContext class_context)
		         (parseClassDoc typespecs id comments)
		       , members
		       )
		  \\ PD_Class {class_ident=id=:{id_name},class_pos,class_args,class_context} clsdefs <- defs
		  ]
	where
		// When the class has one member with the same name as the class, use
		// the class documentation as the function's documentation. This is the
		// case for classes like `class zero a :: a`, which do not have a where
		// clause and hence no other place for the function's documentation.
		parseClassDoc :: [(LocationInModule, 'CDB'.FunctionEntry, a)] Ident !CollectedComments -> Maybe ClassDoc
		parseClassDoc members id comments
		| isSingleFunction members id = flip addClassMemberDoc
			(functionToClassMemberDoc <$> findDoc hideIsUsedReturn id comments)
			<$> findDoc hideFunctionOnClass id comments
		| otherwise = flip (foldl addClassMemberDoc)
			[functionToClassMemberDoc <$> fe.fe_documentation \\ (_,fe,_) <- members]
			<$> findDoc hideIsUsedReturn id comments

		isSingleFunction :: [(LocationInModule, 'CDB'.FunctionEntry, a)] Ident -> Bool
		isSingleFunction members id = length members == 1
			&& fromJust (fst3 $ hd members).LocationInModule.name == id.id_name

		// Hide warnings about @result and @param on single function classes
		hideFunctionOnClass (IllegalField "param")  = False
		hideFunctionOnClass (IllegalField "result") = False
		hideFunctionOnClass w                       = hideIsUsedReturn w

	pd_types :: !Bool ![ParsedDefinition] !CollectedComments -> [(LocationInModule, 'CDB'.TypeDefEntry)]
	pd_types dcl defs comments
		= [let name = 'T'.td_name td in
			( setLine dcl ptd.td_pos {LocationInModule | zero & name=Just name}
			, 'CDB'.toTypeDefEntry NoLocation td $ Just $ findRhsDoc ptd $ fromMaybe gDefault{|*|} $
				findDoc (const True) ptd.td_ident comments
			) \\ PD_Type ptd <- defs, td <- ['T'.toTypeDef ptd]]
	where
		findRhsDoc :: !ParsedTypeDef -> TypeDoc -> TypeDoc
		findRhsDoc {td_rhs=ConsList cs}           = addConses cs
		findRhsDoc {td_rhs=ExtensibleConses cs}   = addConses cs
		findRhsDoc {td_rhs=SelectorList _ _ _ fs} = addFields fs
		findRhsDoc _                              = id

		addFields :: ![ParsedSelector] !TypeDoc -> TypeDoc
		addFields [] doc = doc
		addFields [ps:fs] doc = {doc` & fields=Just [d:fromMaybe [] doc`.fields]}
		where
			doc` = addFields fs doc
			d = parseSingleLineDoc <$> getComment ps.ps_selector_ident comments

		addConses :: ![ParsedConstructor] !TypeDoc -> TypeDoc
		addConses [] doc
			= {doc & constructors=Just []}
		addConses [pc:cs] doc = {doc` & constructors=Just [d:fromMaybe [] doc`.constructors]}
		where
			doc` = addConses cs doc
			d = docParseResultToMaybe (const True) =<< parseDoc <$> getComment pc.pc_cons_ident comments

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

	docParseResultToMaybe :: (ParseWarning -> Bool)
		(Either ParseError (d, [ParseWarning])) -> Maybe d
	docParseResultToMaybe showw (Left e)
		= traceParseError e Nothing
	docParseResultToMaybe showw (Right (doc,ws))
		= traceParseWarnings (filter showw ws) (Just doc)

	hideIsUsedReturn :: ParseWarning -> Bool
	hideIsUsedReturn w = not $ isUsedReturn w