open-axiom repository from github
-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
-- All rights reserved.
-- Copyright (C) 2007-2012, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are
-- met:
--
-- - Redistributions of source code must retain the above copyright
-- notice, this list of conditions and the following disclaimer.
--
-- - Redistributions in binary form must reproduce the above copyright
-- notice, this list of conditions and the following disclaimer in
-- the documentation and/or other materials provided with the
-- distribution.
--
-- - Neither the name of The Numerical Algorithms Group Ltd. nor the
-- names of its contributors may be used to endorse or promote products
-- derived from this software without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
import bc_-util
namespace BOOT
$charUnderscore == char "__" --needed because of parser bug
--=======================================================================
-- Grepping Database libdb.text
-- Redone 12/95 for Saturn; previous function grep renamed as grepFile
-- This function now either returns a filename or a list of strings
--=======================================================================
grepConstruct(s,key,:options) == --key = a o c d p x k (all) . (aok) w (doc)
--Called from genSearch with key = "." and "w"
--key = "." means a o c d p x
--option1 = true means return the result as a file
--All searches of the database call this function to get relevant lines
--from libdb.text. Returns either a list of lines (usual case) or else
--an alist of the form ((kind . <list of lines for that kind>) ...)
$localLibdb : local := fnameExists? '"libdb.text" and '"libdb.text"
lines := grepConstruct1(s,key)
lines is ["error",:.] => lines
IFCAR options => grepSplit(lines,key is 'w) --leave now if a constructor
key in '(o a) => dbScreenForDefaultFunctions lines --kill default lines if a/o
lines
grepConstruct1(s,key) ==
--returns the name of file (WITHOUT .text.$SPADNUM on the end)
$key : local := key
if key = 'k and --convert 'k to 'y if name contains an "&"
or/[stringChar(s,i) = char "&" for i in 0..maxIndex s] then key := 'y
filter := pmTransFilter STRINGIMAGE s --parses and-or-not form
filter is ['error,:.] => filter --exit on parser error
pattern := mkGrepPattern(filter,key) --create string to pass to "grep"
grepConstructDo(pattern, key) --do the "grep"---see b-saturn.boot
grepConstructDo(x, key) ==
$orCount := 0
--x isnt [.,:.] => grepFile(x, key,'i)
$localLibdb =>
oldLines := purgeNewConstructorLines(grepf(x,key,false),$newConstructorList)
newLines := grepf(x,$localLibdb,false)
union(oldLines, newLines)
grepf(x,key,false)
dbExposed?(line,kind) == -- does line come from an unexposed constructor?
conname := makeSymbol
kind = char "a" or kind = char "o" => dbNewConname line --get conname from middle
dbName line
isExposedConstructor conname
dbScreenForDefaultFunctions lines == [x for x in lines | not isDefaultOpAtt x]
isDefaultOpAtt x == x.(1 + dbTickIndex(x,4,0)) = char "x"
grepForAbbrev(s,key) ==
--checks that filter s is not * and is all uppercase; if so, look for abbrevs
u := tableValue($lowerCaseConTb,s) => ['Abbreviations,u] --try cheap test first
s := STRINGIMAGE s
someLowerCaseChar := false
someUpperCaseChar := false
for i in 0..maxIndex s repeat
c := stringChar(s,i)
lowerCase? c => return (someLowerCaseChar := true)
upperCase? c => someUpperCaseChar := true
someLowerCaseChar or not someUpperCaseChar => false
pattern := DOWNCASE s
['Abbreviations ,:[getConstructorFormFromDB x
for x in allConstructors() | test]] where test() ==
not $includeUnexposed? and not isExposedConstructor x => false
a := getConstructorAbbreviationFromDB x
match?(pattern,symbolName a) and not tableValue($defaultPackageNamesHT,x)
applyGrep(x,filename) ==
x isnt [.,:.] => grepFile(x,filename,'i)
$localLibdb =>
a := purgeNewConstructorLines(grepf(x,filename,false),$newConstructorList)
b := grepf(x,$localLibdb,false)
grepCombine(a,b)
grepf(x,filename,false)
grepCombine(a,b) == MSORT union(a,b)
grepf(pattern,s,not?) == --s=sourceFile or list of strings
pattern is [op,:argl] =>
op = "and" =>
while argl is [arg,:argl] repeat
s := grepf(arg,s,not?) -- filter by successive greps
s
op = "or" =>
targetStack := nil
"union"/[grepf(arg,s,not?) for arg in argl]
op = "not" =>
not? => grepf(first argl,s,false)
--could be the first time so have to get all of same $key
lines := grepf(mkGrepPattern('"*",$key),s,false)
grepf(first argl,lines,true)
systemError nil
option :=
not? => 'iv
'i
source :=
LISTP s => dbWriteLines s
s
grepFile(pattern,source,option)
pmTransFilter s ==
--result is either a string or (op ..) where op= and,or,not and arg are results
if $browseMixedCase = true then s := DOWNCASE s
or/[isFilterDelimiter? stringChar(s,i) or stringChar(s,i) = $charUnderscore for i in 0..maxIndex s]
=> (parse := pmParseFromString s) and checkPmParse parse or
['error,'"Illegal search string",'"\vspace{3}\center{{\em Your search string} ",escapeSpecialChars s,'" {\em has incorrect syntax}}"]
or/[s . i = char "*" and s.(i + 1) = char "*"
and (i=0 or stringChar(s,i - 1) ~= $charUnderscore) for i in 0..(maxIndex s - 1)]
=> ['error,'"Illegal search string",'"\vspace{3}\center{Consecutive {\em *}'s are not allowed in search patterns}"]
s
checkPmParse parse ==
string? parse => parse
(fn parse => parse) where fn(u) ==
u is [op,:args] =>
op in '(and or not) and "and"/[checkPmParse x for x in args]
string? u => true
false
nil
dnForm x ==
string? x => x
x is ['not,argl] =>
argl is ['or,:orargs]=>
['and, :[dnForm negate u for u in orargs]] where negate s ==
s is ['not,argx] => argx
['not,s]
argl is ['and,:andargs]=>
['or,:[dnForm negate u for u in andargs]]
argl is ['not,notargl]=>
dnForm notargl
x
x is ['or,:argl1] => ['or,:[dnForm u for u in argl1]]
x is ['and,:argl2] => ['and,:[dnForm u for u in argl2]]
x
pmParseFromString s ==
u := ncParseFromString pmPreparse s
dnForm flatten u where flatten s ==
s is [op,:argl] =>
string? op => strconc(op,strconc/[strconc('" ",x) for x in argl])
[op,:[flatten x for x in argl]]
s
pmPreparse s == fn(s,0,#s) where--stupid insertion of chars to get correct parse
fn(s,n,siz) == --main function: s is string, n is origin
n = siz => '""
i := firstNonDelim(s,n) or return subString(s,n)
j := firstDelim(s,i + 1) or siz
t := gn(s,i,j - 1)
middle :=
member(t,'("and" "or" "not")) => t
--the following 2 lines make commutative("*") parse correctly!!!!
stringChar(t,0) = char "_"" => t
j < siz - 1 and s.j = char "(" => t
strconc('"_"",t,'"_"")
strconc(subString(s,n,i - n),middle,fn(s,j,siz))
gn(s,i,j) == --replace each underscore by 4 underscores!
n := or/[k for k in i..j | stringChar(s,k) = $charUnderscore] =>
strconc(subString(s,i,n - i + 1),charString $charUnderscore,gn(s,n + 1,j))
subString(s,i,j - i + 1)
firstNonDelim(s,n) ==
or/[k for k in n..maxIndex s | not isFilterDelimiter? stringChar(s,k)]
firstDelim(s,n) ==
or/[k for k in n..maxIndex s | isFilterDelimiter? stringChar(s,k)]
isFilterDelimiter? c ==
charMember?(c,$pmFilterDelimiters)
grepSplit(lines,doc?) ==
if doc? then
instream2 := inputTextFile strconc(systemRootDirectory(),'"/algebra/libdb.text")
cons := atts := doms := nil
while lines is [line, :lines] repeat
if doc? then
N:=readInteger dbPart(line,1,-1)
if integer? N then
setFileCursor(instream2,N)
line := readLine instream2
kind := dbKind line
not $includeUnexposed? and not dbExposed?(line,kind) => 'skip
(kind = char "a" or kind = char "o") and isDefaultOpAtt line => 'skip
PROGN
kind = char "c" => cats := insert(line,cats)
kind = char "d" => doms := insert(line,doms)
kind = char "x" => defs := insert(line,defs)
kind = char "p" => paks := insert(line,paks)
kind = char "a" => atts := insert(line,atts)
kind = char "o" => ops := insert(line,ops)
kind = char "-" => 'skip --for now
systemError 'kind
if doc? then closeStream instream2
[['"attribute",:reverse! atts],
['"operation",:reverse! ops],
['"category",:reverse! cats],
['"domain",:reverse! doms],
['"package",:reverse! paks]
-- ['"default_ package",:reverse! defs] -- drop defaults
]
mkUpDownPattern s == recurse(s,0,#s) where
recurse(s,i,n) ==
i = n => '""
strconc(fixchar(s.i),recurse(s,i + 1,n))
fixchar(c) ==
alphabetic? c =>
strconc('"[",charUpdate c,charDowncase c,'"]")
c
mkGrepPattern(s,key) ==
--called by grepConstruct1 and grepf
s isnt [.,:.] => mkGrepPattern1(s,key)
[first s,:[mkGrepPattern(x,key) for x in rest s]]
mkGrepPattern1(x,:options) == --called by mkGrepPattern (and grepConstructName?)
$options : local := options
s := STRINGIMAGE x
--s := DOWNCASE STRINGIMAGE x
addOptions remUnderscores addWilds split(g s,char "*") where
addWilds sl == --add wild cards (sl is list of parts between *'s)
IFCAR sl = '"" => h(IFCDR sl,[$wild1])
h(sl,nil)
g s == --remove "*"s around pattern for text match
not ('w in $options) => s
if stringChar(s,0) = char "*" then s := subString(s,1)
if stringChar(s,k := maxIndex s) = char "*" then s := subString(s,0,k)
s
h(sl,res) == --helper for wild cards
sl is [s,:r] => h(r,[$wild1,s,:res])
res := rest res
if not ('w in $options) then
if first res ~= '"" then res := ['"`",:res]
else if res is [.,p,:r] and p = $wild1 then res := r
strconc/reverse! res
remUnderscores s ==
(k := charPosition($charUnderscore,s,0)) < maxIndex s =>
strconc(subString(s,0,k),'"[",s.(k + 1),'"]",
remUnderscores(subString(s,k + 2)))
s
split(s,char) ==
max := maxIndex s + 1
f := -1
[subString(s,i,f-i)
while ((i := f + 1) <= max) and (f := charPosition(char,s,i))]
charPosition(c,t,startpos) == --honors underscores
n := # t
if startpos < 0 or startpos > n then error "index out of range"
k:= startpos
for i in startpos .. n-1 while c ~= t.i
or i > startpos and t.(i-1) = '__ repeat (k := k+1)
k
addOptions s == --add front anchor
--options a o c d p x denote standard items
--options w means comments
--option t means text
--option s means signature
--option n means number of arguments
--option i means predicate
--option none means NO PREFIX
one := ($options is [x,:$options] and x => x; '"[^x]")
tick := '"[^`]*`"
one = 'w => s
one = 'none => (s = '"`" => '"^."; strconc('"^",s))
prefix :=
one = 't => strconc(tick,tick,tick,tick,tick,".*")
one = 'n => tick
one = 'i => strconc(tick,tick,tick,tick)
one = 's => strconc(tick,tick,tick)
-- true => '"" ----> never put on following prefixes
one = 'k => '"[cdp]"
one = 'y => '"[cdpx]"
STRINGIMAGE one
s = $wild1 => strconc('"^",prefix)
strconc('"^",prefix,s)
conform2OutputForm(form) ==
[op,:args] := form
null args => form
cosig :=
builtinConstructor? op => [true for . in args]
rest getDualSignature op
atypes := getConstructorModemap(op).mmSource
sargl := [fn for x in args for atype in atypes for pred in cosig] where fn() ==
pp [x,atype,pred]
pred => conform2OutputForm x
typ := sublisFormal(args,atype)
if x is ['QUOTE,a] then x := a
algCoerceInteractive(x,typ,'(OutputForm))
[op,:sargl]
oPage(a,:b) == --called by \spadfun{opname}
oSearch (IFCAR b or a) --always take slow path
oPageFrom(opname,conname) == --called by \spadfunFrom{opname}{conname}
htPage := htInitPage(nil,nil) --create empty page and fill in needed properties
htpSetProperty(htPage,'conform,conform := getConstructorForm conname)
htpSetProperty(htPage,'kind,STRINGIMAGE getConstructorKindFromDB conname)
itemlist := ASSOC(opname,koOps(conform,nil)) --all operations name "opname"
null itemlist => systemError [conform,'" has no operation named ",opname]
opAlist := [itemlist]
dbShowOperationsFromConform(htPage,'"operation",opAlist)
aPage(a,:b) == --called by \spadatt{a}
$attributeArgs : local := nil
arg := IFCAR b or a
s := pmParseFromString STRINGIMAGE arg
searchOn :=
s isnt [.,:.] => s
IFCAR s
$attributeArgs : local := IFCAR IFCDR s
aSearch searchOn
--must recognize that not all attributes can be found in database
--e.g. constant(deriv) is not but appears in a conditional in LODO
spadType(x) == --called by \spadtype{x} from HyperDoc
s := PNAME x
form := ncParseFromString s or
systemError ['"Argument: ",s,'" to spadType won't parse"]
if form isnt [.,:.] then form := [form]
op := opOf form
looksLikeDomainForm form => apply(function conPage,form)
conPage(op)
looksLikeDomainForm x ==
entry := getCDTEntry(opOf x,true) or return false
coSig := symbolTarget('coSig,CDDR entry)
k := #coSig
x isnt [.,:.] => k = 1
k ~= #x => false
and/[p for key in rest coSig for arg in rest x] where
p() ==
key => looksLikeDomainForm arg
not ident? arg
spadSys(x) == --called by \spadsyscom{x}
s := PNAME x
if stringChar(s,0) = char ")" then s := subString(s,1)
form := ncParseFromString s or
systemError ['"Argument: ",s,'" to spadType won't parse"]
htSystemCommands PNAME opOf form
--=======================================================================
-- Name and General Search
--=======================================================================
aokSearch filter == genSearch(filter,true) --"General" from HD (see man0.ht)
--General search for constructs but NOT documentation
genSearch(filter,:options) == --"Complete" from HD (see man0.ht) and aokSearch
--General + documentation search
null (filter := checkFilter filter) => nil --in case of filter error
filter = '"*" => htErrorStar()
includeDoc? := not IFCAR options
--give summaries for how many a o c d p x match filter
regSearchAlist := grepConstruct(STRINGIMAGE filter,".",true)
regSearchAlist is ['error,:.] => bcErrorPage regSearchAlist
key := removeSurroundingStars filter
if includeDoc? then
docSearchAlist := grepConstruct(key,'w,true)
docSearchAlist is ['error,:.] => bcErrorPage docSearchAlist
genSearch1(filter,genSearchTran regSearchAlist,genSearchTran docSearchAlist)
genSearchTran alist == [[x,y,:y] for [x,:y] in alist]
genSearch1(filter,reg,doc) ==
regSearchAlist := searchDropUnexposedLines reg
docSearchAlist := searchDropUnexposedLines doc
key := removeSurroundingStars filter
regCount := searchCount regSearchAlist
docCount := searchCount docSearchAlist
count := regCount + docCount
count = 0 => emptySearchPage('"entry",filter,true)
count = 1 =>
alist := (regCount = 1 => regSearchAlist; docSearchAlist)
showNamedConstruct(or/[x for x in alist | second x])
summarize? :=
docSearchAlist => true
nonEmpties := [pair for pair in regSearchAlist | #(second pair) > 0]
not(nonEmpties is [pair])
not summarize? => showNamedConstruct pair
-----------generate a summary page---------------------------
plural :=
$exposedOnlyIfTrue => '"exposed entries match"
'"entries match"
prefix := pluralSay(count,'"", plural)
emfilter := ['"{\em ",escapeSpecialChars STRINGIMAGE filter,'"}"]
header := [:prefix,'" ",:emfilter]
page := htInitPage(header,nil)
htpSetProperty(page,'regSearchAlist,regSearchAlist)
htpSetProperty(page,'docSearchAlist,docSearchAlist)
htpSetProperty(page,'filter,filter)
if docSearchAlist then
dbSayItems(['"{\bf Construct Summary:} ",regCount],'"name matches",'"names match")
for [kind,:pair] in regSearchAlist for i in 0.. | #(first pair) > 0 repeat
bcHt '"\newline{}"
htSayStandard '"\tab{2}"
genSearchSay(pair,summarize?,kind,i,'showConstruct)
if docSearchAlist then
htSaySaturn '"\bigskip{}"
dbSayItems(['"\newline{\bf Documentation Summary:} ",docCount],'"mention",'"mentions",'" of {\em ",key,'"}")
for [kind,:pair] in docSearchAlist for i in 0.. | #(first pair) > 0 repeat
bcHt "\newline{}"
htSayStandard '"\tab{2}"
genSearchSay(pair,true,kind,i,'showDoc)
htShowPageStar()
searchDropUnexposedLines alist ==
[[op,[pred for line in lines | pred],:lines] for [op,.,:lines] in alist] where
pred() ==
not $exposedOnlyIfTrue or dbExposed?(line,dbKind line) => line
nil
repeatSearch(htPage,newValue) ==
$exposedOnlyIfTrue := newValue
filter := htpProperty(htPage,'filter)
reg := htpProperty(htPage,'regSearchAlist)
doc := htpProperty(htPage,'docSearchAlist)
reg => genSearch1(filter,reg,doc)
docSearch1(filter,doc)
searchCount u == +/[# y for [x,y,:.] in u]
showDoc(htPage,count) ==
showIt(htPage,count,htpProperty(htPage,'docSearchAlist))
showConstruct(htPage,count) ==
showIt(htPage,count,htpProperty(htPage,'regSearchAlist))
showIt(htPage,index,searchAlist) ==
filter := htpProperty(htPage,'filter)
[relativeIndex,n] := DIVIDE(index,8)
relativeIndex = 0 => showNamedConstruct(searchAlist.n)
[kind,items,:.] := searchAlist . n
for j in 1.. while j < relativeIndex repeat items := rest items
firstName := dbName first items --select name then gather all of same name
lines := [line for line in items while dbName line = firstName]
showNamedConstruct [kind,nil,:lines]
showNamedConstruct([kind,.,:lines]) == dbSearch(lines,kind,'"")
genSearchSay(pair,summarize,kind,who,fn) ==
[u,:fullLineList] := pair
count := #u
uniqueCount := genSearchUniqueCount u
short := summarize and uniqueCount >= $browseCountThreshold
htMakePage
[['bcLinks,[menuButton(),'"",'genSearchSayJump,[fullLineList,kind]]]]
if count = 0 then htSay('"{\em No ",kind,'"} ")
else if count = 1 then
htSay('"{\em 1 ",kind,'"} ")
else
htSay('"{\em ",count,'" ",pluralize kind,'"} ")
short => 'done
if uniqueCount ~= 1 then
htSayStandard '"\indent{4}"
htSay '"\newline "
htBeginTable()
lastid := nil
groups := organizeByName u
i := 1
for group in groups repeat
id := dbGetName first group
if $includeUnexposed? then
exposed? := or/[dbExposed?(item,dbKind item) for item in group]
bcHt '"{"
if $includeUnexposed? then
exposed? => htBlank()
htSayUnexposed()
htMakePage [['bcLinks, [id,'"",fn,who + 8*i]]]
i := i + #group
bcHt '"}"
if uniqueCount ~= 1 then
htEndTable()
htSayStandard '"\indent{0}"
organizeByName u ==
[[(u := rest u; x) while u and head = dbName (x := first u)]
while u and (head := dbName first u)]
genSearchSayJump(htPage,[lines,kind]) ==
filter := htpProperty(htPage,'filter)
dbSearch(lines,kind,filter)
genSearchUniqueCount(u) ==
--count the unique number of items (if less than $browseCountThreshold)
count := 0
lastid := nil
for item in u while count < $browseCountThreshold repeat
id := dbGetName item
if id ~= lastid then
count := count + 1
lastid := id
count
dbGetName line == subString(line,1,charPosition($tick,line,1) - 1)
pluralSay(count,singular,plural,:options) ==
item := (options is [x,:options] => x; '"")
colon := (IFCAR options => '":"; '"")
count = 0 => concat('"No ",singular,item)
count = 1 => concat('"1 ",singular,item,colon)
concat(count,'" ",plural,item,colon)
--=======================================================================
-- Documentation Search
--=======================================================================
docSearch filter == --"Documentation" from HD (see man0.ht)
null (filter := checkFilter filter) => nil --in case of filter error
filter = '"*" => htErrorStar()
key := removeSurroundingStars filter
docSearchAlist := grepConstruct(filter,'w,true)
docSearchAlist is ['error,:.] => bcErrorPage docSearchAlist
docSearch1(filter,genSearchTran docSearchAlist)
docSearch1(filter,doc) ==
docSearchAlist := searchDropUnexposedLines doc
count := searchCount docSearchAlist
count = 0 => emptySearchPage('"entry",filter,true)
count = 1 => showNamedConstruct(or/[x for x in docSearchAlist | second x])
prefix := pluralSay(count,'"entry matches",'"entries match")
emfilter := ['"{\em ",escapeSpecialChars STRINGIMAGE filter,'"}"]
header := [:prefix,'" ",:emfilter]
page := htInitPage(header,nil)
htpSetProperty(page,'docSearchAlist,docSearchAlist)
htpSetProperty(page,'regSearchAlist,nil)
htpSetProperty(page,'filter,filter)
dbSayItems(['"\newline Documentation Summary: ",count],'"mention",'"mentions",'" of {\em ",filter,'"}")
for [kind,:pair] in docSearchAlist for i in 0.. | #(first pair) > 0 repeat
bcHt '"\newline{}"
htSayStandard '"\tab{2}"
genSearchSay(pair,true,kind,i,'showDoc)
htShowPageStar()
removeSurroundingStars filter ==
key := STRINGIMAGE filter
if stringChar(key,0) = char "*" then key := subString(key,1)
if stringChar(key,max := maxIndex key) = char "*" then
key := subString(key,0,max)
key
showNamedDoc([kind,:lines],index) ==
dbGather(kind,lines,index - 1,true)
sayDocMessage message ==
htSay('"{\em ")
if message is [leftEnd,left,middle,right,rightEnd] then
htSay(leftEnd,left,'"}")
if left ~= '"" and stringChar(left,maxIndex left) = $blank then htBlank()
htSay middle
if right ~= '"" and stringChar(right,0) = $blank then htBlank()
htSay('"{\em ",right,rightEnd)
else
htSay message
htSay ('"}")
stripOffSegments(s,n) ==
progress := true
while n > 0 and progress = true repeat
n := n - 1
k := charPosition(char "`",s,0)
new := subString(s,k + 1)
#new < #s => s := new
progress := false
n = 0 => s
nil
replaceTicksBySpaces s ==
n := -1
max := maxIndex s
while (n := charPosition(char "`",s,n + 1)) <= max repeat
stringChar(s,n) := char " "
s
checkFilter filter ==
filter := STRINGIMAGE filter
filter = '"" => '"*"
trimString filter
aSearch filter == --called from HD (man0.ht): general attribute search
null (filter := checkFilter filter) => nil --in case of filter error
dbSearch(grepConstruct(filter,'a),'"attribute",filter)
oSearch filter == -- called from HD (man0.ht): operation search
opAlist := opPageFastPath filter => opPageFast opAlist
key := 'o
null (filter := checkFilter filter) => nil --in case of filter error
filter = '"*" => grepSearchQuery('"operation",[filter,key,'"operation",'oSearchGrep])
oSearchGrep(filter,key,'"operation")
oSearchGrep(filter,key,kind) == --called from grepSearchQuery/oSearch
dbSearch(grepConstruct(filter,'o),kind,filter)
grepSearchQuery(kind,items) ==
page := htInitPage('"Query Page",nil)
htpSetProperty(page,'items,items)
htQuery(['"{\em Do you want a list of {\em all} ",pluralize kind,'"?\vspace{1}}"],'grepSearchJump,true)
htShowPage()
cSearch filter == --called from HD (man0.ht): category search
constructorSearch(checkFilter filter,'c,'"category")
dSearch filter == --called from HD (man0.ht): domain search
constructorSearch(checkFilter filter,'d,'"domain")
pSearch filter == --called from HD (man0.ht): package search
constructorSearch(checkFilter filter,'p,'"package")
xSearch filter == --called from HD (man0.ht): default package search
constructorSearch(checkFilter filter,'x,'"default package")
kSearch filter == --called from HD (man0.ht): constructor search (no defaults)
constructorSearch(checkFilter filter,'k,'"constructor")
ySearch filter == --called from conPage: like kSearch but defaults included
constructorSearch(checkFilter filter,'y,'"constructor")
constructorSearch(filter,key,kind) ==
null filter => nil --in case of filter error
(parse := conSpecialString? filter) => conPage parse
pageName := LASSOC(DOWNCASE filter,'(("union" . DomainUnion)("record" . DomainRecord)("mapping" . DomainMapping) ("enumeration" . DomainEnumeration))) =>
downlink pageName
name := (string? filter => makeSymbol filter; filter)
if u := tableValue($lowerCaseConTb,name) then filter := STRINGIMAGE first u
line := conPageFastPath DOWNCASE filter =>
code := dbKind line
newkind :=
code = char "p" => '"package"
code = char "d" => '"domain"
code = char "c" => '"category"
nil
kind = '"constructor" or kind = newkind => kPage line
page := htInitPage('"Query Page",nil)
htpSetProperty(page,'line,line)
message :=
['"{\em ",dbName line,'"} is not a {\em ",kind,'"} but a {\em ",
newkind,'"}. Would you like to view it?\vspace{1}"]
htQuery(message, 'grepConstructorSearch,true)
htShowPage()
filter = '"*" => grepSearchQuery(kind,[filter,key,kind,'constructorSearchGrep])
constructorSearchGrep(filter,key,kind)
grepConstructorSearch(htPage,yes) == kPage htpProperty(htPage,'line)
conSpecialString?(filter,:options) ==
secondTime := IFCAR options
parse :=
words := string2Words filter is [s] => ncParseFromString s
and/[not (x in '("and" "or" "not")) for x in words] => ncParseFromString filter
false
null parse => nil
form := conLowerCaseConTran parse
KAR form in '(and or not) or CONTAINED("*",form) => nil
filter = '"Mapping" =>nil
u := kisValidType form => u
secondTime => false
u := strconc/[string2Constructor x for x in dbString2Words filter]
conSpecialString?(u, true)
dbString2Words l ==
i := 0
[w while dbWordFrom(l,i) is [w,i]]
$dbDelimiters := [char " " , char "(", char ")"]
dbWordFrom(l,i) ==
idxmax := maxIndex l
while idxmax >= i and stringChar(l,i) = char " " repeat i := i + 1
if idxmax >= i and member(stringChar(l,i), $dbDelimiters) then return [l.i, i + 1]
k := or/[j for j in i..idxmax | not member(stringChar(l,j), $dbDelimiters)] or return nil
buf := '""
while k <= idxmax and not member(c := stringChar(l,k), $dbDelimiters) repeat
ch :=
c = char "__" => l.(k := 1+k) --this may exceed bounds
c
buf := strconc(buf,ch)
k := k + 1
[buf,k]
conLowerCaseConTran x ==
ident? x => IFCAR tableValue($lowerCaseConTb, x) or x
x isnt [.,:.] => x
[conLowerCaseConTran y for y in x]
string2Constructor x ==
not string? x => x
IFCAR tableValue($lowerCaseConTb, makeSymbol DOWNCASE x) or x
conLowerCaseConTranTryHarder x ==
ident? x => IFCAR tableValue($lowerCaseConTb,DOWNCASE x) or x
x isnt [.,:.] => x
[conLowerCaseConTranTryHarder y for y in x]
constructorSearchGrep(filter,key,kind) ==
dbSearch(grepConstruct(filter,key),kind,filter)
grepSearchJump(htPage,yes) ==
[filter,key,kind,fn] := htpProperty(htPage,'items)
apply(fn,[filter,key,kind])
--=======================================================================
-- Branch Functions After Database Search
--=======================================================================
dbSearch(lines,kind,filter) == --called by attribute, operation, constructor search
lines is ['error,:.] => bcErrorPage lines
null filter => nil --means filter error
lines is ['Abbreviations,:r] => dbSearchAbbrev(lines,kind,filter)
if kind in '("attribute" "operation") then --should not be necessary!!
lines := dbScreenForDefaultFunctions lines
count := #lines
count = 0 => emptySearchPage(kind,filter)
kind in '("attribute" "operation") => dbShowOperationLines(kind,lines)
dbShowConstructorLines lines
dbSearchAbbrev([.,:conlist],kind,filter) ==
null conlist => emptySearchPage('"abbreviation",filter)
kind := intern kind
if kind ~= 'constructor then
conlist := [x for x in conlist | symbolTarget('kind,IFCDR IFCDR x) = kind]
conlist is [[nam,:.]] => conPage DOWNCASE nam
cAlist := [[con,:true] for con in conlist]
htPage := htInitPage('"",nil)
htpSetProperty(htPage,'cAlist,cAlist)
htpSetProperty(htPage,'thing,nil)
return dbShowCons(htPage,'names)
page := htInitPage([#conlist,
'" Abbreviations Match {\em ",STRINGIMAGE filter,'"}"],nil)
for [nam,abbr,:r] in conlist repeat
kind := symbolTarget('kind,r)
htSay('"\newline{\em ",s := STRINGIMAGE abbr)
htSayStandard '"\tab{10}"
htSay '"}"
htSay kind
htSayStandard '"\tab{19}"
bcCon nam
htShowPage()
--=======================================================================
-- Selectable Search
--=======================================================================
detailedSearch(filter) ==
page := htInitPage('"Detailed Search with Options",nil)
filter := escapeSpecialChars PNAME filter
bcHt '"Select what you want to search for, then click on {\em Search} below"
bcHt '"\newline{\it Note:} Logical searches using {\em and}, {\em or}, and {\em not} are not permitted here."
htSayHrule()
htMakePage '(
(text . "\newline")
(bcRadioButtons which
( "\tab{3}{\em Operations}"
((text . "\newline\space{3}")
(text . "name") (bcStrings (14 "*" opname EM))
(text . " \#args") (bcStrings (1 "*" opnargs EM))
(text . " signature") (bcStrings (14 "*" opsig EM))
(text . "\vspace{1}\newline "))
ops)
( "\tab{3}{\em Attributes}"
((text . "\newline\space{3}")
(text . "name") (bcStrings (14 "*" attrname EM))
(text . " \#args ") (bcStrings (1 "*" attrnargs EM))
(text . " arguments ")(bcStrings (14 "*" attrargs EM))
(text . "\vspace{1}\newline "))
attrs)
( "\tab{3}{\em Constructors}"
((text . "\tab{17}")
(bcButtons (1 cats)) (text . " {\em categories} ")
(bcButtons (1 doms)) (text . " {\em domains} ")
(bcButtons (1 paks)) (text . " {\em packages} ")
(bcButtons (1 defs)) (text . " {\em defaults} ")
(text . "\newline\tab{3}")
(text . "name") (bcStrings (14 "*" conname EM))
(text . " \#args") (bcStrings (1 "*" connargs EM))
(text . "signature") (bcStrings (14 "*" consig EM))
(text . "\vspace{1}\newline "))
cons)
-- ( "\tab{3}{\em Documentation}"
-- ((text . "\tab{26}key")
-- (bcStrings (28 "*" docfilter EM)))
-- doc)
)
(text . "\vspace{1}\newline\center{ ")
(bcLinks ("\box{Search}" "" generalSearchDo NIL))
(text . "}"))
htShowPage()
generalSearchDo(htPage,flag) ==
--$exposedOnlyIfTrue := (flag => 'T; nil)
$htPage := htPage
alist := htpInputAreaAlist htPage
which := htpButtonValue(htPage,'which)
selectors :=
which = 'cons => '(conname connargs consig)
which = 'ops => '(opname opnargs opsig)
'(attrname attrnargs attrargs)
name := generalSearchString(htPage,selectors.0)
nargs:= generalSearchString(htPage,selectors.1)
npat := standardizeSignature generalSearchString(htPage,selectors.2)
kindCode :=
which = 'ops => char "o"
which = 'attrs => char "a"
acc := '""
if htButtonOn?(htPage,'cats) then acc := strconc('"c",acc)
if htButtonOn?(htPage,'doms) then acc := strconc('"d",acc)
if htButtonOn?(htPage,'paks) then acc := strconc('"p",acc)
if htButtonOn?(htPage,'defs) then acc := strconc('"x",acc)
n := #acc
n = 0 or n = 4 => '"[cdpx]"
n = 1 => acc
strconc('"[",acc,'"]")
form := mkDetailedGrepPattern(kindCode,name,nargs,npat)
lines := applyGrep(form,'libdb)
--lines := dbReadLines resultFile
if which in '(ops attrs) then lines := dbScreenForDefaultFunctions lines
kind :=
which = 'cons =>
n = 1 =>
htButtonOn?(htPage,'cats) => '"category"
htButtonOn?(htPage,'doms) => '"domain"
htButtonOn?(htPage,'paks) => '"package"
'"default package"
'"constructor"
which = 'ops => '"operation"
'"attribute"
null lines => emptySearchPage(kind,nil)
dbSearch(lines,kind,'"filter")
generalSearchString(htPage,sel) ==
string := htpLabelInputString(htPage,sel)
string = '"" => '"*"
string
htButtonOn?(htPage,key) ==
LASSOC(key,htpInputAreaAlist htPage) is [a,:.] and a = '" t"
mkDetailedGrepPattern(kind,name,nargs,argOrSig) == main where
main() ==
nottick := '"[^`]"
name := replaceGrepStar name
firstPart := strconc('"^",kind,name)
nargsPart := replaceGrepStar nargs
exposedPart := char "." --always get exposed/unexposed
patPart := replaceGrepStar argOrSig
simp strconc(conc(firstPart,conc(nargsPart,conc(exposedPart, patPart))),$tick)
conc(a,b) ==
b = '"[^`]*" or b = char "." => a
strconc(a,$tick,b)
simp a ==
m := maxIndex a
m > 6 and stringChar(a,m-5) = char "[" and stringChar(a,m-4) = char "^"
and stringChar(a,m-3) = $tick and stringChar(a,m-2) = char "]"
and stringChar(a,m-1) = char "*" and stringChar(a,m) = $tick
=> simp subString(a,0,m-5)
a
replaceGrepStar s ==
s = "" => s
final := maxIndex s
i := charPosition(char "*",s,0)
i > final => s
strconc(subString(s,0,i),'"[^`]*",replaceGrepStar subString(s,i + 1))
standardizeSignature(s) == underscoreDollars
stringChar(s,0) = char "(" => s
k := findString('"->",s) or return s --will fail except perhaps on constants
stringChar(s,k - 1) = char ")" => strconc('"(",s)
strconc('"(",subString(s,0,k),'")",subString(s,k))
underscoreDollars(s) == fn(s,0,maxIndex s) where
fn(s,i,n) ==
i > n => '""
(m := charPosition(char "$",s,i)) > n => subString(s,i)
strconc(subString(s,i,m - i),'"___$",fn(s,m + 1,n))
--=======================================================================
-- I/O Code
--=======================================================================
getTempPath kind ==
pathname := mkGrepFile kind
removeFile pathname
pathname
dbWriteLines(s, :options) ==
pathname := IFCAR options or getTempPath 'source
$outStream: local := MAKE_-OUTSTREAM pathname
for x in s repeat writedb x
SHUT $outStream
pathname
dbReadLines target ==
instream := inputTextFile target
lines := []
while (line := readLine instream) ~= %nothing repeat
lines := [line,:lines]
closeStream instream
reverse! lines
dbGetCommentOrigin line ==
--Given a comment line in comdb, returns line in libdb pointing to it
--Comment lines have format [dcpxoa]xxxxxx`ccccc... where
--x's give pointer into libdb, c's are comments
firstPart := dbPart(line,1,-1)
key := makeSymbol subString(firstPart,0,1) --extract this and throw away
address := subString(firstPart, 1) --address in libdb
instream := inputTextFile grepSource key --this always returns libdb now
setFileCursor(instream,readInteger address)
line := readLine instream
closeStream instream
line
grepSource key ==
key = 'libdb => strconc(systemRootDirectory(),'"/algebra/libdb.text")
key = 'gloss => strconc(systemRootDirectory(),'"doc/glosskey.text")
key = $localLibdb => $localLibdb
mkGrepTextfile
key in '(_. a c d k o p x) => 'libdb
'comdb
mkGrepTextfile s ==
strconc(systemRootDirectory(),'"/algebra/", STRINGIMAGE s, '".text")
getTemporaryDirectory() ==
t := getEnv '"TMPDIR" or getEnv '"TEMP" or
getEnv '"TEMPDIR" or getEnv '"TMP" => ensureTrailingSlash t
strconc(systemRootDirectory(),'"/algebra/")
mkGrepFile s == --called to generate a path name for a temporary grep file
suffix := getEnv '"SPADNUM"
strconc(getTemporaryDirectory(), PNAME s,'".txt.", suffix)
--=======================================================================
-- Grepping Code
--=======================================================================
grepFile(pattern,:options) ==
key := (x := IFCAR options => (options := rest options; x); nil)
source := grepSource key
lines :=
not PROBE_-FILE source => nil
target := getTempPath 'target
casepart :=
'iv in options => '"-vi"
'"-i"
command := strconc('"grep ",casepart,'" _'",pattern,'"_' ",source)
runCommand
key in '(a o c d p x) =>
strconc(command, '" | sed 's/~/", STRINGIMAGE key, '"/' > ", target)
strconc(command, '" > ",target)
dbReadLines target
dbUnpatchLines lines
dbUnpatchLines lines == --concatenate long lines together, skip blank lines
dash := char "-"
acc := nil
while lines is [line, :lines] repeat
#line = 0 => 'skip --skip blank lines
acc :=
stringChar(line,0) = dash and line.1 = dash =>
[strconc(first acc,subString(line,2)),:rest acc]
[line,:acc]
-- following call to reverse! needed to keep lines properly sorted
reverse! acc ------> added by BMT 12/95