Factory.icl 34.3 KB
Newer Older
1
implementation module Cloogle.DB.Factory
2 3 4

import StdArray
import StdBool
5
import StdDebug
6
import StdFile
7
from StdFunc import const, flip, id, o
8
import StdList
Camil Staps's avatar
Camil Staps committed
9
import StdOrdList
10
import StdOverloadedList
11 12 13 14 15 16 17
import StdString
import StdTuple

import Control.Applicative
import Control.Monad
import Data.Either
import Data.Error
18
from Data.Func import $, mapSt, on, `on`
19
import Data.Functor
Camil Staps's avatar
Camil Staps committed
20
import Data.GenDefault
21
import Data.List
22 23
from Data.Map import :: Map
import qualified Data.Map as M
24
import Data.Maybe
25
from Data.NGramIndex import :: NGramIndex, newNGramIndex, index
Camil Staps's avatar
Camil Staps committed
26
import qualified Data.Set as S
27
import Data.Tuple
28 29 30
from Database.Native import :: NativeDB, :: Index(..), newDB,
	instance == Index, instance < Index
import qualified Database.Native as DB
31
import System.Directory
Camil Staps's avatar
Camil Staps committed
32
import System.FilePath
Camil Staps's avatar
Camil Staps committed
33 34
from Text import class Text(concat,indexOf,replaceSubString,startsWith),
	instance Text String, <+
35 36

from compile import :: DclCache{hash_table}, empty_cache
Camil Staps's avatar
Camil Staps committed
37
from hashtable import :: BoxedIdent{boxed_ident}, :: HashTable{hte_symbol_heap},
38
	:: IdentClass(IC_Module), :: QualifiedIdents(NoQualifiedIdents),
Camil Staps's avatar
Camil Staps committed
39 40
	putIdentInHashTable, set_hte_mark, newHashTable
from Heap import :: Heap, newHeap, sreadPtr
41 42 43 44
from parse import wantModule
from predef import init_identifiers
from syntax import :: ClassDef{class_args,class_context,class_ident,class_pos},
	:: FileName, :: FunctName, :: FunKind(FK_Macro), :: FunSpecials, :: GCF,
45
	:: GenericCaseDef{gc_gcf,gc_pos,gc_type}, :: GenericCaseFunctions(GCF,GCFC),
Camil Staps's avatar
Camil Staps committed
46 47 48
	:: 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{ste_doc},
Camil Staps's avatar
Camil Staps committed
49
	:: ParsedDefinition(PD_Class,PD_Derive,PD_Function,PD_Generic,PD_Instance,
50
		PD_Instances,PD_Type,PD_TypeSpec,PD_Documentation,PD_GenericCase,
51
		PD_NodeDef,PD_Import),
52 53
	:: ParsedExpr(PE_Ident,PE_List),
	:: ParsedInstance{pi_ident,pi_pos,pi_types},
54
	:: ParsedInstanceAndMembers{pim_pi}, :: ParsedModule, :: ParsedTypeDef,
55
	:: Position(FunPos,LinePos,NoPos), :: Priority, :: Rhs, :: ATypeVar,
56
	:: RhsDefsOfType(ConsList,ExtensibleConses,SelectorList,TypeSpec,EmptyRhs,
57
		AbstractTypeSpec,NewTypeCons,MoreConses),
58 59
	:: SymbolTable, :: SymbolTableEntry, :: SymbolType, :: Type, :: BITVECT,
	:: TypeContext, :: TypeDef{td_ident,td_pos,td_rhs}, :: TypeVar,
60 61 62
	:: ParsedConstructor{pc_doc}, :: ParsedSelector{ps_doc},
	:: ParsedImport, :: Import{import_module},
	:: DocType, :: OptionalDoc
63

64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88
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

from Cloogle.API import :: FunctionKind(..), instance == FunctionKind
import qualified Cloogle.DB as CDB
from Cloogle.DB import
Camil Staps's avatar
Camil Staps committed
89
	:: CloogleDB{..}, :: AnnotationKey,
Camil Staps's avatar
Camil Staps committed
90 91
	:: Library,
	:: Location(Builtin,NoLocation),
Camil Staps's avatar
Camil Staps committed
92
	:: CleanLangReportLocation,
93
	:: CloogleEntry(..),
94
	:: ModuleEntry{..},
95
	:: FunctionEntry{..},
96
	:: TypeDefEntry{tde_loc,tde_instances,tde_derivations,tde_usages},
Camil Staps's avatar
Camil Staps committed
97
	:: ClassEntry{ce_loc,ce_instances,ce_is_meta,ce_members,ce_usages},
Camil Staps's avatar
Camil Staps committed
98
	classContext, :: TypeRestriction,
Camil Staps's avatar
Camil Staps committed
99
	:: SyntaxEntry,
Camil Staps's avatar
Camil Staps committed
100
	:: InstanceEntry{ie_class,ie_types,ie_locations},
101
	:: DeriveEntry{..},
Camil Staps's avatar
Camil Staps committed
102
	:: ABCInstructionEntry{..}, :: ABCArgument,
103
	instance zero FunctionEntry, instance zero ModuleEntry,
104
	class getLocation, instance getLocation CloogleEntry,
Camil Staps's avatar
Camil Staps committed
105 106
	instance == Location,
	location
107

108
:: TemporaryDB
Camil Staps's avatar
Camil Staps committed
109 110
	= { temp_functions         :: ![[('CDB'.FunctionEntry, 'S'.Set String)]]
	  , temp_classes           :: ![[('CDB'.ClassEntry, [(String, 'CDB'.FunctionEntry, 'S'.Set String)])]]
111 112 113 114
	  , 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)]]
Camil Staps's avatar
Camil Staps committed
115
	  , temp_modules           :: ![(ModuleEntry, 'S'.Set String)]
116
	  }
117
	  // TODO function usages in instances/derivations
118

119 120
newTemporaryDB :: TemporaryDB
newTemporaryDB
121 122 123 124 125 126 127
	= { temp_functions         = []
	  , temp_classes           = []
	  , temp_instances         = []
	  , temp_types             = []
	  , temp_derivations       = []
	  , temp_class_derivations = []
	  , temp_modules           = []
128 129
	  }

Camil Staps's avatar
Camil Staps committed
130 131 132 133 134 135 136 137
instance < (Maybe a) | < a
where
	< (Just x) (Just y) = x < y
	< (Just _) Nothing  = True
	< _        _        = False

instance < Location
where
Camil Staps's avatar
Camil Staps committed
138
	< ('CDB'.Location l1 m1 _ d1 i1 n1) ('CDB'.Location l2 m2 _ d2 i2 n2)
Camil Staps's avatar
Camil Staps committed
139
		= ((l1,m1,n1),(d1,i1)) < ((l2,m2,n2), (d2,i2))
Camil Staps's avatar
Camil Staps committed
140
	< ('CDB'.Location _ _ _ _ _ _) _
Camil Staps's avatar
Camil Staps committed
141
		= True
Camil Staps's avatar
Camil Staps committed
142
	< _ ('CDB'.Location _ _ _ _ _ _)
Camil Staps's avatar
Camil Staps committed
143 144 145 146 147 148 149 150
		= False
	< (Builtin a _) (Builtin b _)
		= a < b
	< (Builtin _ _) _
		= True
	< _ _
		= False

Camil Staps's avatar
Camil Staps committed
151 152 153 154 155 156 157 158 159 160 161 162 163 164 165
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

166 167
finaliseDB :: ![CloogleEntry] !TemporaryDB -> *'CDB'.CloogleDB
finaliseDB extra tdb =
Camil Staps's avatar
Camil Staps committed
168
	{ db = 'DB'.mapInPlace link $ newDB entries
Camil Staps's avatar
Camil Staps committed
169 170
	, name_ngrams = foldr (uncurry index) (newNGramIndex 3 True)
		[('CDB'.getName loc, i) \\ (i,e) <- entridxs, Just loc <- ['CDB'.getLocation e]]
171 172 173 174
	, 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]]
Camil Staps's avatar
Camil Staps committed
175
	, types = foldr (uncurry addType) zero
176
		[(snd $ 'TU'.prepare_unification False alwaysUnique synonymmap $ 'T'.removeTypeContexts t,i)
Camil Staps's avatar
Camil Staps committed
177
			\\ (i,FunctionEntry fe) <- entridxs, Just t <- [fe.fe_type <|> (docType =<< fe.fe_documentation)]]
Camil Staps's avatar
Camil Staps committed
178 179
	, core = coreidxs
	, apps = appidxs
Camil Staps's avatar
Camil Staps committed
180
	, builtins = idxfilter \e -> fromMaybe False ('CDB'.isBuiltin <$> 'CDB'.getLocation e)
Camil Staps's avatar
Camil Staps committed
181
	, syntax = idxfilter \e -> e=:(SyntaxEntry _)
Camil Staps's avatar
Camil Staps committed
182
	, abc_instrs = idxfilter \e -> e=:(ABCInstructionEntry _)
183 184
	, library_map = libmap
	, module_map = modmap
Camil Staps's avatar
Camil Staps committed
185 186 187 188 189 190 191 192
	, 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]
193
	, always_unique = always_unique
Camil Staps's avatar
Camil Staps committed
194
	}
195
where
Camil Staps's avatar
Camil Staps committed
196
	link :: !Int !CloogleEntry -> CloogleEntry
197
	link i e = case e of
Camil Staps's avatar
Camil Staps committed
198
		TypeDefEntry tde -> TypeDefEntry
199 200
			{ tde
			& tde_instances=idxfilter \e -> case e of
201 202 203
				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]
204 205
				_                -> False
			, tde_derivations=idxfilter \e -> case e of
206 207 208 209
				DeriveEntry {de_type='T'.Type t _}   -> t == name
				DeriveEntry {de_type='T'.Arrow _}    -> name == "(->)"
				DeriveEntry {de_type='T'.Func _ _ _} -> name == "(->)"
				_                                    -> False
210
			, tde_usages=fromMaybe [] ('M'.get name type_usages_map)
211
			}
212
			with name = 'T'.td_name $ 'CDB'.getTypeDef tde
Camil Staps's avatar
Camil Staps committed
213
		ClassEntry ce -> ClassEntry
214 215
			{ ce
			& ce_instances=idxfilter \e -> case e of
Camil Staps's avatar
Camil Staps committed
216
				InstanceEntry ie -> ie.ie_class == name
217
				_                -> False
Camil Staps's avatar
Camil Staps committed
218 219 220
			, ce_members=idxfilter \e -> case e of
				FunctionEntry fe -> fe.fe_class == Just (Index i)
				_                -> False
221
			, ce_usages=fromMaybe [] ('M'.get name class_usages_map)
222
			}
223
			with name = 'CDB'.getName ce.ce_loc
Camil Staps's avatar
Camil Staps committed
224
		FunctionEntry fe -> FunctionEntry
225
			{ fe
226 227 228
			& fe_derivations=case fe.fe_derivations of
				Nothing -> Nothing
				Just _  -> Just $ idxfilter \e -> case e of
Camil Staps's avatar
Camil Staps committed
229
					DeriveEntry de -> de.de_generic == name
230
					_              -> False
231
			, fe_usages=fromMaybe [] ('M'.get name function_usages_map)
232
			}
Camil Staps's avatar
Camil Staps committed
233 234
			with name = 'CDB'.getName fe.fe_loc
		ModuleEntry me -> ModuleEntry
235
			{ me
236
			& me_usages=fromMaybe [] ('M'.get name module_usages_map)
237
			}
Camil Staps's avatar
Camil Staps committed
238 239 240
			with name = 'CDB'.getName me.me_loc
		e -> e

241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278
	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]

Camil Staps's avatar
Camil Staps committed
279
	entries = [e \\ Right e <- entries`]
280
	entries` = map Right (
Camil Staps's avatar
Camil Staps committed
281
		extra ++
Camil Staps's avatar
Camil Staps committed
282
		[TypeDefEntry tde \\ tds <- tdb.temp_types, tde <- tds] ++
283
		[ModuleEntry mod \\ (mod,_) <- tdb.temp_modules] ++
284
		map ClassEntry classes ++
285
		map (FunctionEntry o fst) function_entries ++
286
		// Normal instances
Camil Staps's avatar
Camil Staps committed
287
		[InstanceEntry {ie_class=cls,ie_types=types,ie_locations=map thd3 is}
Camil Staps's avatar
Camil Staps committed
288 289
			\\ is=:[(cls,types,_):_] <- groupBy instanceEq
				$ sortBy ((<) `on` (\(c,ts,_) -> (c,map snd ts)))
290 291
				$ flatten tdb.temp_instances] ++
		// Derivations
292
		[DeriveEntry {de_generic=gn, de_type=t, de_type_representation=tr, de_locations=map fth4 ds}
293 294 295
			\\ 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]] ++
296
		[InstanceEntry {ie_class=gn, ie_types=[(t,tr)], ie_locations=map fth4 ds}
297 298 299 300 301
			\\ 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
Camil Staps's avatar
Camil Staps committed
302
	where
303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331
		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
332
		instanceEq (s, ts, _) (s2, ts2, _) = s == s2 && all (uncurry (isomorphic_to)) (zip2 (map fst ts) (map fst ts2))
Camil Staps's avatar
Camil Staps committed
333

Camil Staps's avatar
Camil Staps committed
334
	entridxs = zip2 [Index i \\ i <- [0..]] entries
Camil Staps's avatar
Camil Staps committed
335 336
	idxfilter f = [idx \\ (idx,e) <- entridxs | f e]
	idxhd = hd o idxfilter
Camil Staps's avatar
Camil Staps committed
337

Camil Staps's avatar
Camil Staps committed
338 339 340 341 342 343
	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
344
		coremods = [(fromJust $ 'CDB'.getLibrary me.me_loc, fromJust $ 'CDB'.getModule me.me_loc) \\ (me,_) <- tdb.temp_modules | me.me_is_core]
Camil Staps's avatar
Camil Staps committed
345 346 347 348 349 350
	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
Camil Staps's avatar
Camil Staps committed
351
		appmods = [(fromJust $ 'CDB'.getLibrary me.me_loc, fromJust $ 'CDB'.getModule me.me_loc) \\ (me,_) <- tdb.temp_modules | me.me_is_app]
Camil Staps's avatar
Camil Staps committed
352

353 354 355 356
	libmap = 'M'.fromList
		[(l,idxfilter \e -> case 'CDB'.getLocation e >>= 'CDB'.getLibrary of
			Nothing -> False
			Just l` -> l == l`) \\ l <- libs]
357
	where libs = removeDup [fromJust ('CDB'.getLibrary me.me_loc) \\ (me,_) <- tdb.temp_modules]
358
	modmap = 'M'.fromList
Camil Staps's avatar
Camil Staps committed
359
		[(m,idxfilter \e -> case 'CDB'.getLocation e >>= 'CDB'.getModule of
360 361
			Nothing -> False
			Just m` -> m == m`) \\ m <- mods]
362
	where mods = removeDup [fromJust ('CDB'.getModule me.me_loc) \\ (me,_) <- tdb.temp_modules]
363

364 365 366 367 368 369 370 371
	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 _)]

372 373 374 375
	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

Camil Staps's avatar
Camil Staps committed
376 377 378 379
findModules :: !String !IndexItem !String !*World -> *(!['CDB'.ModuleEntry], !*World)
findModules root item base w
| match item.pattern_exclude path = ([], w)
#! (fps, w)   = readDirectory fullpath w
380
| isError fps = ([], w)
381
#! (Ok fps)   = fps
Camil Staps's avatar
Camil Staps committed
382 383 384
#! mods       = map makeEntry $ filter included $ filter isIclModule fps
#! (moremodss,w) = mapSt (findModules root item o ((+++) basedot)) (filter isDirectory fps) w
= (removeDupBy (\m -> 'CDB'.getName m.me_loc) (mods ++ flatten moremodss), w)
385
where
386
	basedot = if (base == "") "" (base +++ ".")
Camil Staps's avatar
Camil Staps committed
387 388 389 390 391 392 393 394 395 396
	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 -> 'CDB'.ModuleEntry
	makeEntry fn =
397
		{ me_loc           = location item.IndexItem.name modname (path </?> fn) (Just 1) (Just 1) modname
398 399
		, me_is_core       = match item.pattern_core (path </?> fn)
		, me_is_app        = match item.pattern_app  (path </?> fn)
Camil Staps's avatar
Camil Staps committed
400 401 402
		, me_documentation = Nothing
		, me_usages        = []
		}
Camil Staps's avatar
Camil Staps committed
403
	where
Camil Staps's avatar
Camil Staps committed
404
		modname = basedot +++ fn % (0, size fn - 5)
405 406

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

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

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

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

Camil Staps's avatar
Camil Staps committed
419
indexModule :: !Bool !String !'CDB'.ModuleEntry !TemporaryDB !*World
420
	-> *(!TemporaryDB, !*World)
Camil Staps's avatar
Camil Staps committed
421
indexModule include_locals root mod db w
422
#! (functions,macros,generics,typedefs,clss,insts,derivs,clsderivs,(modname,mod`,imports),w)
Camil Staps's avatar
Camil Staps committed
423
	= findModuleContents include_locals (root </> lib </> mkdir ('CDB'.getName mod.me_loc)) w
Camil Staps's avatar
Camil Staps committed
424
#! typedefs = [{td & tde_loc=castLoc modname loc} \\ (loc,td) <- typedefs]
Camil Staps's avatar
Camil Staps committed
425
#! lib = lib % (0, size lib - size modname + size ('CDB'.getName mod.me_loc) - 1)
426 427 428
#! db  =
	{ db
	& temp_functions =
429
		[ [({f & fe_loc=castLoc modname loc},idents) \\ (loc,f,idents) <- functions ++ macros ++ generics]
Camil Staps's avatar
Camil Staps committed
430
		, [(f, 'S'.newSet) \\ td <- typedefs, f <- constructor_functions td ++ record_functions td]
431 432
		: db.temp_functions
		]
433
	, temp_classes = [[({ce & ce_loc=castLoc modname loc}, fs) \\ (loc,ce,fs) <- clss]:db.temp_classes]
Camil Staps's avatar
Camil Staps committed
434
	, temp_types = [typedefs:db.temp_types]
Camil Staps's avatar
Camil Staps committed
435 436 437
	, 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]
438
	, temp_modules = [({mod & me_loc='CDB'.setModule modname ('CDB'.setName modname mod.me_loc), me_documentation=mod`.me_documentation},imports):db.temp_modules]
439
	}
Camil Staps's avatar
Camil Staps committed
440
= (db,w)
441
where
Camil Staps's avatar
Camil Staps committed
442 443
	lib = fromJust ('CDB'.getLibrary mod.me_loc)

444
	castLocThd3 :: String -> ([(a, b, LocationInModule)] -> [(a, b, 'CDB'.Location)])
Camil Staps's avatar
Camil Staps committed
445 446 447
	castLocThd3 m = map (appThd3 (castLoc m))
	castLocFrth m = map (\(a,b,c,l) -> (a,b,c,castLoc m l))

448
	castLoc :: String LocationInModule -> 'CDB'.Location
Camil Staps's avatar
Camil Staps committed
449 450
	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"
Camil Staps's avatar
Camil Staps committed
451 452 453

	mkdir :: String -> String
	mkdir s = { if (c == '.') '/' c \\ c <-: s }
Camil Staps's avatar
Camil Staps committed
454

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

458
findModuleContents :: !Bool !String !*World
Camil Staps's avatar
Camil Staps committed
459 460 461
	-> *( ![(LocationInModule, 'CDB'.FunctionEntry, 'S'.Set String)]
	    , ![(LocationInModule, 'CDB'.FunctionEntry, 'S'.Set String)]
	    , ![(LocationInModule, 'CDB'.FunctionEntry, 'S'.Set String)]
462
	    , ![(LocationInModule, 'CDB'.TypeDefEntry)]
Camil Staps's avatar
Camil Staps committed
463
	    , ![(LocationInModule, 'CDB'.ClassEntry, [(String, 'CDB'.FunctionEntry, 'S'.Set String)])]
464 465 466
	    , ![('CDB'.Name, [('CDB'.Type, String)], LocationInModule)]
	    , ![('CDB'.Name, [('CDB'.Type, String, LocationInModule)])]
	    , ![('CDB'.Name, 'CDB'.Type, String, LocationInModule)]
Camil Staps's avatar
Camil Staps committed
467
	    , !('CDB'.Name, 'CDB'.ModuleEntry, 'S'.Set String)
Camil Staps's avatar
Camil Staps committed
468 469
	    , !*World
	    )
470
findModuleContents include_locals path w
471 472 473 474 475 476
#! (dcl,dcl_symbols,w) = readModule False w
#! (dcl,modname) = case dcl of
	Left  _   -> ([], "")
	Right dcl -> (dcl.mod_defs, dcl.mod_ident.id_name)
#! (icl,icl_symbols,w) = readModule True w
#! icl = case icl of Left _ -> []; Right icl -> icl.mod_defs
477
#! imports = 'S'.fromList [i.import_module.id_name \\ PD_Import is <- dcl ++ icl, i <- is]
478
#! contents=:(functions,rules,generics,typedefs,clss,insts,derivs,clsderivs) =
479 480 481 482 483 484
	( combine cmpLocFst3  joinLocFstIds pd_typespecs    dcl dcl_symbols icl icl_symbols
	, combine cmpLocFst3  joinLocFstIds pd_rewriterules dcl dcl_symbols icl icl_symbols
	, combine cmpLocFst3  joinLocFstIds pd_generics     dcl dcl_symbols icl icl_symbols
	, combine cmpLocFst   joinTypeDefs  pd_types        dcl dcl_symbols icl icl_symbols
	, combine cmpLocFst3  joinLocFst3   pd_classes      dcl dcl_symbols icl icl_symbols
	, combine cmpInsts    joinInsts     pd_instances    dcl dcl_symbols icl icl_symbols
485 486 487
	, combineDerivs (pd_derivations True dcl) (pd_derivations False icl)
	, combine cmpClsDeriv joinClsDeriv pd_class_derivations dcl dcl_symbols icl icl_symbols
	)
488
#! (functions,rules,generics,typedefs,clss,insts,derivs,clsderivs) =
489 490
	if include_locals
	contents
491 492 493
	( filter (hasDcl o fst3)            functions
	, filter (hasDcl o fst3)            rules
	, filter (hasDcl o fst3)            generics
494
	, filter (hasDcl o fst)             typedefs
495
	, filter (hasDcl o fst3)            clss
496 497 498 499
	, 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
Camil Staps's avatar
Camil Staps committed
500
#! rules = filter (\(r,_,_) -> not $ any (\(l,_,_)->fromJust l.LocationInModule.name == fromJust r.LocationInModule.name) functions) rules
501
= (functions,rules,generics,typedefs,clss,insts,derivs,clsderivs,(modname,pd_module dcl,imports),w)
Camil Staps's avatar
Camil Staps committed
502
where
503 504
	combine :: (a a -> Bool) (a a -> a)
		(Bool [ParsedDefinition] SymbolTable -> [a])
505 506
		![ParsedDefinition] SymbolTable
		![ParsedDefinition] SymbolTable
507 508 509 510 511 512 513 514 515
		-> [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 iclsym
		= unionBy eq join (find True dcl dclsym) (find False icl iclsym)

	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
516
		([],   xs) -> [y:unionBy eq join xs  ys]
517 518 519
		(found,xs) -> let (foundys,ys`) = partition (eq y) ys in
			[foldr join y (found ++ foundys):unionBy eq join xs ys`]

Camil Staps's avatar
Camil Staps committed
520
	cmpLoc x y = x.LocationInModule.name == y.LocationInModule.name
521 522

	cmpLocFst :: ((LocationInModule, a) (LocationInModule, a) -> Bool)
523 524 525 526
	cmpLocFst = cmpLoc `on` fst

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

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

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

Camil Staps's avatar
Camil Staps committed
534 535
	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)
536

537 538
	joinTypeDefs :: (LocationInModule, 'CDB'.TypeDefEntry) (LocationInModule, 'CDB'.TypeDefEntry) -> (LocationInModule, 'CDB'.TypeDefEntry)
	joinTypeDefs (a,t) (b,u) = (joinLoc a b, 'CDB'.mergeTypeDefEntries t u)
539 540 541 542 543 544

	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 ::
545 546 547
		([('CDB'.Name, [('CDB'.Type, String, LocationInModule)])]
		 [('CDB'.Name, [('CDB'.Type, String, LocationInModule)])]
		 -> [('CDB'.Name, [('CDB'.Type, String, LocationInModule)])])
548 549 550 551 552 553 554 555 556 557
	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 =
Camil Staps's avatar
Camil Staps committed
558 559 560
		{ dcl_line = a.dcl_line              <|> b.dcl_line
		, icl_line = a.icl_line              <|> b.icl_line
		, name     = a.LocationInModule.name <|> b.LocationInModule.name
561 562
		}

Camil Staps's avatar
Camil Staps committed
563 564 565
	pd_module :: ![ParsedDefinition] -> ModuleEntry
	pd_module [PD_Documentation _ doc:_]
		= { zero
566
		  & me_documentation = docParseResultToMaybe (const True) $ parseDoc doc
Camil Staps's avatar
Camil Staps committed
567
		  }
Camil Staps's avatar
Camil Staps committed
568
	pd_module _ = zero
Camil Staps's avatar
Camil Staps committed
569

Camil Staps's avatar
Camil Staps committed
570
	pd_rewriterules :: !Bool ![ParsedDefinition] SymbolTable -> [(LocationInModule, 'CDB'.FunctionEntry, 'S'.Set String)]
571
	pd_rewriterules dcl defs st
Camil Staps's avatar
Camil Staps committed
572
		= [( setLine dcl pos {LocationInModule | zero & name=Just id.id_name}
573
		   , let doc = findDoc hideIsUsedReturn id st in
Camil Staps's avatar
Camil Staps committed
574
		     trace_type_warning id
575
		     { zero
Camil Staps's avatar
Camil Staps committed
576
		     & fe_kind=Macro
577
		     , fe_type=(docType =<< doc) <|> pdType pd
Camil Staps's avatar
Camil Staps committed
578
		     , fe_representation=Just $ priostring id pd +++ cpp pd
Camil Staps's avatar
Camil Staps committed
579
		     , fe_priority=findPrio id >>= 'T'.toMaybePriority
580
		     , fe_documentation=doc
581
		     }
Camil Staps's avatar
Camil Staps committed
582
		   , (idents ICExpression pd).globals
583
		   ) \\ pd=:(PD_Function pos id isinfix args rhs _) <- defs]
Camil Staps's avatar
Camil Staps committed
584
	where
Camil Staps's avatar
Camil Staps committed
585 586 587 588 589 590
		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 -> ""
Camil Staps's avatar
Camil Staps committed
591 592

		findPrio :: Ident -> Maybe Priority
593
		findPrio id = (\(PD_TypeSpec _ _ p _ _) -> p) <$> findTypeSpec id defs
Camil Staps's avatar
Camil Staps committed
594 595 596

		findTypeSpec :: Ident [ParsedDefinition] -> Maybe ParsedDefinition
		findTypeSpec _  []          = Nothing
597
		findTypeSpec id [pd=:(PD_TypeSpec _ id` prio _ _):defs]
Camil Staps's avatar
Camil Staps committed
598
		| id`.id_name == id.id_name = Just pd
599 600
		findTypeSpec id [_:defs]    = findTypeSpec id defs

Camil Staps's avatar
Camil Staps committed
601 602 603 604 605 606
		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

607
	pd_derivations :: !Bool ![ParsedDefinition] -> [('CDB'.Name, [('CDB'.Type, String, LocationInModule)])]
608 609 610 611 612
	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]

Camil Staps's avatar
Camil Staps committed
613
	pd_generics :: !Bool ![ParsedDefinition] SymbolTable -> [(LocationInModule, 'CDB'.FunctionEntry, 'S'.Set String)]
614
	pd_generics dcl defs st
Camil Staps's avatar
Camil Staps committed
615
		= [( setLine dcl gen_pos {LocationInModule | zero & name=Just id_name}
Camil Staps's avatar
Camil Staps committed
616 617 618 619
		   , { zero
		     & fe_type=Just $ 'T'.toType gen_type
		     , fe_generic_vars=Just $ map 'T'.toTypeVar gen_vars
		     , fe_representation=Just $ cpp gen
620
		     , fe_documentation=findDoc hideIsUsedReturn id st
621
		     , fe_derivations=Just []
Camil Staps's avatar
Camil Staps committed
622
		     }
Camil Staps's avatar
Camil Staps committed
623
		   , 'S'.newSet
624 625
		   ) \\ gen=:(PD_Generic {gen_ident=id=:{id_name},gen_pos,gen_type,gen_vars}) <- defs]

Camil Staps's avatar
Camil Staps committed
626
	pd_typespecs :: !Bool ![ParsedDefinition] SymbolTable -> [(LocationInModule, 'CDB'.FunctionEntry, 'S'.Set String)]
627
	pd_typespecs dcl defs st
Camil Staps's avatar
Camil Staps committed
628
		= [( setLine dcl pos {LocationInModule | zero & name=Just id_name}
Camil Staps's avatar
Camil Staps committed
629 630 631 632
		   , { zero
		     & fe_type=Just $ 'T'.toType t
		     , fe_priority = 'T'.toMaybePriority p
		     , fe_representation = Just $ cpp ts
633
		     , fe_documentation = findDoc hideIsUsedReturn id st
Camil Staps's avatar
Camil Staps committed
634
		     }
Camil Staps's avatar
Camil Staps committed
635
		   , (idents ICExpression [pd \\ pd=:(PD_Function _ id _ _ _ _) <- defs | id.id_name == id_name]).globals
636 637
		   ) \\ ts=:(PD_TypeSpec pos id=:{id_name} p (Yes t) funspecs) <- defs]

638
	pd_class_derivations :: !Bool ![ParsedDefinition] SymbolTable -> [('CDB'.Name, 'CDB'.Type, String, LocationInModule)]
639 640 641 642
	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]

643
	pd_instances :: !Bool ![ParsedDefinition] SymbolTable -> [('CDB'.Name, [('CDB'.Type, String)], LocationInModule)]
644 645
	pd_instances dcl defs _
		= [(id, types, setLine dcl pos zero) \\ (id,types,pos) <- instances]
646
	where
647
		instances = map (appSnd3 (map (\t -> ('T'.toType t, cppp t)))) $
648 649 650
			[(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]

Camil Staps's avatar
Camil Staps committed
651
	pd_classes :: !Bool ![ParsedDefinition] SymbolTable -> [(LocationInModule, 'CDB'.ClassEntry, [(String, 'CDB'.FunctionEntry, 'S'.Set String)])]
652
	pd_classes dcl defs st
653 654
		= [ let
		      typespecs = pd_typespecs True clsdefs st
Camil Staps's avatar
Camil Staps committed
655
		      macros = [(n,(r,ids)) \\ ({LocationInModule | name=Just n},{fe_representation=Just r},ids) <- pd_rewriterules dcl clsdefs st]
656 657 658
		      updateRepresentation n fe
		        = { fe
		          & fe_kind=if (isNothing $ lookup n macros) fe.fe_kind Macro
659
		          , fe_representation=(fst <$> lookup n macros) <|> fe.fe_representation
660 661 662 663
		          , fe_documentation=if (isSingleFunction typespecs id)
		              ((\d -> {FunctionDoc | d & vars=[]}) <$> findDoc hideIsUsedReturn id st)
		              fe.fe_documentation
		          }
Camil Staps's avatar
Camil Staps committed
664 665
		      members = [(f,updateRepresentation f et,ids) \\ ({LocationInModule | name=Just f}, et, ids) <- typespecs]
		    in ( setLine dcl class_pos {LocationInModule | zero & name=Just id_name}
666 667
		       , 'CDB'.toClass
		         NoLocation
668
		         (map 'T'.toTypeVar class_args)
669
		         (all (\(_,fe,_) -> fe.fe_kind == Macro) members)
670
		         (flatten $ map 'T'.toTypeContext class_context)
671
		         (parseClassDoc typespecs id st)
672
		       , members
673 674 675
		       )
		  \\ PD_Class {class_ident=id=:{id_name},class_pos,class_args,class_context} clsdefs <- defs
		  ]
676 677 678 679 680
	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.
681
		parseClassDoc :: [(LocationInModule, 'CDB'.FunctionEntry, a)] Ident SymbolTable -> Maybe ClassDoc
682
		parseClassDoc members id st
683
		| isSingleFunction members id = flip addClassMemberDoc
684 685
			(functionToClassMemberDoc <$> findDoc hideIsUsedReturn id st)
			<$> findDoc hideFunctionOnClass id st
686
		| otherwise = flip (foldl addClassMemberDoc)
687
			[functionToClassMemberDoc <$> fe.fe_documentation \\ (_,fe,_) <- members]
688
			<$> findDoc hideIsUsedReturn id st
689

690
		isSingleFunction :: [(LocationInModule, 'CDB'.FunctionEntry, a)] Ident -> Bool
691
		isSingleFunction members id = length members == 1
Camil Staps's avatar
Camil Staps committed
692
			&& fromJust (fst3 $ hd members).LocationInModule.name == id.id_name
693 694 695 696 697

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

699
	pd_types :: !Bool ![ParsedDefinition] SymbolTable -> [(LocationInModule, 'CDB'.TypeDefEntry)]
700
	pd_types dcl defs st
701
		= [let name = 'T'.td_name td in
Camil Staps's avatar
Camil Staps committed
702
			( setLine dcl ptd.td_pos {LocationInModule | zero & name=Just name}
703
			, 'CDB'.toTypeDefEntry NoLocation td $ Just $ findRhsDoc ptd $ fromMaybe gDefault{|*|} $
704
				findDoc (const True) ptd.td_ident st
705
			) \\ PD_Type ptd <- defs, td <- ['T'.toTypeDef ptd]]
706
	where
707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722
		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 = case ps.ps_doc of
				Yes d -> Just $ parseSingleLineDoc d
				No -> Nothing

		addConses :: ![ParsedConstructor] !TypeDoc -> TypeDoc
723
		addConses [] doc
724 725 726 727 728 729 730
			= {doc & constructors=Just []}
		addConses [pc:cs] doc = {doc` & constructors=Just [d:fromMaybe [] doc`.constructors]}
		where
			doc` = addConses cs doc
			d = case pc.pc_doc of
				Yes d -> docParseResultToMaybe (const True) (parseDoc d)
				No -> Nothing
731

732
	toLine :: Position -> 'CDB'.LineNr
Camil Staps's avatar
Camil Staps committed
733 734 735 736
	toLine (FunPos _ l _) = Just l
	toLine (LinePos _ l)  = Just l
	toLine _              = Nothing

Camil Staps's avatar
Camil Staps committed
737
	readModule :: Bool !*World -> *(!Either String ParsedModule, SymbolTable, !*World)
Camil Staps's avatar
Camil Staps committed
738 739 740
	readModule icl w
	# ht = newHashTable newHeap
	# ht = set_hte_mark (if icl 1 0) ht
Camil Staps's avatar
Camil Staps committed
741
	# filename = path +++ if icl ".icl" ".dcl"
742
	# (ok,f,w) = fopen filename FReadText w
Camil Staps's avatar
Camil Staps committed
743
	| not ok = (Left $ "Couldn't open " +++ filename, abort "no symboltable\n", w)
Camil Staps's avatar
Camil Staps committed
744
	# (mod_id, ht) = putIdentInHashTable path (IC_Module NoQualifiedIdents) ht
Camil Staps's avatar
Camil Staps committed
745
	# ((b1,b2,pm,ht,f),w) = accFiles (wantModule` f "" icl mod_id.boxed_ident NoPos True ht stderr) w
746
	# (ok,w) = fclose f w
Camil Staps's avatar
Camil Staps committed
747
	| not ok = (Left $ "Couldn't close " +++ filename, abort "no symboltable\n", w)
Camil Staps's avatar
Camil Staps committed
748
	= (Right pm, ht.hte_symbol_heap, w)
749 750 751 752 753 754
	where
		wantModule` :: !*File !{#Char} !Bool !Ident !Position !Bool !*HashTable !*File !*Files
			-> ((!Bool,!Bool,!ParsedModule