Factory.icl 34.5 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
	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]

270 271
	function_entries = flatten tdb.temp_functions ++
		[({ fun
272 273 274 275 276
		& 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
277 278 279 280 281 282
		}, 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]
283

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

Camil Staps's avatar
Camil Staps committed
339
	entridxs = zip2 [Index i \\ i <- [0..]] entries
Camil Staps's avatar
Camil Staps committed
340 341
	idxfilter f = [idx \\ (idx,e) <- entridxs | f e]
	idxhd = hd o idxfilter
Camil Staps's avatar
Camil Staps committed
342

Camil Staps's avatar
Camil Staps committed
343 344 345 346 347 348
	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
349
		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
350 351 352 353 354 355
	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
356
		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
357

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

369 370 371 372 373 374 375 376
	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 _)]

377 378 379 380
	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
381 382 383 384
findModules :: !String !IndexItem !String !*World -> *(!['CDB'.ModuleEntry], !*World)
findModules root item base w
| match item.pattern_exclude path = ([], w)
#! (fps, w)   = readDirectory fullpath w
385
| isError fps = ([], w)
386
#! (Ok fps)   = fps
Camil Staps's avatar
Camil Staps committed
387
#! mods       = [makeEntry fn (isMember (replaceSubString ".icl" ".dcl" fn) fps) \\ fn <- fps | isIclModule fn && included fn]
Camil Staps's avatar
Camil Staps committed
388 389
#! (moremodss,w) = mapSt (findModules root item o ((+++) basedot)) (filter isDirectory fps) w
= (removeDupBy (\m -> 'CDB'.getName m.me_loc) (mods ++ flatten moremodss), w)
390
where
391
	basedot = if (base == "") "" (base +++ ".")
Camil Staps's avatar
Camil Staps committed
392 393 394 395 396 397 398 399
	path = replaceSubString "." {pathSeparator} base
	fullpath = root </?> item.IndexItem.name </?> path

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

Camil Staps's avatar
Camil Staps committed
400 401 402
	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
403 404
		, 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
405 406 407
		, me_documentation = Nothing
		, me_usages        = []
		}
Camil Staps's avatar
Camil Staps committed
408
	where
Camil Staps's avatar
Camil Staps committed
409
		modname = basedot +++ fn % (0, size fn - 5)
410 411

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

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

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

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

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

451
	castLoc :: String LocationInModule -> 'CDB'.Location
Camil Staps's avatar
Camil Staps committed
452 453
	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
454 455 456

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

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

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

	cmpLocFst :: ((LocationInModule, a) (LocationInModule, a) -> Bool)
526 527 528 529
	cmpLocFst = cmpLoc `on` fst

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

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

534 535 536
	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
537 538
	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)
539

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

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

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

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

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

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

Camil Staps's avatar
Camil Staps committed
604 605 606 607 608 609
		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

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

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

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

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

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

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

702
	pd_types :: !Bool ![ParsedDefinition] SymbolTable -> [(LocationInModule, 'CDB'.TypeDefEntry)]
703
	pd_types dcl defs st
704
		= [let name = 'T'.td_name td in
Camil Staps's avatar
Camil Staps committed
705
			( setLine dcl ptd.td_pos {LocationInModule | zero & name=Just name}
706
			, 'CDB'.toTypeDefEntry NoLocation td $ Just $ findRhsDoc ptd $ fromMaybe gDefault{|*|} $
707
				findDoc (const True) ptd.td_ident st
708
			) \\ PD_Type ptd <- defs, td <- ['T'.toTypeDef ptd]]
709
	where
710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725
		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
726
		addConses [] doc
727 728 729 730 731 732 733
			= {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
734

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

Camil Staps's avatar
Camil Staps committed
740
	readModule :: Bool !*World -> *(!Either String ParsedModule, SymbolTable, !*World)
Camil Staps's avatar
Camil Staps committed
741 742 743
	readModule icl w
	# ht = newHashTable newHeap
	# ht = set_hte_mark (if icl 1 0) ht
Camil Staps's avatar
Camil Staps committed
744
	# filename = path +++ if icl ".icl" ".dcl"
745
	# (ok,f,w) = fopen filename FReadText w
Camil Staps's avatar
Camil Staps committed
746
	| not ok = (Left $ "Couldn't open " +++ filename, abort "no symboltable\n", w)
Camil Staps's avatar
Camil Staps committed
747
	# (mod_id,