Factory.icl 33.8 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
import StdString
import StdTuple

14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34
from Clean.Doc import :: ModuleDoc, :: FunctionDoc{vars,description}, :: ClassDoc,
	:: TypeDoc{fields,constructors}, :: ConstructorDoc, :: ClassMemberDoc,
	:: Description, :: ParseWarning(UsedReturn,IllegalField), :: ParseError,
	generic docBlockToDoc, parseDoc, parseSingleLineDoc, :: DocBlock,
	class docType(..), instance docType FunctionDoc,
	class docConstructors(..), instance docConstructors TypeDoc,
	class docFields(..), instance docFields TypeDoc,
	traceParseError, traceParseWarnings,
	constructorToFunctionDoc, functionToClassMemberDoc, addClassMemberDoc
import Clean.Idents
import Clean.Parse
import Clean.Parse.Comments
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, instance toString Type
import Clean.Types.CoclTransform
35 36 37 38
import Control.Applicative
import Control.Monad
import Data.Either
import Data.Error
39
from Data.Func import $, mapSt, on, `on`, instance Functor ((->) a)
40
import Data.Functor
Camil Staps's avatar
Camil Staps committed
41
import Data.GenDefault
42
import Data.List
43 44
from Data.Map import :: Map
import qualified Data.Map as M
45
import Data.Maybe
46
from Data.NGramIndex import :: NGramIndex, newNGramIndex, index
Camil Staps's avatar
Camil Staps committed
47
import qualified Data.Set as S
48
import Data.Tuple
49 50 51
from Database.Native import :: NativeDB, :: Index(..), newDB,
	instance == Index, instance < Index
import qualified Database.Native as DB
52
import System.Directory
Camil Staps's avatar
Camil Staps committed
53
import System.FilePath
Camil Staps's avatar
Camil Staps committed
54 55
from Text import class Text(concat,indexOf,replaceSubString,startsWith),
	instance Text String, <+
56 57

from compile import :: DclCache{hash_table}, empty_cache
Camil Staps's avatar
Camil Staps committed
58
from Heap import :: Heap, newHeap, sreadPtr
59 60 61
from predef import init_identifiers
from syntax import :: ClassDef{class_args,class_context,class_ident,class_pos},
	:: FileName, :: FunctName, :: FunKind(FK_Macro), :: FunSpecials, :: GCF,
62
	:: GenericCaseDef{gc_gcf,gc_pos,gc_type}, :: GenericCaseFunctions(GCF,GCFC),
Camil Staps's avatar
Camil Staps committed
63 64
	:: GenericDef{gen_ident,gen_pos,gen_type,gen_vars},
	:: Ident{id_name,id_info}, :: LineNr, :: Module{mod_defs,mod_ident},
65
	:: Optional(Yes,No), :: SymbolPtr, :: Ptr, :: SymbolTableEntry,
Camil Staps's avatar
Camil Staps committed
66
	:: ParsedDefinition(PD_Class,PD_Derive,PD_Function,PD_Generic,PD_Instance,
67
		PD_Instances,PD_Type,PD_TypeSpec,PD_GenericCase,
68
		PD_NodeDef,PD_Import),
69 70
	:: ParsedExpr(PE_Ident,PE_List),
	:: ParsedInstance{pi_ident,pi_pos,pi_types},
71
	:: ParsedInstanceAndMembers{pim_pi}, :: ParsedModule, :: ParsedTypeDef,
72
	:: Position(FunPos,LinePos,NoPos), :: Priority, :: Rhs, :: ATypeVar,
73
	:: RhsDefsOfType(ConsList,ExtensibleConses,SelectorList,TypeSpec,EmptyRhs,
74
		AbstractTypeSpec,NewTypeCons,MoreConses),
75 76
	:: SymbolTable, :: SymbolTableEntry, :: SymbolType, :: Type, :: BITVECT,
	:: TypeContext, :: TypeDef{td_ident,td_pos,td_rhs}, :: TypeVar,
Camil Staps's avatar
Camil Staps committed
77
	:: ParsedConstructor{pc_cons_ident}, :: ParsedSelector{ps_field_ident},
78
	:: ParsedImport, :: Import{import_module}
79

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

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

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

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

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

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

235 236 237 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
	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]

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

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

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

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

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

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

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

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

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

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

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

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

445
	castLoc :: String LocationInModule -> 'CDB'.Location
Camil Staps's avatar
Camil Staps committed
446 447
	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
448 449 450

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

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

455
findModuleContents :: !Bool !String !*World
Camil Staps's avatar
Camil Staps committed
456 457 458
	-> *( ![(LocationInModule, 'CDB'.FunctionEntry, 'S'.Set String)]
	    , ![(LocationInModule, 'CDB'.FunctionEntry, 'S'.Set String)]
	    , ![(LocationInModule, 'CDB'.FunctionEntry, 'S'.Set String)]
459
	    , ![(LocationInModule, 'CDB'.TypeDefEntry)]
Camil Staps's avatar
Camil Staps committed
460
	    , ![(LocationInModule, 'CDB'.ClassEntry, [(String, 'CDB'.FunctionEntry, 'S'.Set String)])]
461 462 463
	    , ![('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
464
	    , !('CDB'.Name, 'CDB'.ModuleEntry, 'S'.Set String)
Camil Staps's avatar
Camil Staps committed
465 466
	    , !*World
	    )
467
findModuleContents include_locals path w
468 469 470 471 472 473 474
#! (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
475
			( {zero & me_documentation=docParseResultToMaybe (const True) =<< parseDoc <$> getComment dcl coll}
476 477 478 479
			, dcl.mod_defs
			, coll
			)
#! (icl,w) = readModule (path +++ ".icl") w
Camil Staps's avatar
Camil Staps committed
480
#! (icl,modname) = case icl of
481 482
	Error _ -> ([], "")
	Ok (icl,syms) -> (icl.mod_defs, icl.mod_ident.id_name)
483
#! imports = 'S'.fromList [i.import_module.id_name \\ PD_Import is <- dcl ++ icl, i <- is]
484
#! contents=:(functions,rules,generics,typedefs,clss,insts,derivs,clsderivs) =
485 486 487 488 489 490
	( 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
491
	, combineDerivs (pd_derivations True dcl) (pd_derivations False icl)
492
	, combine cmpClsDeriv joinClsDeriv pd_class_derivations dcl documentation icl
493
	)
494
#! (functions,rules,generics,typedefs,clss,insts,derivs,clsderivs) =
495 496
	if include_locals
	contents
497 498 499
	( filter (hasDcl o fst3)            functions
	, filter (hasDcl o fst3)            rules
	, filter (hasDcl o fst3)            generics
500
	, filter (hasDcl o fst)             typedefs
501
	, filter (hasDcl o fst3)            clss
502 503 504 505
	, 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
506
#! rules = filter (\(r,_,_) -> not $ any (\(l,_,_)->fromJust l.LocationInModule.name == fromJust r.LocationInModule.name) functions) rules
507
= (functions,rules,generics,typedefs,clss,insts,derivs,clsderivs,(modname,dclmod,imports),w)
Camil Staps's avatar
Camil Staps committed
508
where
509
	combine :: (a a -> Bool) (a a -> a)
510 511 512
		(Bool [ParsedDefinition] CollectedComments -> [a])
		![ParsedDefinition] !CollectedComments
		![ParsedDefinition]
513
		-> [a]
514
	combine eq join find dcl dclsym [] // Special case for things like _library.dcl
515
		= find True dcl dclsym
516 517
	combine eq join find dcl dclsym icl
		= unionBy eq join (find True dcl dclsym) (find False icl emptyCollectedComments)
518 519 520 521

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

	cmpLocFst :: ((LocationInModule, a) (LocationInModule, a) -> Bool)
529 530 531 532
	cmpLocFst = cmpLoc `on` fst

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

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

537 538 539
	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
540 541
	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)
542

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

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

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

613 614
	pd_generics :: !Bool ![ParsedDefinition] !CollectedComments -> [(LocationInModule, 'CDB'.FunctionEntry, 'S'.Set String)]
	pd_generics dcl defs comments
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
Camil Staps's avatar
Camil Staps committed
620
		     , fe_documentation=findDoc hideIsUsedReturn gen comments
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]

626 627
	pd_typespecs :: !Bool ![ParsedDefinition] !CollectedComments -> [(LocationInModule, 'CDB'.FunctionEntry, 'S'.Set String)]
	pd_typespecs dcl defs comments
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
Camil Staps's avatar
Camil Staps committed
633
		     , fe_documentation = findDoc hideIsUsedReturn ts comments
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] CollectedComments -> [('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] CollectedComments -> [('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]

651 652
	pd_classes :: !Bool ![ParsedDefinition] !CollectedComments -> [(LocationInModule, 'CDB'.ClassEntry, [(String, 'CDB'.FunctionEntry, 'S'.Set String)])]
	pd_classes dcl defs comments
653
		= [ let
654 655
		      typespecs = pd_typespecs True clsdefs comments
		      macros = [(n,(r,ids)) \\ ({LocationInModule | name=Just n},{fe_representation=Just r},ids) <- pd_rewriterules dcl clsdefs comments]
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
		          , fe_documentation=if (isSingleFunction typespecs id)
Camil Staps's avatar
Camil Staps committed
661
		              ((\d -> {FunctionDoc | d & vars=[]}) <$> findDoc hideIsUsedReturn pd comments)
662 663
		              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)
Camil Staps's avatar
Camil Staps committed
671
		         (parseClassDoc typespecs pd comments)
672
		       , members
673
		       )
Camil Staps's avatar
Camil Staps committed
674
		  \\ pd=:(PD_Class {class_ident=id=:{id_name},class_pos,class_args,class_context} clsdefs) <- defs
675
		  ]
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.
Camil Staps's avatar
Camil Staps committed
681 682
		parseClassDoc :: [(LocationInModule, 'CDB'.FunctionEntry, a)] ParsedDefinition !CollectedComments -> Maybe ClassDoc
		parseClassDoc members pd=:(PD_Class {class_ident=id} _) comments
683
		| isSingleFunction members id = flip addClassMemberDoc
Camil Staps's avatar
Camil Staps committed
684 685
			(functionToClassMemberDoc <$> findDoc hideIsUsedReturn pd comments)
			<$> findDoc hideFunctionOnClass pd comments
686
		| otherwise = flip (foldl addClassMemberDoc)
687
			[functionToClassMemberDoc <$> fe.fe_documentation \\ (_,fe,_) <- members]
Camil Staps's avatar
Camil Staps committed
688
			<$> findDoc hideIsUsedReturn pd comments
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 700
	pd_types :: !Bool ![ParsedDefinition] !CollectedComments -> [(LocationInModule, 'CDB'.TypeDefEntry)]
	pd_types dcl defs comments
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{|*|} $
Camil Staps's avatar
Camil Staps committed
704 705
				findDoc (const True) pd comments
			) \\ pd=:(PD_Type ptd) <- defs, td <- ['T'.toTypeDef ptd]]
706
	where
707 708 709 710 711 712 713 714 715 716 717
		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
718
			d = parseSingleLineDoc <$> getComment ps comments
719 720

		addConses :: ![ParsedConstructor] !TypeDoc -> TypeDoc
721
		addConses [] doc
722 723 724 725
			= {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
726
			d = docParseResultToMaybe (const True) =<< parseDoc <$> getComment pc comments
727

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

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

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

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

746 747 748
	isUsedReturn :: ParseWarning -> Bool
	isUsedReturn UsedReturn = True; isUsedReturn _ = False

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

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

Camil Staps's avatar
Camil Staps committed
772
record_functions :: !'CDB'.TypeDefEntry -> ['CDB'.FunctionEntry]
Camil Staps's avatar
Camil Staps committed
773 774 775 776 777 778 779 780 781 782
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]
783
where
784
	field_doc = fromMaybe [] (docFields =<< 'CDB'.getTypeDefDoc etd) ++ repeat Nothing
785 786 787

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
788 789

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