First draft below (reading Thesaurus in from a TaskPaper outline).
(Make sure you have copied the entire script revealed by the disclosure triangle below – the last line is end unlines)
AppleScript source code
use AppleScript version "2.4"
use framework "Foundation"
use scripting additions
property fpThesaurus : "~/Desktop/Test TP.taskpaper"
-- Rob Trew 2020
-- Ver 0.04 Importing a Thesaurus outline from a TaskPaper file
-- Ver 0.03 (Creating an 'Other' column for tags not found (as spelled) in thesaurus)
-- Ver 0.02 (Reporting any tags not found in thesaurus)
---------------------------TEST----------------------------
on run
either(alert("Tag columns"), ¬
columnsFromTags, ¬
thesaurusFromFilePath(fpThesaurus))
end run
----------------------OO TAG COLUMNS-----------------------
-- columnsFromTags :: [(String, [String])] -> OmniOutliner IO ()
on columnsFromTags(thesaurusEntries)
tell application "OmniOutliner"
if 0 < (count of documents) then
my updatedTagColsFromThesaurus(thesaurusEntries, front document)
else
"No document open in OmniOutliner"
end if
end tell
end columnsFromTags
-- thesaurusFromFilePath :: FilePath -> Either String [(String, [String])]
on thesaurusFromFilePath(fp)
if doesFileExist(fp) then
set strThesaurus to readFile(fpThesaurus)
set trees to ¬
forestFromLineIndents(indentLevelsFromLines(paragraphs of strThesaurus))
script tagGroup
on |λ|(tree)
script go
on |λ|(x, xs)
Tuple(x, map(my fst, xs))
end |λ|
end script
foldTree(go, tree)
end |λ|
end script
|Right|(map(tagGroup, trees))
else
|Left|("Thesaurus outline not found at " & fpThesaurus)
end if
end thesaurusFromFilePath
-- updateTagColsFromThesaurus :: [(String, [String])] -> OO Doc -> IO String
on updatedTagColsFromThesaurus(lexicon, oDoc)
using terms from application "OmniOutliner"
set colNames to {"Tags"} & my map(my fst, lexicon)
set tagCols to my map(my columnFoundOrCreated(oDoc), colNames)
script go
on |λ|(oRow)
set {lstUnallocated, lstTaggings} to my listFromTuple(tagParse(lexicon, ¬
value of cell "Tags" of oRow))
----------ROW UPDATED FROM THESAURUS ENTRIES-----------
script tagUpdates
on |λ|(acc, kvs)
set {label, vs} to kvs
set value of cell label of acc to my intercalate(";", vs)
acc
end |λ|
end script
my foldl(tagUpdates, oRow, lstTaggings)
--------ANY REMAINING TAGS WITH NO THESAURUS ENTRY---------
if 0 < length of lstUnallocated then
set colOther to |λ|("Other") of columnFoundOrCreated(oDoc)
set strOther to intercalate(";", lstUnallocated)
set value of cell "Other" of oRow to strOther
set strMsg to anyUnallocated(strOther)
else
set strMsg to ""
end if
----------------------LOG OF RESULTS-----------------------
set strTopic to topic of oRow
if 0 < length of strTopic then
script report
on |λ|(colName)
set mb to (value of (cell colName of oRow)) as string
if 0 < length of mb then
{tab & colName & " : " & mb}
else
{}
end if
end |λ|
end script
{strTopic & " ->\n" & my unlines(my concatMap(report, ¬
rest of colNames)) & linefeed & strMsg}
else
{}
end if
end |λ|
end script
my unlines(my concatMap(go, rows of oDoc))
end using terms from
end updatedTagColsFromThesaurus
-- anyUnallocated :: String -> String
on anyUnallocated(s)
if 0 < length of s then
"\tOTHER: " & s & linefeed
else
""
end if
end anyUnallocated
------------------------OO GENERIC-------------------------
-- columnFoundOrCreated :: OO Doc -> String -> OO Column
on columnFoundOrCreated(oDoc)
script go
on |λ|(strColName)
using terms from application "OmniOutliner"
set cols to columns of oDoc where name is strColName
if 0 < (count of cols) then
item 1 of cols
else
tell oDoc to make new column with properties {name:strColName}
end if
end using terms from
end |λ|
end script
end columnFoundOrCreated
-------------------------TAG PARSE-------------------------
-- tagParse ::[(String, [String])] -> String -> ([String], [(String, [String])])
on tagParse(lexicon, strTags)
-- Tuple resulting from a parse of a semi-colon delimited string
-- in terms of a thesaurus.
-- (Remaining unallocated tags, plus a list of (label, instances) pairs)
set ks to splitOn(";", strTags)
script go
on |λ|(a, tpl)
set residue to fst(a)
if 0 < length of residue then
set examples to snd(tpl)
script p
on |λ|(x)
examples contains x
end |λ|
end script
set tplParts to partition(p, residue)
set harvest to fst(tplParts)
set unallocated to snd(tplParts)
if 0 < length of harvest then
Tuple(unallocated, snd(a) & {{fst(tpl), harvest}})
else
a
end if
else
a
end if
end |λ|
end script
foldl(go, Tuple(ks, {}), lexicon)
end tagParse
--------------------------GENERIC--------------------------
-- https://github.com/RobTrew/prelude-applescript
-- Left :: a -> Either a b
on |Left|(x)
{type:"Either", |Left|:x, |Right|:missing value}
end |Left|
-- Right :: b -> Either a b
on |Right|(x)
{type:"Either", |Left|:missing value, |Right|:x}
end |Right|
-- Node :: a -> [Tree a] -> Tree a
on Node(v, xs)
{type:"Node", root:v, nest:xs}
end Node
-- Tuple (,) :: a -> b -> (a, b)
on Tuple(a, b)
-- Constructor for a pair of values, possibly of two different types.
{type:"Tuple", |1|:a, |2|:b, length:2}
end Tuple
-- alert :: String -> String -> IO ()
on alert(strTitle)
script
on |λ|(s)
tell current application
activate
display dialog s with title strTitle buttons {"OK"} default button "OK"
return s
end tell
end |λ|
end script
end alert
-- compose (<<<) :: (b -> c) -> (a -> b) -> a -> c
on compose(f, g)
script
property mf : mReturn(f)
property mg : mReturn(g)
on |λ|(x)
mf's |λ|(mg's |λ|(x))
end |λ|
end script
end compose
-- concatMap :: (a -> [b]) -> [a] -> [b]
on concatMap(f, xs)
set lng to length of xs
set acc to {}
tell mReturn(f)
repeat with i from 1 to lng
set acc to acc & (|λ|(item i of xs, i, xs))
end repeat
end tell
return acc
end concatMap
-- div :: Int -> Int -> Int
on |div|(a, b)
a div b
end |div|
-- doesFileExist :: FilePath -> IO Bool
on doesFileExist(strPath)
set ca to current application
set oPath to (ca's NSString's stringWithString:strPath)'s ¬
stringByStandardizingPath
set {bln, int} to (ca's NSFileManager's defaultManager's ¬
fileExistsAtPath:oPath isDirectory:(reference))
bln and (int ≠ 1)
end doesFileExist
-- either :: (a -> c) -> (b -> c) -> Either a b -> c
on either(lf, rf, e)
if missing value is |Left| of e then
tell mReturn(rf) to |λ|(|Right| of e)
else
tell mReturn(lf) to |λ|(|Left| of e)
end if
end either
-- Lift a simple function to one which applies to a tuple,
-- transforming only the first item of the tuple
-- firstArrow :: (a -> b) -> ((a, c) -> (b, c))
on firstArrow(f)
script
on |λ|(xy)
Tuple(mReturn(f)'s |λ|(|1| of xy), |2| of xy)
end |λ|
end script
end firstArrow
-- flip :: (a -> b -> c) -> b -> a -> c
on flip(f)
script
property g : mReturn(f)
on |λ|(x, y)
g's |λ|(y, x)
end |λ|
end script
end flip
-- foldl :: (a -> b -> a) -> a -> [b] -> a
on foldl(f, startValue, xs)
tell mReturn(f)
set v to startValue
set lng to length of xs
repeat with i from 1 to lng
set v to |λ|(v, item i of xs, i, xs)
end repeat
return v
end tell
end foldl
-- foldTree :: (a -> [b] -> b) -> Tree a -> b
on foldTree(f, tree)
script go
property g : mReturn(f)'s |λ|
on |λ|(oNode)
g(root of oNode, map(go, nest of oNode))
end |λ|
end script
|λ|(tree) of go
end foldTree
-- forestFromLineIndents :: [(Int, String)] -> [Tree String]
on forestFromLineIndents(tuples)
script go
on |λ|(xs)
if 0 < length of xs then
set {n, s} to listFromTuple(item 1 of xs)
script lessIndented
on |λ|(x)
n < fst(x)
end |λ|
end script
set {firstTreeLines, rs} to ¬
listFromTuple(|λ|(rest of xs) of span(lessIndented))
{Node(s, |λ|(firstTreeLines))} & |λ|(rs)
else
{}
end if
end |λ|
end script
|λ|(tuples) of go
end forestFromLineIndents
-- fst :: (a, b) -> a
on fst(tpl)
if class of tpl is record then
|1| of tpl
else
item 1 of tpl
end if
end fst
-- identity :: a -> a
on identity(x)
-- The argument unchanged.
x
end identity
-- indentLevelsFromLines :: [String] -> [(Int, String)]
on indentLevelsFromLines(xs)
set indentTextPairs to map(compose(firstArrow(my |length|), span(my isSpace)), xs)
script indentSize
on |λ|(tpl)
set w to fst(tpl)
if 0 < w then
{w}
else
{}
end if
end |λ|
end script
set indentUnit to minimum(concatMap(indentSize, indentTextPairs))
script indentDepth
on |λ|(x)
x div indentUnit
end |λ|
end script
map(firstArrow(indentDepth, indentTextPairs), indentTextPairs)
end indentLevelsFromLines
-- intercalate :: String -> [String] -> String
on intercalate(delim, xs)
set {dlm, my text item delimiters} to ¬
{my text item delimiters, delim}
set str to xs as text
set my text item delimiters to dlm
str
end intercalate
-- isSpace :: Char -> Bool
on isSpace(c)
set i to id of c
32 = i or (9 ≤ i and 13 ≥ i)
end isSpace
-- length :: [a] -> Int
on |length|(xs)
set c to class of xs
if list is c or string is c then
length of xs
else
(2 ^ 29 - 1) -- (maxInt - simple proxy for non-finite)
end if
end |length|
-- listFromTuple :: (a, a ...) -> [a]
on listFromTuple(tpl)
items 2 thru -2 of (tpl as list)
end listFromTuple
-- map :: (a -> b) -> [a] -> [b]
on map(f, xs)
-- The list obtained by applying f
-- to each element of xs.
tell mReturn(f)
set lng to length of xs
set lst to {}
repeat with i from 1 to lng
set end of lst to |λ|(item i of xs, i, xs)
end repeat
return lst
end tell
end map
-- minimum :: Ord a => [a] -> a
on minimum(xs)
set lng to length of xs
if lng < 1 then return missing value
set m to item 1 of xs
repeat with x in xs
set v to contents of x
if v < m then set m to v
end repeat
return m
end minimum
-- mReturn :: First-class m => (a -> b) -> m (a -> b)
on mReturn(f)
-- 2nd class handler function lifted into 1st class script wrapper.
if script is class of f then
f
else
script
property |λ| : f
end script
end if
end mReturn
-- partition :: (a -> Bool) -> [a] -> ([a], [a])
on partition(f, xs)
tell mReturn(f)
set ys to {}
set zs to {}
repeat with x in xs
set v to contents of x
if |λ|(v) then
set end of ys to v
else
set end of zs to v
end if
end repeat
end tell
Tuple(ys, zs)
end partition
-- readFile :: FilePath -> IO String
on readFile(strPath)
set ca to current application
set e to reference
set {s, e} to (ca's NSString's ¬
stringWithContentsOfFile:((ca's NSString's ¬
stringWithString:strPath)'s ¬
stringByStandardizingPath) ¬
encoding:(ca's NSUTF8StringEncoding) |error|:(e))
if missing value is e then
s as string
else
(localizedDescription of e) as string
end if
end readFile
-- snd :: (a, b) -> b
on snd(tpl)
if class of tpl is record then
|2| of tpl
else
item 2 of tpl
end if
end snd
-- span :: (a -> Bool) -> [a] -> ([a], [a])
on span(f)
-- The longest (possibly empty) prefix of xs
-- that contains only elements satisfying p,
-- tupled with the remainder of xs.
-- span(p, xs) eq (takeWhile(p, xs), dropWhile(p, xs))
script
on |λ|(xs)
set lng to length of xs
set i to 0
tell mReturn(f)
repeat while lng > i and |λ|(item (1 + i) of xs)
set i to 1 + i
end repeat
end tell
splitAt(i, xs)
end |λ|
end script
end span
-- splitAt :: Int -> [a] -> ([a], [a])
on splitAt(n, xs)
if n > 0 and n < length of xs then
if class of xs is text then
Tuple(items 1 thru n of xs as text, ¬
items (n + 1) thru -1 of xs as text)
else
Tuple(items 1 thru n of xs, items (n + 1) thru -1 of xs)
end if
else
if n < 1 then
Tuple({}, xs)
else
Tuple(xs, {})
end if
end if
end splitAt
-- splitOn :: String -> String -> [String]
on splitOn(pat, src)
set {dlm, my text item delimiters} to ¬
{my text item delimiters, pat}
set xs to text items of src
set my text item delimiters to dlm
return xs
end splitOn
-- unlines :: [String] -> String
on unlines(xs)
-- A single string formed by the intercalation
-- of a list of strings with the newline character.
set {dlm, my text item delimiters} to ¬
{my text item delimiters, linefeed}
set str to xs as text
set my text item delimiters to dlm
str
end unlines
