Commit f7d39332 authored by Camil Staps's avatar Camil Staps
Browse files

Add derivations and meta-class instances

parent 63597317
......@@ -85,10 +85,11 @@ derive JSONDecode CloogleEntry
* A TypeDef with meta-data
*/
:: TypeDefEntry
= { tde_loc :: !Location //* The location
, tde_typedef :: !TypeDef //* The TypeDef
, tde_doc :: !Maybe TypeDoc //* Documentation on the TypeDef
, tde_instances :: ![Index] //* Instances of this type
= { tde_loc :: !Location //* The location
, tde_typedef :: !TypeDef //* The TypeDef
, tde_doc :: !Maybe TypeDoc //* Documentation on the TypeDef
, tde_instances :: ![Index] //* Instances of this type
, tde_derivations :: ![Index] //* Derivations of this type
}
/**
......@@ -108,6 +109,7 @@ derive JSONDecode CloogleEntry
= { ce_loc :: !Location //* The location
, ce_vars :: ![String] //* The type variables of the class
// Using TypeVar causes import clashes in CloogleDBFactory
, ce_is_meta :: !Bool //* Whether this is a meta class (no non-macro members and not TC)
, ce_context :: !TypeContext //* A class context
, ce_documentation :: !Maybe ClassDoc //* Documentation on this class
, ce_members :: ![Index] //* Class members (FunctionEntries)
......@@ -119,16 +121,17 @@ derive JSONDecode CloogleEntry
* Information about a class instance
*/
:: InstanceEntry
= { ie_class :: !Name //* The class
, ie_types :: ![(Type, String)] //* The instantiated type and a string representation for each class variable
, ie_locations :: ![Location] //* The places where this instance is found
= { ie_class :: Name //* The class
, ie_types :: [(Type, String)] //* The instantiated type and a string representation for each class variable
, ie_locations :: [Location] //* The places where this instance is found
}
/**
* Information about a generic derivation
*/
:: DeriveEntry
= { de_type :: !Type //* The type to derive an instance for
= { de_generic :: !Name //* The generic
, de_type :: !Type //* The type to derive an instance for
, de_type_representation :: !String //* A string representation of the type
, de_locations :: ![Location] //* The locations in which the derivation occurs
, de_isclass :: !Bool //* Whether this is a class derivation
......@@ -193,11 +196,13 @@ mergeTypeDefEntries :: TypeDefEntry TypeDefEntry -> TypeDefEntry
*
* @param The location of the class
* @param The type variables of the class
* @param Whether this is a meta class
* @param The class context
* @param The documentation
* @result A Class record with those data
*/
toClass :: Location [String] TypeContext (Maybe ClassDoc) -> ClassEntry
toClass :: Location [String] Bool TypeContext (Maybe ClassDoc) -> ClassEntry
classContext :: ClassEntry -> [TypeRestriction]
/**
* Synchronise the database. Should be called after updating data, to update
......
......@@ -196,6 +196,7 @@ toTypeDefEntry loc td doc =
, tde_typedef=td
, tde_doc=doc
, tde_instances=[]
, tde_derivations=[]
}
getTypeDef :: TypeDefEntry -> TypeDef
......@@ -210,10 +211,11 @@ mergeTypeDefEntries a=:{tde_typedef={td_rhs=TDRAbstract Nothing}} b = case b.tde
rhs -> {a & tde_typedef.td_rhs=TDRAbstract (Just rhs)}
mergeTypeDefEntries a b = b
toClass :: Location [String] TypeContext (Maybe ClassDoc) -> ClassEntry
toClass loc vs cc doc
toClass :: Location [String] Bool TypeContext (Maybe ClassDoc) -> ClassEntry
toClass loc vs meta cc doc
= { ce_loc = loc
, ce_vars = vs
, ce_is_meta = meta
, ce_context = cc
, ce_documentation = doc
, ce_members = []
......@@ -221,6 +223,9 @@ toClass loc vs cc doc
, ce_derivations = []
}
classContext :: ClassEntry -> [TypeRestriction]
classContext ce = ce.ce_context
syncDB :: !Int !*CloogleDB -> *CloogleDB
syncDB _ db = db
......
......@@ -74,13 +74,15 @@ from CloogleDB import
:: CloogleEntry(..),
:: ModuleEntry{me_loc,me_is_core,me_is_app,me_documentation},
:: FunctionEntry{fe_loc,fe_type,fe_kind,fe_generic_vars,fe_priority,fe_representation,fe_documentation,fe_class},
:: TypeDefEntry{tde_loc,tde_instances},
:: ClassEntry{ce_loc,ce_instances},
:: TypeDefEntry{tde_loc,tde_instances,tde_derivations},
:: ClassEntry{ce_loc,ce_instances,ce_is_meta}, classContext, :: TypeRestriction,
:: SyntaxEntry, :: DeriveEntry,
:: InstanceEntry{ie_class,ie_types,ie_locations},
:: DeriveEntry{..},
instance zero FunctionEntry, instance zero ModuleEntry,
class getLocation, instance getLocation CloogleEntry,
instance == Location
from Cloogle import instance == FunctionKind
from Doc import :: ModuleDoc, :: FunctionDoc{..}, :: ClassDoc, :: TypeDoc{..},
:: ConstructorDoc, :: ClassMemberDoc, :: Description,
:: ParseWarning(UsedReturn,IllegalField), :: ParseError,
......@@ -128,12 +130,31 @@ finaliseDb extra tdb =
, module_map = modmap
}
where
entries = map link $
entries = [link e \\ Right e <- entries`]
where
link :: CloogleEntry -> CloogleEntry
link (TypeDefEntry tde) = TypeDefEntry
{ tde
& tde_instances=idxfilter \e -> case e of
InstanceEntry ie -> not $ isEmpty [() \\ 'T'.Type t _ <- concatMap ('T'.subtypes o fst) ie.ie_types | t == 'CDB'.getName tde.tde_loc]
_ -> False
, tde_derivations=idxfilter \e -> case e of
DeriveEntry {de_type='T'.Type t _} -> t == 'CDB'.getName tde.tde_loc
_ -> False
}
link (ClassEntry ce) = ClassEntry
{ ce
& ce_instances=idxfilter \e -> case e of
InstanceEntry ie -> ie.ie_class == 'CDB'.getName ce.ce_loc
_ -> False
}
link e = e
entries` = map Right (
extra ++
[FunctionEntry fun \\ funs <- tdb.temp_functions, fun <- funs] ++
[TypeDefEntry tde \\ tds <- tdb.temp_types, tde <- tds] ++
[ModuleEntry mod \\ mod <- tdb.temp_modules] ++
[ClassEntry cls \\ clss <- tdb.temp_classes, (cls,_) <- clss] ++
map ClassEntry classes ++
[FunctionEntry
{ fun
& fe_kind=case fun.fe_kind of Function -> ClassMember; Macro -> ClassMacro
......@@ -143,25 +164,53 @@ where
_ -> False
}
\\ clss <- tdb.temp_classes, (cls,funs) <- clss, (fname,fun) <- funs] ++
// Normal instances
[InstanceEntry {ie_class=cls,ie_types=types,ie_locations=map thd3 is}
\\ is=:[(cls,types,_):_] <- groupBy instanceEq
$ sortBy ((<) `on` (\(c,ts,_) -> (c,map snd ts)))
$ flatten tdb.temp_instances]
$ flatten tdb.temp_instances] ++
// Derivations
[DeriveEntry {de_generic=gn, de_type=t, de_type_representation=tr, de_locations=map fth4 ds, de_isclass=False}
\\ 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]] ++
[DeriveEntry {de_generic=gn, de_type=t, de_type_representation=tr, de_locations=map fth4 ds, de_isclass=True}
\\ ds=:[(gn,t,tr,_):_] <- groupBy ((==) `on` (\(g,_,tr,_) -> (g,tr)))
$ sortBy ((<) `on` (\(g,_,tr,_) -> (g,tr)))
$ flatten tdb.temp_class_derivations]) ++
// Meta-class instances
concatMap metainstances classes
where
link :: CloogleEntry -> CloogleEntry
link (TypeDefEntry tde) = TypeDefEntry
{ tde
& tde_instances=idxfilter \e -> case e of
InstanceEntry ie -> not $ isEmpty [() \\ 'T'.Type t [] <- concatMap ('T'.subtypes o fst) ie.ie_types | t == 'CDB'.getName tde.tde_loc]
_ -> False
}
link (ClassEntry ce) = ClassEntry
{ ce
& ce_instances=idxfilter \e -> case e of
InstanceEntry ie -> ie.ie_class == 'CDB'.getName ce.ce_loc
_ -> False
}
link e = e
metainstances :: ClassEntry -> [Either String CloogleEntry]
metainstances {ce_is_meta=False} = []
metainstances ce = [Left cls:[Right $ InstanceEntry {ie_class=cls,ie_types=[(t,tr)],ie_locations=locs} \\ (t,tr,locs) <- types`]]
where
crestrs = [c \\ 'T'.Instance c ['T'.Var _] <- classContext ce | c <> "TC"] // TC class is implicit
grestrs = [g \\ 'T'.Derivation g ('T'.Var _) <- classContext ce]
ctypes = [[(hd ie.ie_types,ie.ie_locations) \\ InstanceEntry ie <- entries | ie.ie_class == c && length ie.ie_types == 1] \\ c <- crestrs]
gtypes = [[((de.de_type,de.de_type_representation),de.de_locations) \\ DeriveEntry de <- entries | de.de_generic == g] \\ g <- grestrs]
types = case ctypes ++ gtypes of
[] -> []
ts -> foldr1 intersect $ map (map fst) ts
types` = [(t,tr,flatten [locs \\ rts <- ctypes ++ gtypes, ((t`,_),locs) <- rts | t == t`]) \\ (t,tr) <- types]
cls = 'CDB'.getName ce.ce_loc
// Ideally we would use entries, but that causes a cycle in spine.
// So we use entries up to the point where the class itself is defined.
// This requires keeping an Either where Left holds the class under evaluation.
// It also requires sorting the classes, see below with contextOrd.
entries = [e \\ Right e <- takeWhile (\e -> case e of
Left c -> c <> cls
Right _ -> True) entries`]
classes = sortBy contextOrd [cls \\ clss <- tdb.temp_classes, (cls,_) <- clss]
where
contextOrd :: ClassEntry ClassEntry -> Bool
contextOrd a b = isMember aname [c \\ 'T'.Instance c _ <- classContext b]
where [aname,bname:_] = map 'CDB'.getName [a.ce_loc,b.ce_loc]
instanceEq :: (String, [('CDB'.Type, a)], b) (String, [('CDB'.Type, a)], b) -> Bool
instanceEq (s, ts, _) (s2, ts2, _) = s == s2 && map fst ts == map fst ts2
entridxs = zip2 [Index i \\ i <- [0..]] entries
idxfilter f = [idx \\ (idx,e) <- entridxs | f e]
......@@ -193,9 +242,6 @@ where
Just m` -> m == m`) \\ m <- mods]
where mods = removeDup [fromJust ('CDB'.getModule me.me_loc) \\ me <- tdb.temp_modules]
instanceEq :: (String, [('CDB'.Type, a)], b) (String, [('CDB'.Type, a)], b) -> Bool
instanceEq (s, ts, _) (s2, ts2, _) = s == s2 && map fst ts == map fst ts2
// Exclude Root Library Aux Base module
findModules :: ![String] !String !'CDB'.Library !a !String !*World
-> *(![('CDB'.Library, 'CDB'.Module, a)], !*World)
......@@ -466,13 +512,15 @@ where
((\d -> {FunctionDoc | d & vars=[]}) <$> findDoc hideIsUsedReturn id st)
fe.fe_documentation
}
members = [(f,updateRepresentation f et) \\ ({name=Just f}, et) <- typespecs]
in ( setLine dcl class_pos {zero & name=Just id_name}
, 'CDB'.toClass
NoLocation
(map 'T'.toTypeVar class_args)
(all (\(_,fe) -> fe.fe_kind == Macro) members)
(flatten $ map 'T'.toTypeContext class_context)
(parseClassDoc typespecs id st)
, [(f,updateRepresentation f et) \\ ({name=Just f}, et) <- typespecs]
, members
)
\\ PD_Class {class_ident=id=:{id_name},class_pos,class_args,class_context} clsdefs <- defs
]
......@@ -613,3 +661,5 @@ where
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
fth4 (a,b,c,d) :== d
......@@ -125,12 +125,14 @@ makeResult orgsearchtype tdes usedsyns (entry, annots) db
| entry =: (TypeDefEntry _)
# (TypeDefEntry tde) = entry
# (insts,db) = getIndices tde.tde_instances db
# (derivs,db) = getIndices tde.tde_derivations db
= (TypeResult (general,
{ type = concat $ print False tde.tde_typedef
, type_instances = sortBy ((<) `on` fst3)
[(ie.ie_class, map snd ie.ie_types, map locResult ie.ie_locations)
\\ {value=InstanceEntry ie} <- insts]
, type_derivations = [] // TODO
, type_derivations = sortBy ((<) `on` fst)
[(de.de_generic, map locResult de.de_locations) \\ {value=DeriveEntry de} <- derivs]
, type_field_doc = docFields =<< tde.tde_doc
, type_constructor_doc = map ((=<<) docDescription) <$> (docConstructors =<< tde.tde_doc)
, type_representation_doc = join (docRepresentation =<< tde.tde_doc)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment