Factory.icl 33.6 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 Heap import :: Heap, newHeap, sreadPtr
38 39 40
from predef import init_identifiers
from syntax import :: ClassDef{class_args,class_context,class_ident,class_pos},
	:: FileName, :: FunctName, :: FunKind(FK_Macro), :: FunSpecials, :: GCF,
41
	:: GenericCaseDef{gc_gcf,gc_pos,gc_type}, :: GenericCaseFunctions(GCF,GCFC),
Camil Staps's avatar
Camil Staps committed
42 43
	:: GenericDef{gen_ident,gen_pos,gen_type,gen_vars},
	:: Ident{id_name,id_info}, :: LineNr, :: Module{mod_defs,mod_ident},
44
	:: Optional(Yes,No), :: SymbolPtr, :: Ptr, :: SymbolTableEntry,
Camil Staps's avatar
Camil Staps committed
45
	:: ParsedDefinition(PD_Class,PD_Derive,PD_Function,PD_Generic,PD_Instance,
46
		PD_Instances,PD_Type,PD_TypeSpec,PD_GenericCase,
47
		PD_NodeDef,PD_Import),
48 49
	:: ParsedExpr(PE_Ident,PE_List),
	:: ParsedInstance{pi_ident,pi_pos,pi_types},
50
	:: ParsedInstanceAndMembers{pim_pi}, :: ParsedModule, :: ParsedTypeDef,
51
	:: Position(FunPos,LinePos,NoPos), :: Priority, :: Rhs, :: ATypeVar,
52
	:: RhsDefsOfType(ConsList,ExtensibleConses,SelectorList,TypeSpec,EmptyRhs,
53
		AbstractTypeSpec,NewTypeCons,MoreConses),
54 55
	:: SymbolTable, :: SymbolTableEntry, :: SymbolType, :: Type, :: BITVECT,
	:: TypeContext, :: TypeDef{td_ident,td_pos,td_rhs}, :: TypeVar,
Camil Staps's avatar
Camil Staps committed
56
	:: ParsedConstructor{pc_cons_ident}, :: ParsedSelector{ps_field_ident},
57
	:: ParsedImport, :: Import{import_module}
58

59 60 61 62 63 64 65 66 67 68 69 70
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,
71 72
	:: TypeDoc{fields,constructors}, :: ConstructorDoc, :: ClassMemberDoc,
	:: Description, :: ParseWarning(UsedReturn,IllegalField), :: ParseError,
73 74 75 76 77 78 79
	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
80 81
import Clean.Parse
import Clean.Parse.Comments
82 83 84 85

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

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

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

Camil Staps's avatar
Camil Staps committed
127 128 129 130 131 132 133 134
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
135
	< ('CDB'.Location l1 m1 _ d1 i1 n1) ('CDB'.Location l2 m2 _ d2 i2 n2)
Camil Staps's avatar
Camil Staps committed
136
		= ((l1,m1,n1),(d1,i1)) < ((l2,m2,n2), (d2,i2))
Camil Staps's avatar
Camil Staps committed
137
	< ('CDB'.Location _ _ _ _ _ _) _
Camil Staps's avatar
Camil Staps committed
138
		= True
Camil Staps's avatar
Camil Staps committed
139
	< _ ('CDB'.Location _ _ _ _ _ _)
Camil Staps's avatar
Camil Staps committed
140 141 142 143 144 145 146 147
		= False
	< (Builtin a _) (Builtin b _)
		= a < b
	< (Builtin _ _) _
		= True
	< _ _
		= False

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

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

238 239 240 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
	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]

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

Camil Staps's avatar
Camil Staps committed
281
	entries = [e \\ Right e <- entries`]
282
	entries` = map Right (
Camil Staps's avatar
Camil Staps committed
283
		extra ++
Camil Staps's avatar
Camil Staps committed
284
		[TypeDefEntry tde \\ tds <- tdb.temp_types, tde <- tds] ++
285
		[ModuleEntry mod \\ (mod,_) <- tdb.temp_modules] ++
286
		map ClassEntry classes ++
287
		map (FunctionEntry o fst) function_entries ++
288
		// Normal instances
Camil Staps's avatar
Camil Staps committed
289
		[InstanceEntry {ie_class=cls,ie_types=types,ie_locations=map thd3 is}
Camil Staps's avatar
Camil Staps committed
290 291
			\\ is=:[(cls,types,_):_] <- groupBy instanceEq
				$ sortBy ((<) `on` (\(c,ts,_) -> (c,map snd ts)))
292 293
				$ flatten tdb.temp_instances] ++
		// Derivations
294
		[DeriveEntry {de_generic=gn, de_type=t, de_type_representation=tr, de_locations=map fth4 ds}
295 296 297
			\\ 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]] ++
298
		[InstanceEntry {ie_class=gn, ie_types=[(t,tr)], ie_locations=map fth4 ds}
299 300 301 302 303
			\\ 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
304
	where
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 332 333
		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
334
		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
335

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

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

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

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

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

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

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

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

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

417 418 419 420
	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
421
indexModule :: !Bool !String !'CDB'.ModuleEntry !TemporaryDB !*World
422
	-> *(!TemporaryDB, !*World)
Camil Staps's avatar
Camil Staps committed
423
indexModule include_locals root mod db w
424
#! (functions,macros,generics,typedefs,clss,insts,derivs,clsderivs,(modname,mod`,imports),w)
Camil Staps's avatar
Camil Staps committed
425
	= findModuleContents include_locals (root </> lib </> mkdir ('CDB'.getName mod.me_loc)) w
Camil Staps's avatar
Camil Staps committed
426
#! typedefs = [{td & tde_loc=castLoc modname loc} \\ (loc,td) <- typedefs]
427 428 429
#! db  =
	{ db
	& temp_functions =
430
		[ [({f & fe_loc=castLoc modname loc},idents) \\ (loc,f,idents) <- functions ++ macros ++ generics]
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 477
#! (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
Camil Staps's avatar
Camil Staps committed
478
			( {zero & me_documentation=docParseResultToMaybe (const True) =<< parseDoc <$> getComment dcl coll}
479 480 481 482
			, dcl.mod_defs
			, coll
			)
#! (icl,w) = readModule (path +++ ".icl") w
Camil Staps's avatar
Camil Staps committed
483
#! (icl,modname) = case icl of
484 485
	Error _ -> ([], "")
	Ok (icl,syms) -> (icl.mod_defs, icl.mod_ident.id_name)
486
#! imports = 'S'.fromList [i.import_module.id_name \\ PD_Import is <- dcl ++ icl, i <- is]
487
#! contents=:(functions,rules,generics,typedefs,clss,insts,derivs,clsderivs) =
488 489 490 491 492 493
	( 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
494
	, combineDerivs (pd_derivations True dcl) (pd_derivations False icl)
495
	, combine cmpClsDeriv joinClsDeriv pd_class_derivations dcl documentation icl
496
	)
497
#! (functions,rules,generics,typedefs,clss,insts,derivs,clsderivs) =
498 499
	if include_locals
	contents
500 501 502
	( filter (hasDcl o fst3)            functions
	, filter (hasDcl o fst3)            rules
	, filter (hasDcl o fst3)            generics
503
	, filter (hasDcl o fst)             typedefs
504
	, filter (hasDcl o fst3)            clss
505 506 507 508
	, 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
509
#! rules = filter (\(r,_,_) -> not $ any (\(l,_,_)->fromJust l.LocationInModule.name == fromJust r.LocationInModule.name) functions) rules
510
= (functions,rules,generics,typedefs,clss,insts,derivs,clsderivs,(modname,dclmod,imports),w)
Camil Staps's avatar
Camil Staps committed
511
where
512
	combine :: (a a -> Bool) (a a -> a)
513 514 515
		(Bool [ParsedDefinition] CollectedComments -> [a])
		![ParsedDefinition] !CollectedComments
		![ParsedDefinition]
516
		-> [a]
517
	combine eq join find dcl dclsym [] // Special case for things like _library.dcl
518
		= find True dcl dclsym
519 520
	combine eq join find dcl dclsym icl
		= unionBy eq join (find True dcl dclsym) (find False icl emptyCollectedComments)
521 522 523 524

	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
525
		([],   xs) -> [y:unionBy eq join xs  ys]
526 527 528
		(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
529
	cmpLoc x y = x.LocationInModule.name == y.LocationInModule.name
530 531

	cmpLocFst :: ((LocationInModule, a) (LocationInModule, a) -> Bool)
532 533 534 535
	cmpLocFst = cmpLoc `on` fst

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

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

540 541 542
	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
543 544
	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)
545

546 547
	joinTypeDefs :: (LocationInModule, 'CDB'.TypeDefEntry) (LocationInModule, 'CDB'.TypeDefEntry) -> (LocationInModule, 'CDB'.TypeDefEntry)
	joinTypeDefs (a,t) (b,u) = (joinLoc a b, 'CDB'.mergeTypeDefEntries t u)
548 549 550 551 552 553

	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 ::
554 555 556
		([('CDB'.Name, [('CDB'.Type, String, LocationInModule)])]
		 [('CDB'.Name, [('CDB'.Type, String, LocationInModule)])]
		 -> [('CDB'.Name, [('CDB'.Type, String, LocationInModule)])])
557 558 559 560 561 562 563 564 565 566
	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
567 568 569
		{ dcl_line = a.dcl_line              <|> b.dcl_line
		, icl_line = a.icl_line              <|> b.icl_line
		, name     = a.LocationInModule.name <|> b.LocationInModule.name
570 571
		}

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

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

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

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

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

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

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

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

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

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

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

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

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

		addConses :: ![ParsedConstructor] !TypeDoc -> TypeDoc
723
		addConses [] doc
724 725 726 727
			= {doc & constructors=Just []}
		addConses [pc:cs] doc = {doc` & constructors=Just [d:fromMaybe [] doc`.constructors]}
		where
			doc` = addConses cs doc
Camil Staps's avatar
Camil Staps committed
728
			d = docParseResultToMaybe (const True) =<< parseDoc <$> getComment pc comments
729

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

735
	docParseResultToMaybe :: (ParseWarning -> Bool)
736
		(Either ParseError (d, [ParseWarning])) -> Maybe d
737
	docParseResultToMaybe showw (Left e)
738
		= traceParseError e Nothing
739 740 741 742 743
	docParseResultToMaybe showw (Right (doc,ws))
		= traceParseWarnings (filter showw ws) (Just doc)

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

Camil Staps's avatar
Camil Staps committed
745
	findDoc :: (ParseWarning -> Bool) a CollectedComments -> Maybe d | docBlockToDoc{|*|} d & commentIndex a
746
	findDoc showw id coll = getComment id coll >>= \doc -> docParseResultToMaybe showw $ parseDoc doc
747

748 749 750
	isUsedReturn :: ParseWarning -> Bool
	isUsedReturn UsedReturn = True; isUsedReturn _ = False

751 752 753 754
	setLine :: !Bool !Position !LocationInModule -> LocationInModule
	setLine True  pos loc = {loc & dcl_line=toLine pos}
	setLine False pos loc = {loc & icl_line=toLine pos}

Camil Staps's avatar
Camil Staps committed
755
constructor_functions :: !'CDB'.TypeDefEntry -> ['CDB'.FunctionEntry]
Camil Staps's avatar
Camil Staps committed
756 757 758 759 760
constructor_functions etd = [
	{ zero
	& fe_loc='CDB'.setName c etd.tde_loc
	, fe_kind=Constructor
	, fe_type=Just f
761
	, fe_representation=Just $ concat $ print_prio c p ++ [" :: "] ++ print False f
Camil Staps's avatar
Camil Staps committed
762 763 764 765 766
	, fe_priority=p
	, fe_documentation=constructorToFunctionDoc <$> doc
	}
	\\ (c,f,p) <- 'T'.constructorsToFunctions ('CDB'.getTypeDef etd)
	 & doc <- cons_doc]
767
where
768 769 770
	print_prio :: !String (Maybe 'T'.Priority) -> [String]
	print_prio name Nothing  = [name]
	print_prio name (Just p) = ["(",name,") ":print False p]
771

772
	cons_doc = fromMaybe [] (docConstructors =<< 'CDB'.getTypeDefDoc etd) ++ repeat Nothing
773

Camil Staps's avatar
Camil Staps committed
774
record_functions :: !'CDB'.TypeDefEntry -> ['CDB'.FunctionEntry]
Camil Staps's avatar
Camil Staps committed
775 776 777 778 779 780 781 782 783 784
record_functions etd = [
	{ zero
	& fe_loc='CDB'.setName f etd.tde_loc
	, fe_kind=RecordField
	, fe_type=Just t
	, fe_representation=Just $ concat [".", f, " :: ":print False t]
	, fe_documentation=(\d -> {FunctionDoc | gDefault{|*|} & description=Just d}) <$> doc
	}
	\\ (f,t) <- 'T'.recordsToFunctions ('CDB'.getTypeDef etd)
	 & doc <- field_doc]
785
where
786
	field_doc = fromMaybe [] (docFields =<< 'CDB'.getTypeDefDoc etd) ++ repeat Nothing
787 788 789

instance == (a,b,c,d) | == a & == b & == c & == d
where == (a,b,c,d) (p,q,r,s) = a == p && b == q && c == r && d == s
790 791

fth4 (a,b,c,d) :== d