Verified Commit bcf47e56 authored by Camil Staps's avatar Camil Staps 🚀

Merge branch 'function-usages'

parents e12095f1 7c5e0a80
Subproject commit 1a9e842bb4c58ec4ff270b843d878f3fce8e0c22
Subproject commit 25b5f828ddb77a10482ba69b5f35f34c45779cc8
Subproject commit 14b0de79519cdaf0830f6b4f8051bca068e4c673
Subproject commit d052c6fb6fcbff6316f913892f310ce476e5bf0b
......@@ -102,6 +102,7 @@ derive JSONDecode CloogleEntry
, fe_documentation :: !Maybe FunctionDoc //* Documentation on this entry
, fe_class :: !Maybe Index //* The class, for class members
, fe_derivations :: !Maybe [Index] //* The DerivaionEntries
, fe_usages :: ![Index] //* FunctionEntries where the implementation uses this function
}
/**
......
......@@ -98,6 +98,7 @@ where
, fe_documentation = Nothing
, fe_class = Nothing
, fe_derivations = Nothing
, fe_usages = []
}
instance zero ModuleEntry
......@@ -456,9 +457,11 @@ filterUsages names wrap=:{db,name_map}
# db = 'DB'.searchIndices Intersect (sort [(i,[(ExactResult,1)]) \\ is <- idxss, i <- is]) db
// For all lists of entries, the corresponding usages
# (entriess,db) = mapSt 'DB'.getIndices idxss db
# usagess = map (foldr1 mergeUnion o map \e -> getUsages e.value) entriess
# usagess = map (foldr mergeUnion [] o map \e -> getUsages e.value) entriess
// AND all usages together
# usages = foldr1 mergeIntersect usagess
# usages = case usagess of
[] -> []
us -> foldr1 mergeIntersect us
# db = 'DB'.searchIndices AddExcluded [(u,[]) \\ u <- usages] db
= {wrap & db=db}
where
......@@ -466,6 +469,7 @@ where
getUsages (TypeDefEntry tde) = tde.tde_usages
getUsages (ClassEntry ce) = ce.ce_usages
getUsages (ModuleEntry me) = me.me_usages
getUsages (FunctionEntry fe) = fe.fe_usages
getUsages _ = []
// Efficient union on sorted lists
......
......@@ -4,6 +4,8 @@ definition module CloogleDBFactory
* Functions to populate a database using the Clean compiler frontend
*/
from Data.Set import :: Set
import CloogleDB
:: TemporaryDB
......@@ -69,15 +71,15 @@ indexModule :: !Bool !String !Module !Library
* - The module
*/
findModuleContents :: !Bool !String !*World
-> *( ![(LocationInModule, FunctionEntry)]
, ![(LocationInModule, FunctionEntry)]
, ![(LocationInModule, FunctionEntry)]
-> *( ![(LocationInModule, FunctionEntry, Set String)]
, ![(LocationInModule, FunctionEntry, Set String)]
, ![(LocationInModule, FunctionEntry, Set String)]
, ![(LocationInModule, TypeDefEntry)]
, ![(LocationInModule, ClassEntry, [(String, FunctionEntry)])]
, ![(LocationInModule, ClassEntry, [(String, FunctionEntry, Set String)])]
, ![(Name, [(Type, String)], LocationInModule)]
, ![(Name, [(Type, String, LocationInModule)])]
, ![(Name, Type, String, LocationInModule)]
, !(Name, ModuleEntry, [String])
, !(Name, ModuleEntry, Set String)
, !*World
)
......
......@@ -23,10 +23,11 @@ import Data.List
from Data.Map import :: Map
import qualified Data.Map as M
import Data.Maybe
import qualified Data.Set as S
import Data.Tuple
import System.Directory
import System.FilePath
from Text import class Text(concat,indexOf,replaceSubString), instance Text String
from Text import class Text(concat,indexOf,replaceSubString), instance Text String, <+
import CleanPrettyPrint
......@@ -95,16 +96,18 @@ from Doc import :: ModuleDoc, :: FunctionDoc{..}, :: ClassDoc, :: TypeDoc{..},
class docFields(..), instance docFields TypeDoc,
traceParseError, traceParseWarnings,
constructorToFunctionDoc, functionToClassMemberDoc, addClassMemberDoc
import Idents
:: TemporaryDB
= { temp_functions :: ![['CDB'.FunctionEntry]]
, temp_classes :: ![[('CDB'.ClassEntry, [(String, 'CDB'.FunctionEntry)])]]
= { temp_functions :: ![[('CDB'.FunctionEntry, 'S'.Set String)]]
, temp_classes :: ![[('CDB'.ClassEntry, [(String, 'CDB'.FunctionEntry, 'S'.Set String)])]]
, 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)]]
, temp_modules :: ![(ModuleEntry, [String])]
, temp_modules :: ![(ModuleEntry, 'S'.Set String)]
}
// TODO function usages in instances/derivations
newTemporaryDB :: TemporaryDB
newTemporaryDB
......@@ -117,9 +120,30 @@ newTemporaryDB
, temp_modules = []
}
instance < (Maybe a) | < a
where
< (Just x) (Just y) = x < y
< (Just _) Nothing = True
< _ _ = False
instance < Location
where
< (Location l1 m1 _ d1 i1 n1) (Location l2 m2 _ d2 i2 n2)
= ((l1,m1,n1),(d1,i1)) < ((l2,m2,n2), (d2,i2))
< (Location _ _ _ _ _ _) _
= True
< _ (Location _ _ _ _ _ _)
= False
< (Builtin a _) (Builtin b _)
= a < b
< (Builtin _ _) _
= True
< _ _
= False
finaliseDB :: ![CloogleEntry] !TemporaryDB -> *'CDB'.CloogleDB
finaliseDB extra tdb =
{ db = newDB entries
{ db = 'DB'.mapInPlace link $ newDB entries
, name_ngrams = foldr (uncurry index) (newNGramIndex 3 True)
[('CDB'.getName loc, i) \\ (i,e) <- entridxs, Just loc <- ['CDB'.getLocation e]]
, name_map = foldr (\(name,i) -> flip 'M'.alter name \is -> case is of
......@@ -146,10 +170,9 @@ finaliseDB extra tdb =
, always_unique = always_unique
}
where
entries = [link i e \\ Right e <- filter (\e -> e=:(Right _)) entries` & i <- [0..]]
where
link :: Int CloogleEntry -> CloogleEntry
link _ (TypeDefEntry tde) = TypeDefEntry
link :: !Int !CloogleEntry -> CloogleEntry
link i e = trace_n ("Linking #" <+ i <+ fromMaybe "" ((\loc -> ": " <+ 'CDB'.getName loc) <$> 'CDB'.getLocation e)) case e of
TypeDefEntry tde -> TypeDefEntry
{ tde
& tde_instances=idxfilter \e -> case e of
InstanceEntry ie -> case name of
......@@ -166,7 +189,7 @@ where
_ -> False
}
with name = 'T'.td_name $ 'CDB'.getTypeDef tde
link i (ClassEntry ce) = ClassEntry
ClassEntry ce -> ClassEntry
{ ce
& ce_instances=idxfilter \e -> case e of
InstanceEntry ie -> ie.ie_class == name
......@@ -174,7 +197,7 @@ where
, ce_members=idxfilter \e -> case e of
FunctionEntry fe -> fe.fe_class == Just (Index i)
_ -> False
, ce_usages=idxfilter` \e -> or [cls == name \\ 'T'.Instance cls _ <- context e]
, ce_usages=idxfilter \e -> or [cls == name \\ 'T'.Instance cls _ <- context e]
}
with
name = 'CDB'.getName ce.ce_loc
......@@ -186,38 +209,34 @@ where
| name == 'CDB'.getName ce.ce_loc = []
| otherwise = classContext ce
context _ = []
link _ (FunctionEntry fe=:{fe_derivations=Just _}) = FunctionEntry
FunctionEntry fe -> FunctionEntry
{ fe
& fe_derivations=Just $ idxfilter \e -> case e of
DeriveEntry de -> de.de_generic == 'CDB'.getName fe.fe_loc
_ -> False
& fe_derivations=case fe.fe_derivations of
Nothing -> Nothing
Just _ -> Just $ idxfilter \e -> case e of
DeriveEntry de -> de.de_generic == name
_ -> False
, fe_usages=fromMaybe [] ('M'.get ('CDB'.getName fe.fe_loc) global_functions_map)
}
link _ (ModuleEntry me) = ModuleEntry
with name = 'CDB'.getName fe.fe_loc
ModuleEntry me -> ModuleEntry
{ me
& me_usages=idxfilter` \e -> case e of
& me_usages=idxfilter \e -> case e of
ModuleEntry me -> case find (\(mod,_) -> mod.me_loc == me.me_loc) tdb.temp_modules of
Nothing -> False
Just (_,imps) -> isMember name imps
Just (_,imps) -> 'S'.member name imps
_ -> False
}
where
name = 'CDB'.getName me.me_loc
link _ e = e
with name = 'CDB'.getName me.me_loc
e -> e
entries = [e \\ Right e <- entries`]
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] ++
map ClassEntry classes ++
[FunctionEntry
{ fun
& fe_kind=case fun.fe_kind of Function -> ClassMember; Macro -> ClassMacro
, fe_loc='CDB'.setName fname cls.ce_loc
, fe_class=Just $ idxhd \ce -> case ce of
ClassEntry ce -> ce.ce_loc == cls.ce_loc
_ -> False
}
\\ clss <- tdb.temp_classes, (cls,funs) <- clss, (fname,fun) <- funs] ++
map (FunctionEntry o fst) function_entries ++
// Normal instances
[InstanceEntry {ie_class=cls,ie_types=types,ie_locations=map thd3 is}
\\ is=:[(cls,types,_):_] <- groupBy instanceEq
......@@ -266,13 +285,30 @@ where
instanceEq :: (String, [('CDB'.Type, a)], b) (String, [('CDB'.Type, a)], b) -> Bool
instanceEq (s, ts, _) (s2, ts2, _) = s == s2 && all (uncurry (isomorphic_to)) (zip2 (map fst ts) (map fst ts2))
global_functions_map = 'M'.fromList
$ map (\gidxs=:[(g,_):_] -> (g,map snd gidxs))
$ groupBy ((==) `on` fst)
$ sortBy ((<) `on` fst)
$ flatten
[[(g,idx) \\ g <- removeDup ('S'.toList globs)] // TODO remove removeDup when Data.Set difference is fixed
\\ idx <- fidxs
& (fe,globs) <- [(fe, 'S'.newSet) \\ FunctionEntry fe <- extra] ++ function_entries]
where
fidxs = [idx \\ (idx,FunctionEntry _) <- entridxs]
function_entries = flatten tdb.temp_functions ++ [(
{ fun
& fe_kind=case fun.fe_kind of Function -> ClassMember; Macro -> ClassMacro
, fe_loc='CDB'.setName fname cls.ce_loc
, fe_class=Just $ idxhd \ce -> case ce of
ClassEntry ce -> ce.ce_loc == cls.ce_loc
_ -> False
}, ids) \\ clss <- tdb.temp_classes, (cls,funs) <- clss, (fname,fun,ids) <- funs]
entridxs = zip2 [Index i \\ i <- [0..]] entries
idxfilter f = [idx \\ (idx,e) <- entridxs | f e]
idxhd = hd o idxfilter
// WARNING: indexes may be wrong after meta-instances due to the use of Left
idxfilter` f = [idx \\ (idx,Right e) <- zip2 [Index i \\ i <- [0..]] entries` | f e]
coreidxs = idxfilter \e -> case 'CDB'.getLocation e of
Nothing -> False
Just l -> case ('CDB'.getLibrary l, 'CDB'.getModule l) of
......@@ -356,8 +392,8 @@ indexModule include_locals root mod lib modf db w
#! db =
{ db
& temp_functions =
[ [{f & fe_loc=castLoc modname loc} \\ (loc,f) <- functions ++ macros ++ generics]
, [f \\ td <- typedefs, f <- constructor_functions td ++ record_functions td]
[ [({f & fe_loc=castLoc modname loc},idents) \\ (loc,f,idents) <- functions ++ macros ++ generics]
, [(f, 'S'.newSet) \\ td <- typedefs, f <- constructor_functions td ++ record_functions td]
: db.temp_functions
]
, temp_classes = [[({ce & ce_loc=castLoc modname loc}, fs) \\ (loc,ce,fs) <- clss]:db.temp_classes]
......@@ -384,15 +420,15 @@ instance zero LocationInModule
where zero = {dcl_line=Nothing, icl_line=Nothing, name=Nothing}
findModuleContents :: !Bool !String !*World
-> *( ![(LocationInModule, 'CDB'.FunctionEntry)]
, ![(LocationInModule, 'CDB'.FunctionEntry)]
, ![(LocationInModule, 'CDB'.FunctionEntry)]
-> *( ![(LocationInModule, 'CDB'.FunctionEntry, 'S'.Set String)]
, ![(LocationInModule, 'CDB'.FunctionEntry, 'S'.Set String)]
, ![(LocationInModule, 'CDB'.FunctionEntry, 'S'.Set String)]
, ![(LocationInModule, 'CDB'.TypeDefEntry)]
, ![(LocationInModule, 'CDB'.ClassEntry, [(String, 'CDB'.FunctionEntry)])]
, ![(LocationInModule, 'CDB'.ClassEntry, [(String, 'CDB'.FunctionEntry, 'S'.Set String)])]
, ![('CDB'.Name, [('CDB'.Type, String)], LocationInModule)]
, ![('CDB'.Name, [('CDB'.Type, String, LocationInModule)])]
, ![('CDB'.Name, 'CDB'.Type, String, LocationInModule)]
, !('CDB'.Name, 'CDB'.ModuleEntry, [String])
, !('CDB'.Name, 'CDB'.ModuleEntry, 'S'.Set String)
, !*World
)
findModuleContents include_locals path w
......@@ -402,30 +438,30 @@ findModuleContents include_locals path w
Right dcl -> (dcl.mod_defs, dcl.mod_ident.id_name)
#! (icl,icl_symbols,w) = readModule True w
#! icl = case icl of Left _ -> []; Right icl -> icl.mod_defs
#! imports = [i.import_module.id_name \\ PD_Import is <- icl, i <- is]
#! imports = 'S'.fromList [i.import_module.id_name \\ PD_Import is <- icl, i <- is]
#! contents=:(functions,rules,generics,typedefs,clss,insts,derivs,clsderivs) =
( combine cmpLocFst joinLocFst pd_typespecs dcl dcl_symbols icl icl_symbols
, combine cmpLocFst joinLocFst pd_rewriterules dcl dcl_symbols icl icl_symbols
, combine cmpLocFst joinLocFst pd_generics dcl dcl_symbols icl icl_symbols
, combine cmpLocFst joinTypeDefs pd_types dcl dcl_symbols icl icl_symbols
, combine cmpLocFst3 joinLocFst3 pd_classes dcl dcl_symbols icl icl_symbols
, combine cmpInsts joinInsts pd_instances dcl dcl_symbols icl icl_symbols
( combine cmpLocFst3 joinLocFstIds pd_typespecs dcl dcl_symbols icl icl_symbols
, combine cmpLocFst3 joinLocFstIds pd_rewriterules dcl dcl_symbols icl icl_symbols
, combine cmpLocFst3 joinLocFstIds pd_generics dcl dcl_symbols icl icl_symbols
, combine cmpLocFst joinTypeDefs pd_types dcl dcl_symbols icl icl_symbols
, combine cmpLocFst3 joinLocFst3 pd_classes dcl dcl_symbols icl icl_symbols
, combine cmpInsts joinInsts pd_instances dcl dcl_symbols icl icl_symbols
, combineDerivs (pd_derivations True dcl) (pd_derivations False icl)
, combine cmpClsDeriv joinClsDeriv pd_class_derivations dcl dcl_symbols icl icl_symbols
)
#! (functions,rules,generics,typedefs,clss,insts,derivs,clsderivs) =
if include_locals
contents
( filter (hasDcl o fst) functions
, filter (hasDcl o fst) rules
, filter (hasDcl o fst) generics
( filter (hasDcl o fst3) functions
, filter (hasDcl o fst3) rules
, filter (hasDcl o fst3) generics
, filter (hasDcl o fst) typedefs
, filter (hasDcl o fst3) clss
, 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
#! rules = filter (\(r,_) -> not $ any (\(l,_)->fromJust l.name == fromJust r.name) functions) rules
#! rules = filter (\(r,_,_) -> not $ any (\(l,_,_)->fromJust l.name == fromJust r.name) functions) rules
= (functions,rules,generics,typedefs,clss,insts,derivs,clsderivs,(modname,pd_module dcl,imports),w)
where
combine :: (a a -> Bool) (a a -> a)
......@@ -459,6 +495,9 @@ where
joinLocFst3 :: (LocationInModule, a, b) (LocationInModule, c, d) -> (LocationInModule, a, b)
joinLocFst3 (l1,a,b) (l2,_,_) = (joinLoc l1 l2, a, b)
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)
joinTypeDefs :: (LocationInModule, 'CDB'.TypeDefEntry) (LocationInModule, 'CDB'.TypeDefEntry) -> (LocationInModule, 'CDB'.TypeDefEntry)
joinTypeDefs (a,t) (b,u) = (joinLoc a b, 'CDB'.mergeTypeDefEntries t u)
......@@ -492,7 +531,7 @@ where
}
pd_module _ = zero
pd_rewriterules :: !Bool ![ParsedDefinition] SymbolTable -> [(LocationInModule, 'CDB'.FunctionEntry)]
pd_rewriterules :: !Bool ![ParsedDefinition] SymbolTable -> [(LocationInModule, 'CDB'.FunctionEntry, 'S'.Set String)]
pd_rewriterules dcl defs st
= [( setLine dcl pos {zero & name=Just id.id_name}
, let doc = findDoc hideIsUsedReturn id st in
......@@ -504,6 +543,7 @@ where
, fe_priority=findPrio id >>= 'T'.toMaybePriority
, fe_documentation=doc
}
, (idents ICExpression pd).globals
) \\ pd=:(PD_Function pos id isinfix args rhs _) <- defs]
where
priostring :: Ident ParsedDefinition -> String
......@@ -534,7 +574,7 @@ where
\\ gcdefs <- [ds \\ PD_Derive ds <- defs] ++ [[d] \\ PD_GenericCase d _ <- defs]
, {gc_type,gc_pos,gc_gcf=GCF id _} <- gcdefs]
pd_generics :: !Bool ![ParsedDefinition] SymbolTable -> [(LocationInModule, 'CDB'.FunctionEntry)]
pd_generics :: !Bool ![ParsedDefinition] SymbolTable -> [(LocationInModule, 'CDB'.FunctionEntry, 'S'.Set String)]
pd_generics dcl defs st
= [( setLine dcl gen_pos {zero & name=Just id_name}
, { zero
......@@ -544,9 +584,10 @@ where
, fe_documentation=findDoc hideIsUsedReturn id st
, fe_derivations=Just []
}
, 'S'.newSet
) \\ gen=:(PD_Generic {gen_ident=id=:{id_name},gen_pos,gen_type,gen_vars}) <- defs]
pd_typespecs :: !Bool ![ParsedDefinition] SymbolTable -> [(LocationInModule, 'CDB'.FunctionEntry)]
pd_typespecs :: !Bool ![ParsedDefinition] SymbolTable -> [(LocationInModule, 'CDB'.FunctionEntry, 'S'.Set String)]
pd_typespecs dcl defs st
= [( setLine dcl pos {zero & name=Just id_name}
, { zero
......@@ -555,6 +596,7 @@ where
, fe_representation = Just $ cpp ts
, fe_documentation = findDoc hideIsUsedReturn id st
}
, (idents ICExpression [pd \\ pd=:(PD_Function _ id _ _ _ _) <- defs | id.id_name == id_name]).globals
) \\ ts=:(PD_TypeSpec pos id=:{id_name} p (Yes t) funspecs) <- defs]
pd_class_derivations :: !Bool ![ParsedDefinition] SymbolTable -> [('CDB'.Name, 'CDB'.Type, String, LocationInModule)]
......@@ -570,25 +612,25 @@ where
[(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]
pd_classes :: !Bool ![ParsedDefinition] SymbolTable -> [(LocationInModule, 'CDB'.ClassEntry, [(String, 'CDB'.FunctionEntry)])]
pd_classes :: !Bool ![ParsedDefinition] SymbolTable -> [(LocationInModule, 'CDB'.ClassEntry, [(String, 'CDB'.FunctionEntry, 'S'.Set String)])]
pd_classes dcl defs st
= [ let
typespecs = pd_typespecs True clsdefs st
macros = [(n,r) \\ ({name=Just n},{fe_representation=Just r}) <- pd_rewriterules dcl clsdefs st]
macros = [(n,(r,ids)) \\ ({name=Just n},{fe_representation=Just r},ids) <- pd_rewriterules dcl clsdefs st]
updateRepresentation n fe
= { fe
& fe_kind=if (isNothing $ lookup n macros) fe.fe_kind Macro
, fe_representation=lookup n macros <|> fe.fe_representation
, fe_representation=(fst <$> lookup n macros) <|> fe.fe_representation
, fe_documentation=if (isSingleFunction typespecs id)
((\d -> {FunctionDoc | d & vars=[]}) <$> findDoc hideIsUsedReturn id st)
fe.fe_documentation
}
members = [(f,updateRepresentation f et) \\ ({name=Just f}, et) <- typespecs]
members = [(f,updateRepresentation f et,ids) \\ ({name=Just f}, et, ids) <- 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)
(all (\(_,fe,_) -> fe.fe_kind == Macro) members)
(flatten $ map 'T'.toTypeContext class_context)
(parseClassDoc typespecs id st)
, members
......@@ -600,18 +642,18 @@ where
// 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.
parseClassDoc :: [(LocationInModule, 'CDB'.FunctionEntry)] Ident SymbolTable -> Maybe ClassDoc
parseClassDoc :: [(LocationInModule, 'CDB'.FunctionEntry, a)] Ident SymbolTable -> Maybe ClassDoc
parseClassDoc members id st
| isSingleFunction members id = flip addClassMemberDoc
(functionToClassMemberDoc <$> findDoc hideIsUsedReturn id st)
<$> findDoc hideFunctionOnClass id st
| otherwise = flip (foldl addClassMemberDoc)
[functionToClassMemberDoc <$> fe.fe_documentation \\ (_,fe) <- members]
[functionToClassMemberDoc <$> fe.fe_documentation \\ (_,fe,_) <- members]
<$> findDoc hideIsUsedReturn id st
isSingleFunction :: [(LocationInModule, 'CDB'.FunctionEntry)] Ident -> Bool
isSingleFunction :: [(LocationInModule, 'CDB'.FunctionEntry, a)] Ident -> Bool
isSingleFunction members id = length members == 1
&& fromJust (fst $ hd members).name == id.id_name
&& fromJust (fst3 $ hd members).name == id.id_name
// Hide warnings about @result and @param on single function classes
hideFunctionOnClass (IllegalField "param") = False
......
......@@ -73,7 +73,7 @@ getEntries :: *(DB v ak a) -> *([(v, Map ak a)], *DB v ak a)
/**
* An in-place map over all entries (also the excluded ones).
*/
mapInPlace :: (v -> v) *(DB v ak a) -> *(DB v ak a)
mapInPlace :: (Int v -> v) *(DB v ak a) -> *(DB v ak a)
/**
* Linear search for entries. The search function returns whether the entry
......
......@@ -7,7 +7,7 @@ import StdInt
import StdString
import StdTuple
from Data.Func import $
from Data.Func import $, hyperstrict
import Data.Functor
import Data.Map
import Data.Maybe
......@@ -23,7 +23,7 @@ instance == Index where == (Index a) (Index b) = a == b
instance < Index where < (Index a) (Index b) = a < b
newDB :: [v] -> *DB v ak a
newDB vs = DB {{value=v,included=True,annotations=newMap} \\ v <- vs}
newDB vs = DB {{value=hyperstrict v,included=True,annotations=newMap} \\ v <- vs}
saveDB :: *(DB v ak a) *File -> *(*DB v ak a, *File) | JSONEncode{|*|} v
saveDB (DB db) f
......@@ -98,15 +98,17 @@ where
# (r,es) = collect (i-1) es
= (if e.included [(e.value,e.annotations):r] r, es)
mapInPlace :: (v -> v) *(DB v ak a) -> *(DB v ak a)
mapInPlace :: (Int v -> v) *(DB v ak a) -> *(DB v ak a)
mapInPlace f (DB db)
# (s,db) = usize db
= DB (upd (s-1) db)
= DB (upd 0 s db)
where
upd -1 es = es
upd i es
# (e,es) = es![i]
= upd (i-1) {es & [i]={e & value=f e.value}}
//upd :: !Int !Int !*{!Entry v ak a} -> *{!Entry v ak a}
upd i s es
| i == s = es
#! (e,es) = es![i]
#! e & value = hyperstrict $ f i e.value
= upd (i+1) s {es & [i]=e}
search :: !SearchMode (v -> (Bool, [(ak, a)])) *(DB v ak a) -> *DB v ak a | ==, < ak
search mode f (DB db)
......
definition module Idents
from StdClass import class Eq
from StdList import isMember, removeDup
from StdOverloaded import class ==
from Data.Set import :: Set
from syntax import :: ParsedDefinition
:: Idents =
{ locals :: Set String
, globals :: Set String
}
:: IdentContext
= ICExpression
| ICPattern
class idents t :: IdentContext t -> Idents
instance idents [t] | idents t
instance idents ParsedDefinition
implementation module Idents
from Data.List import concatMap
from Data.Set import :: Set, newSet, union, unions, difference, fromList
import syntax
removeLocalGlobals :: Idents -> Idents
removeLocalGlobals ids = {ids & globals=difference ids.globals ids.locals}
noLocals :: Idents -> Idents
noLocals ids = {ids & locals=newSet}
instance zero Idents
where
zero =
{ locals = newSet
, globals = newSet
}
instance + Idents
where
+ a b = removeLocalGlobals
{ locals = union a.locals b.locals
, globals = union a.globals b.globals
}
instance idents [t] | idents t
where
idents c xs = removeLocalGlobals
{ locals = unions [x.locals \\ x <- xids]
, globals = unions [x.globals \\ x <- xids]
}
where xids = map (idents c) xs
instance idents (Optional a) | idents a
where
idents _ No = zero
idents c (Yes x) = idents c x
instance idents String
where
idents ICExpression s = {zero & globals=fromList [s]}
idents ICPattern s = {zero & locals= fromList [s]}
instance idents Ident where idents c id = idents c id.id_name
instance idents ParsedDefinition
where
idents c pd = case pd of
PD_Function _ id _ args rhs _ ->
idents ICPattern id +
noLocals (idents ICPattern args + idents ICExpression rhs)
PD_NodeDef _ e rhs -> idents ICPattern e + idents ICExpression rhs
PD_Type _ -> abort "idents PD_Type\n"
// PD_Type ptd -> abort "idents PD_Type\n"
PD_TypeSpec _ _ _ _ _ -> zero