-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

-- | Pull deriver call documentation out of a Performance and format it nicely.
module Cmd.CallDoc where
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Text as Text
import qualified Data.Text.Lazy as Lazy

import qualified Util.Doc as Doc
import qualified Util.Format as Format
import           Util.Format ((<+/>), (<+>), (<//>), (</>))
import qualified Util.Html as Html
import           Util.Html (html, tag)
import qualified Util.Lists as Lists
import qualified Util.Texts as Texts

import qualified Cmd.Cmd as Cmd
import qualified Cmd.Perf as Perf
import qualified Derive.Call.Module as Module
import qualified Derive.Call.Tags as Tags
import qualified Derive.Derive as Derive
import qualified Derive.Expr as Expr
import qualified Derive.Library as Library
import qualified Derive.ParseTitle as ParseTitle
import qualified Derive.Sig as Sig

import qualified Perform.Pitch as Pitch
import qualified Ui.Ui as Ui

import           Global
import           Types


-- * output

-- | Convert a Document to plain text.
doc_text :: Document -> Lazy.Text
doc_text :: Document -> Text
doc_text = Text -> Width -> Doc -> Text
Format.render Text
"  " Width
75 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap forall {a}. Pretty a => (Text, [(a, [CallBindings])]) -> Doc
section
    where
    section :: (Text, [(a, [CallBindings])]) -> Doc
section (Text
call_kind, [(a, [CallBindings])]
scope_docs) =
        Doc
"##" Doc -> Doc -> Doc
<+> Text -> Doc
Format.text Text
call_kind Doc -> Doc -> Doc
<+> Doc
"calls" forall a. Semigroup a => a -> a -> a
<> Doc
"\n\n"
        forall a. Semigroup a => a -> a -> a
<> forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap forall {a}. Pretty a => (a, [CallBindings]) -> Doc
scope_doc [(a, [CallBindings])]
scope_docs
    scope_doc :: (a, [CallBindings]) -> Doc
scope_doc (a
source, [CallBindings]
calls) = Doc
"### from" Doc -> Doc -> Doc
<+> Text -> Doc
Format.text (forall a. Pretty a => a -> Text
pretty a
source)
        forall a. Semigroup a => a -> a -> a
<> Doc
"\n\n" forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
Format.unlines (forall a b. (a -> b) -> [a] -> [b]
map (Bool -> CallBindings -> Doc
call_bindings_text Bool
True) [CallBindings]
calls)

call_bindings_text :: Bool -> CallBindings -> Format.Doc
call_bindings_text :: Bool -> CallBindings -> Doc
call_bindings_text Bool
include_module ([Binding]
binds, CallType
ctype, CallDoc
call_doc) =
    [Doc] -> Doc
Format.unlines (forall a b. (a -> b) -> [a] -> [b]
map Binding -> Doc
show_bind [Binding]
binds)
    Doc -> Doc -> Doc
</> CallDoc -> Doc
show_call_doc CallDoc
call_doc
    forall a. Semigroup a => a -> a -> a
<> Doc
"\n\n"
    where
    show_bind :: Binding -> Doc
show_bind (Text
sym, Derive.CallName Text
name) =
        Text -> Doc
Format.text Text
sym Doc -> Doc -> Doc
<+> Doc
"--" Doc -> Doc -> Doc
<+> Text -> Doc
Format.text Text
name
        Doc -> Doc -> Doc
<+> (if Bool
include_module
            then Text -> Doc
Format.text (Module -> Text
show_module (CallDoc -> Module
Derive.cdoc_module CallDoc
call_doc))
            else forall a. Monoid a => a
mempty)
        Doc -> Doc -> Doc
<+> (Doc
"(" forall a. Semigroup a => a -> a -> a
<> Text -> Doc
Format.text (forall a. Pretty a => a -> Text
pretty CallType
ctype) forall a. Semigroup a => a -> a -> a
<> Doc
")")
    show_call_doc :: CallDoc -> Doc
show_call_doc (Derive.CallDoc Module
_module Tags
tags Doc
doc [ArgDoc]
args)
        | Tags
tags forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ArgDoc]
args = Doc -> Doc
write_doc Doc
doc
        | Bool
otherwise = Doc -> Doc
write_doc Doc
doc Doc -> Doc -> Doc
<//> Tags -> Doc
write_tags Tags
tags
            forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
Format.indentLine ([ArgDoc] -> Doc
arg_docs [ArgDoc]
args)
    arg_docs :: [ArgDoc] -> Doc
arg_docs = [Doc] -> Doc
Format.unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ArgDoc -> Doc
arg_doc
    arg_doc :: ArgDoc -> Doc
arg_doc (Derive.ArgDoc ArgName
name Type
typ ArgParser
parser EnvironDefault
env_default Doc
doc) =
        Text -> Doc
Format.text (ArgName -> Text
unname ArgName
name forall a. Semigroup a => a -> a -> a
<> Text
super forall a. Semigroup a => a -> a -> a
<> Text
" :: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Type
typ
            forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (Text
" = "<>) Maybe Text
deflt
            forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> ArgName -> EnvironDefault -> Text
environ_keys ArgName
name EnvironDefault
env_default
            forall a. Semigroup a => a -> a -> a
<> Text
" --")
        Doc -> Doc -> Doc
<+/> Doc -> Doc
write_doc Doc
doc
        where
        (Maybe Text
super_, Maybe Text
deflt) = ArgParser -> (Maybe Text, Maybe Text)
show_parser ArgParser
parser
        super :: Text
super = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (\Text
t -> if Text -> Width
Text.length Text
t forall a. Eq a => a -> a -> Bool
== Width
1 then Text
t else Text
" " forall a. Semigroup a => a -> a -> a
<> Text
t)
            Maybe Text
super_
    write_tags :: Tags -> Doc
write_tags Tags
tags
        -- Otherwise there's nothing separating the call doc and args doc.
        | Tags
tags forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty = Doc
"Args:"
        | Bool
otherwise = Text -> Doc
Format.text forall a b. (a -> b) -> a -> b
$ Text
"Tags: "
            forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " (Tags -> [Text]
Tags.untag Tags
tags)
    unname :: ArgName -> Text
unname (Derive.ArgName Text
s) = Text
s

environ_keys :: Derive.ArgName -> Sig.EnvironDefault -> Text
environ_keys :: ArgName -> EnvironDefault -> Text
environ_keys ArgName
name EnvironDefault
deflt =
    Text
"[" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " (CallName -> ArgName -> EnvironDefault -> [Text]
Sig.environ_keys CallName
"*" ArgName
name EnvironDefault
deflt) forall a. Semigroup a => a -> a -> a
<> Text
"]"

write_doc :: Doc.Doc -> Format.Doc
write_doc :: Doc -> Doc
write_doc =
    Doc -> Doc
Format.indent forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
Format.wrapWords forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Text -> Doc
Format.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
Text.words forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Text
undoc
    where undoc :: Doc -> Text
undoc (Doc.Doc Text
s) = Text
s

show_module :: Module.Module -> Text
show_module :: Module -> Text
show_module (Module.Module Text
name) = Text
"[" forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
"]"

show_parser :: Derive.ArgParser -> (Maybe Text, Maybe Text)
    -- ^ (superscript to mark this arg, default value)
show_parser :: ArgParser -> (Maybe Text, Maybe Text)
show_parser ArgParser
p = case ArgParser
p of
    ArgParser
Derive.Required -> (forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
    Derive.Defaulted Text
deflt -> (forall a. Maybe a
Nothing, forall a. a -> Maybe a
Just Text
deflt)
    Derive.Optional Text
deflt -> (forall a. a -> Maybe a
Just Text
"?", forall a. a -> Maybe a
Just Text
deflt)
    ArgParser
Derive.Many -> (forall a. a -> Maybe a
Just Text
"*", forall a. Maybe a
Nothing)
    ArgParser
Derive.Many1 -> (forall a. a -> Maybe a
Just Text
"+", forall a. Maybe a
Nothing)
    Derive.Environ Maybe Text
deflt -> (forall a. a -> Maybe a
Just Text
"env", Maybe Text
deflt)

{- | Print an abbreviated list of calls, grouped by namespace and ordered by
    shadowing priority.  Should look like:

    >     note generator
    > n -- note (instrument) [inst] When the event has zero duration, dispatc...
    > n -- note (imported) [prelude] The note call is the main note generator...
    >     note transformer
    > n -- note-attributes (imported) [prelude] This is similar to to `=`, bu...
-}
bindings_text :: Document -> Text
bindings_text :: Document -> Text
bindings_text =
    [Text] -> Text
Text.unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Text.null) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a} {a}.
(Pretty a, Pretty a) =>
((Text, a), [(a, (Binding, CallDoc))]) -> [Text]
section forall b c a. (b -> c) -> (a -> b) -> a -> c
. Document
-> [((Text, CallType), [(ScopeSource, (Binding, CallDoc))])]
flatten
    where
    section :: ((Text, a), [(a, (Binding, CallDoc))]) -> [Text]
section ((Text
call_kind, a
call_type), [(a, (Binding, CallDoc))]
bindings)
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(a, (Binding, CallDoc))]
bindings = []
        | Bool
otherwise = Text
"\t" forall a. Semigroup a => a -> a -> a
<> Text
call_kind forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty a
call_type
            forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Pretty a => (a, (Binding, CallDoc)) -> Text
binding [(a, (Binding, CallDoc))]
bindings
    binding :: (a, (Binding, CallDoc)) -> Text
binding (a
scope_source,
            ((Text
symbol_name, Derive.CallName Text
call_name), CallDoc
call_doc)) =
        Text
doc forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Width -> Text -> Text
Texts.ellipsis (Width
width forall a. Num a => a -> a -> a
- Text -> Width
Text.length Text
doc forall a. Num a => a -> a -> a
- Width
1)
            (Doc -> Text
undoc (CallDoc -> Doc
Derive.cdoc_doc CallDoc
call_doc))
        where
        undoc :: Doc -> Text
undoc (Doc.Doc Text
d) = Text
d
        doc :: Text
doc = Text
symbol_name forall a. Semigroup a => a -> a -> a
<> Text
" -- " forall a. Semigroup a => a -> a -> a
<> Text
call_name forall a. Semigroup a => a -> a -> a
<> Text
" (" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty a
scope_source
            forall a. Semigroup a => a -> a -> a
<> Text
") " forall a. Semigroup a => a -> a -> a
<> Module -> Text
show_module (CallDoc -> Module
Derive.cdoc_module CallDoc
call_doc)
    width :: Width
width = Width
76
    flatten :: Document
        -> [((CallKind, CallType), [(ScopeSource, (Binding, Derive.CallDoc))])]
    flatten :: Document
-> [((Text, CallType), [(ScopeSource, (Binding, CallDoc))])]
flatten Document
sections = forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall k a. Ord k => (a -> k) -> [a] -> [a]
Lists.sortOn forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat)) forall a b. (a -> b) -> a -> b
$ forall a b. Ord a => [(a, b)] -> [(a, NonNull b)]
Lists.groupFst
        [ ((Text
call_kind, CallType
call_type),
            forall a b. (a -> b) -> [a] -> [b]
map (ScopeSource
scope_source,) (forall a b. (a -> b) -> [a] -> [b]
map (, CallDoc
call_doc) [Binding]
bindings))
        | (Text
call_kind, [ScopeDoc]
scope_docs) <- Document
sections
        , (ScopeSource
scope_source, [CallBindings]
call_bindings) <- [ScopeDoc]
scope_docs
        , ([Binding]
bindings, CallType
call_type, CallDoc
call_doc) <- [CallBindings]
call_bindings
        ]

-- ** html output

-- | Convert a Document to HTML.
doc_html :: Html.HtmlState -> Document -> Html.Html
doc_html :: HtmlState -> Document -> Html
doc_html HtmlState
hstate = (HtmlState -> Html
html_header HtmlState
hstate <>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap forall {a}. Pretty a => (Text, [(Maybe a, [CallBindings])]) -> Html
section
    where
    section :: (Text, [(Maybe a, [CallBindings])]) -> Html
section (Text
call_kind, [(Maybe a, [CallBindings])]
scope_docs) =
        Text -> Text -> Html -> Html
Html.tag_class Text
"div" Text
"call-kind" forall a b. (a -> b) -> a -> b
$ Text -> Html -> Html
tag Text
"h2" (Text -> Html
html Text
call_kind)
            forall a. Semigroup a => a -> a -> a
<> Html
"\n\n" forall a. Semigroup a => a -> a -> a
<> forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap (forall {a}. Pretty a => Text -> (Maybe a, [CallBindings]) -> Html
scope_doc Text
call_kind) [(Maybe a, [CallBindings])]
scope_docs
    scope_doc :: Text -> (Maybe a, [CallBindings]) -> Html
scope_doc Text
call_kind (Maybe a
maybe_source, [CallBindings]
call_bindings) = case Maybe a
maybe_source of
        -- 'imported_scope_doc' does this since Library doesn't have source
        -- types.
        Maybe a
Nothing -> Html
doc
        Just a
source -> Text -> Text -> Html -> Html
Html.tag_class Text
"div" Text
"call-source" forall a b. (a -> b) -> a -> b
$
            Text -> Html -> Html
tag Text
"h3" (Html
"from " forall a. Semigroup a => a -> a -> a
<> Text -> Html
html (forall a. Pretty a => a -> Text
pretty a
source)) forall a. Semigroup a => a -> a -> a
<> Html
"\n\n" forall a. Semigroup a => a -> a -> a
<> Html
doc
        where
        doc :: Html
doc = Html
"<dl class=main-dl>\n"
            forall a. Semigroup a => a -> a -> a
<> forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap (Text -> (Module, [CallBindings]) -> Html
show_module_group Text
call_kind)
                (forall key a. Ord key => (a -> key) -> [a] -> [(key, [a])]
Lists.keyedGroupSort forall {a} {b}. (a, b, CallDoc) -> Module
module_of [CallBindings]
call_bindings)
            forall a. Semigroup a => a -> a -> a
<> Html
"</dl>\n"
    module_of :: (a, b, CallDoc) -> Module
module_of (a
_, b
_, CallDoc
call_doc) = CallDoc -> Module
Derive.cdoc_module CallDoc
call_doc
    show_module_group :: Text -> (Module, [CallBindings]) -> Html
show_module_group Text
call_kind (Module
module_, [CallBindings]
call_bindings) =
        Text -> Text -> Html -> Html
Html.tag_class Text
"div" Text
"call-module" forall a b. (a -> b) -> a -> b
$
            forall {a}. Show a => Module -> a -> Html
show_module Module
module_ (forall (t :: * -> *) a. Foldable t => t a -> Width
length [CallBindings]
call_bindings) forall a. Semigroup a => a -> a -> a
<> Html
"<br>\n"
            forall a. Semigroup a => a -> a -> a
<> forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap (HtmlState -> Text -> CallBindings -> Html
call_bindings_html HtmlState
hstate Text
call_kind) [CallBindings]
call_bindings
    show_module :: Module -> a -> Html
show_module (Module.Module Text
m) a
calls = Text -> Html -> Html
tag Text
"center" forall a b. (a -> b) -> a -> b
$
        Text -> Html -> Html
tag Text
"b" Html
"Module: " forall a. Semigroup a => a -> a -> a
<> Text -> Html -> Html
tag Text
"code" (Text -> Html
html Text
m)
            forall a. Semigroup a => a -> a -> a
<> Html
" (" forall a. Semigroup a => a -> a -> a
<> Text -> Html
html (forall a. Show a => a -> Text
showt a
calls) forall a. Semigroup a => a -> a -> a
<> Html
" calls)"

html_header :: Html.HtmlState -> Html.Html
html_header :: HtmlState -> Html
html_header HtmlState
hstate = forall a. Monoid a => [a] -> a
mconcat
    [ Html
"<meta charset=utf-8>\n"
    , Html
"<style type=text/css>\n" forall a. Semigroup a => a -> a -> a
<> Html
css forall a. Semigroup a => a -> a -> a
<> Html
"</style>\n"
    , Html
"<script>\n" forall a. Semigroup a => a -> a -> a
<> Html
javascript forall a. Semigroup a => a -> a -> a
<> Html
"\n</script>\n"
    , forall a. Monoid a => a -> [a] -> a
Lists.join Html
"; "
        [ Html
"<code>arg<sup>?</sup></code> &mdash; optional arg"
        , Html
"<code>arg<sup>*</sup></code> &mdash; zero or more args"
        , Html
"<code>arg<sup>+</sup></code> &mdash; one or more args"
        , Html
"<code>arg<sup>env</sup></code> &mdash; looked up in the environ"
        , Html
"<code>arg = val</code> &mdash; arg with default"
        , Html
":: <em>type</em> &mdash; argument type"
        , Html
"<code>[*-arg arg]</code> &mdash; default from environ values\
            \ <code>name-arg</code> followed by <code>arg</code>"
        ]
    , Html
"<p> <code>word</code> to include a tag containing the word,\
        \ <code>-word</code> to\n\
        \exclude.  Prefix with <code>m:</code> for modules,\
        \ <code>kind:(note|control|pitch|val)</code> for call kinds, or\
        \ <code>type:(val|generator|transformer)</code> for call types.\n\
        \<input id=input type=text size=60 value=\"" forall a. Semigroup a => a -> a -> a
<> Html
default_search
        forall a. Semigroup a => a -> a -> a
<> Html
"\" onchange=\"search(this.value)\">\n\
        \<br>You can also search by <code>%control</code>, arg default\n\
        \(<code>name-arg</code>), and call kind (<code>note</code>,\n\
        \<code>control</code>, ...).\
        \\n<br>Search for calls with the browser's text search, \"call --\"\
        \ to search by binding, \"-- call\" to search by name.\n<br>"
    , HtmlState -> Doc -> Html
Html.html_doc HtmlState
hstate Doc
"Common tags are documented at 'Derive.Call.Tags'."
    , Html
"\n<p> <span id=totals> x </span>\n"
    ]
    where default_search :: Html
default_search = Html
"-m:internal -m:ly "

css :: Html.Html
css :: Html
css = forall a. Monoid a => a -> [a] -> a
Lists.join Html
"\n"
    [ Html
".main-dl dl { border-bottom: 1px solid #999 }"
    , Html
"dl.compact {"
    , Html
"    margin: 0px;"
    , Html
"    padding: 0;"
    , Html
"}"
    , Html
"ul { margin: 0; }"
    , Html
"div { margin-bottom: 10px; }"
    , Html
".compact dt {"
    , Html
"    margin: 0;"
    , Html
"    padding: 0;"
    , Html
"}"
    , Html
".compact dd {"
    , Html
"    margin: 0 0 1em 0;"
    , Html
"    padding: 0;"
    , Html
"}"
    ]

javascript :: Html.Html
javascript :: Html
javascript = forall a. Monoid a => a -> [a] -> a
Lists.join Html
"\n"
    [ Html
search_javascript
    , Html
""
    , Html
hide_empty_javascript
    , Html
""
    , Html
"window.onload = function() {"
    , Html
"    var input = document.getElementById('input');"
    -- Theoretically this is useful, but in practice I'm usually reloading to
    -- see doc changes, and so auto-focus is just an annoyance.
    -- , "    input.focus();"
    -- , "    input.setSelectionRange(999, 999);"
    , Html
"    search(input.value);"
    , Html
"};"
    ]

search_javascript :: Html.Html
search_javascript :: Html
search_javascript = forall a. Monoid a => a -> [a] -> a
Lists.join Html
"\n"
    [ Html
"var total_calls = 0;"
    , Html
"var displayed_calls = 0;"
    , Html
"var search = function(val) {"
    , Html
"    var search_words = val.split(/ +/).filter("
    , Html
"        function(x) { return x != '' });"
    , Html
"    total_calls = 0;"
    , Html
"    displayed_calls = 0;"
    , Html
"    var calls = document.getElementsByClassName('call');"
    , Html
"    for (var i = 0; i < calls.length; i++) {"
    , Html
"        var c = calls[i];"
    , Html
"        var tags = c.attributes.tags.value.split(' ');"
    , Html
"        c.hidden = !matches(search_words, tags);"
    , Html
"        total_calls++;"
    , Html
"        if (!c.hidden) displayed_calls++;"
    , Html
"    }"
    , Html
"    hide_all_empty();"
    , Html
"    document.getElementById('totals').innerText ="
    , Html
"        'calls displayed/total: ' + displayed_calls + '/' + total_calls;"
    , Html
"};"
    , Html
""
    , Html
"var matches = function(search_words, tags) {"
    , Html
"    tags = tags.filter(function(x) { return x != '' });"
    , Html
"    return search_words.every(function(x) {"
    , Html
"        if (x[0] === '-')"
    , Html
"            return !tags_match(tags, x.slice(1));"
    , Html
"        else"
    , Html
"            return tags_match(tags, x);"
    , Html
"     });"
    , Html
"};"
    , Html
""
    , Html
"var tags_match = function(tags, val) {"
    , Html
"    return tags.some(function(t) { return t.indexOf(val) !== -1 });"
    , Html
"};"
    ]

hide_empty_javascript :: Html.Html
hide_empty_javascript :: Html
hide_empty_javascript = forall a. Monoid a => a -> [a] -> a
Lists.join Html
"\n"
    [ Html
"var hide_all_empty = function() {"
    , Html
"    hide_if_empty('call-module');"
    , Html
"    hide_if_empty('call-source');"
    , Html
"    hide_if_empty('call-kind');"
    , Html
"};"
    , Html
""
    , Html
"var hide_if_empty = function(class_) {"
    , Html
"    var elts = document.getElementsByClassName(class_);"
    , Html
"    for (var i = 0; i < elts.length; i++) {"
    , Html
"        elts[i].hidden = !any_shown_call(elts[i]);"
    , Html
"    }"
    , Html
"};"
    , Html
"" -- True if this has any unhidden 'call' children.
    , Html
"var any_shown_call = function(parent) {"
    , Html
"    for (var i = 0; i < parent.children.length; i++) {"
    , Html
"        var c = parent.children[i];"
    , Html
"        if (c.className === 'call' && !c.hidden || any_shown_call(c))"
    , Html
"            return true;"
    , Html
"    }"
    , Html
"    return false;"
    , Html
"};"
    ]

call_bindings_html :: Html.HtmlState -> Text -> CallBindings -> Html.Html
call_bindings_html :: HtmlState -> Text -> CallBindings -> Html
call_bindings_html HtmlState
hstate Text
call_kind bindings :: CallBindings
bindings@([Binding]
binds, CallType
ctype, CallDoc
call_doc) = forall a. Monoid a => [a] -> a
mconcat
    [ Html
"<div class=call tags=\"" forall a. Semigroup a => a -> a -> a
<> Text -> Html
html ([Text] -> Text
Text.unwords [Text]
tags) forall a. Semigroup a => a -> a -> a
<> Html
"\">"
    , forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap (forall {a}. Pretty a => a -> (Bool, Binding) -> Html
show_bind (CallDoc -> Module
Derive.cdoc_module CallDoc
call_doc))
        (forall a b. [a] -> [b] -> [(a, b)]
zip (Bool
True forall a. a -> [a] -> [a]
: forall a. a -> [a]
repeat Bool
False) [Binding]
binds)
        forall a. Semigroup a => a -> a -> a
<> CallDoc -> Html
show_call_doc CallDoc
call_doc
    , Html
"</div>\n\n"
    ]
    where
    tags :: [Text]
tags = Text
"kind:" forall a. Semigroup a => a -> a -> a
<> Text
call_kind forall a. a -> [a] -> [a]
: CallBindings -> [Text]
binding_tags CallBindings
bindings
    show_bind :: a -> (Bool, Binding) -> Html
show_bind a
module_ (Bool
first, (Text
sym, Derive.CallName Text
name)) =
        Html
"<dt>" forall a. Semigroup a => a -> a -> a
<> Text -> Html -> Html
tag Text
"code" (Text -> Html
html Text
sym)
        -- This used to be &mdash;, but that's too hard to use text search on.
        forall a. Semigroup a => a -> a -> a
<> Html
" -- " forall a. Semigroup a => a -> a -> a
<> Text -> Html -> Html
tag Text
"b" (Text -> Html
html Text
name)
        forall a. Semigroup a => a -> a -> a
<> (if Bool
first then forall {a}. Pretty a => a -> Html
show_ctype a
module_ else Html
"") forall a. Semigroup a => a -> a -> a
<> Html
"\n"
    show_ctype :: a -> Html
show_ctype a
module_ = forall a. Monoid a => [a] -> a
mconcat
        [ Html
"<div style='float:right'>"
        , Text -> Html -> Html
tag Text
"code" (Text -> Html
html (forall a. Pretty a => a -> Text
pretty a
module_))
        , Html
" : "
        , Text -> Html -> Html
tag Text
"em" (Text -> Html
html (Text
call_kind forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty CallType
ctype))
        , Html
"</div>"
        ]
    show_call_doc :: CallDoc -> Html
show_call_doc (Derive.CallDoc Module
_module Tags
tags Doc
doc [ArgDoc]
args) =
        Html
"<dd> <dl class=compact>\n"
        forall a. Semigroup a => a -> a -> a
<> HtmlState -> Doc -> Html
Html.html_doc HtmlState
hstate Doc
doc
        forall a. Semigroup a => a -> a -> a
<> Tags -> Html
write_tags Tags
tags forall a. Semigroup a => a -> a -> a
<> Html
"\n"
        forall a. Semigroup a => a -> a -> a
<> Text -> Html -> Html
tag Text
"ul" (forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap ArgDoc -> Html
arg_doc [ArgDoc]
args)
        forall a. Semigroup a => a -> a -> a
<> Html
"</dl>\n"
    arg_doc :: ArgDoc -> Html
arg_doc (Derive.ArgDoc ArgName
name Type
typ ArgParser
parser EnvironDefault
env_default Doc
doc) =
        Html
"<li" forall a. Semigroup a => a -> a -> a
<> Html
li_type forall a. Semigroup a => a -> a -> a
<> Html
">" forall a. Semigroup a => a -> a -> a
<> Text -> Html -> Html
tag Text
"code" (Text -> Html
html (ArgName -> Text
unname ArgName
name))
        forall a. Semigroup a => a -> a -> a
<> Maybe Text -> Html
show_char Maybe Text
char
        forall a. Semigroup a => a -> a -> a
<> Html
" :: " forall a. Semigroup a => a -> a -> a
<> Text -> Html -> Html
tag Text
"em" (Text -> Html
html (forall a. Pretty a => a -> Text
pretty Type
typ))
        forall a. Semigroup a => a -> a -> a
<> Maybe Text -> Html
show_default Maybe Text
deflt
        forall a. Semigroup a => a -> a -> a
<> Html
" " forall a. Semigroup a => a -> a -> a
<> Text -> Html -> Html
tag Text
"code" (Text -> Html
html (ArgName -> EnvironDefault -> Text
environ_keys ArgName
name EnvironDefault
env_default))
        forall a. Semigroup a => a -> a -> a
<> (if Doc
doc forall a. Eq a => a -> a -> Bool
== Doc
"" then Html
"" else Html
" &mdash; " forall a. Semigroup a => a -> a -> a
<> HtmlState -> Doc -> Html
Html.html_doc HtmlState
hstate Doc
doc)
        forall a. Semigroup a => a -> a -> a
<> Html
"\n"
        where
        unname :: ArgName -> Text
unname (Derive.ArgName Text
s) = Text
s
        (Maybe Text
char, Maybe Text
deflt) = ArgParser -> (Maybe Text, Maybe Text)
show_parser ArgParser
parser
        li_type :: Html
li_type = if forall a. Maybe a -> Bool
Maybe.isNothing Maybe Text
deflt then Html
""
            else Html
" style=list-style-type:circle"
    show_default :: Maybe Text -> Html
show_default = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Html
"" ((Html
" = " <>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Html -> Html
tag Text
"code" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Html
html)
    show_char :: Maybe Text -> Html
show_char = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Html
"" (Text -> Html -> Html
tag Text
"sup" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Html
html)
    write_tags :: Tags -> Html
write_tags Tags
tags
        | Tags
tags forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty = Html
""
        | Bool
otherwise = Html
"<br><b>Tags:</b> "
            forall a. Semigroup a => a -> a -> a
<> Text -> Html -> Html
tag Text
"em" (Text -> Html
html (Text -> [Text] -> Text
Text.intercalate Text
", " (Tags -> [Text]
Tags.untag Tags
tags)))

-- | Extract explicit tags as well as some implicit tags.  Implicit tags are
-- @%control@ for controls in the default arguments, @name-arg@ for environ
-- keys that default the arguments, and @note@, @control@, @pitch@, or @val@ for
-- the call kind.
binding_tags :: CallBindings -> [Text]
binding_tags :: CallBindings -> [Text]
binding_tags ([Binding]
binds, CallType
ctype, CallDoc
call_doc) =
    forall a. Ord a => [a] -> [a]
Lists.unique forall a b. (a -> b) -> a -> b
$ Text
"type:" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty CallType
ctype forall a. a -> [a] -> [a]
: CallDoc -> [Text]
extract CallDoc
call_doc
    where
    names :: [CallName]
names = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [Binding]
binds
    extract :: CallDoc -> [Text]
extract CallDoc
call_doc = Module -> Text
module_ (CallDoc -> Module
Derive.cdoc_module CallDoc
call_doc)
        forall a. a -> [a] -> [a]
: CallDoc -> [Text]
cdoc_tags CallDoc
call_doc forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ArgDoc -> [Text]
arg_tags (CallDoc -> [ArgDoc]
Derive.cdoc_args CallDoc
call_doc)
    cdoc_tags :: CallDoc -> [Text]
cdoc_tags = Tags -> [Text]
Tags.untag forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallDoc -> Tags
Derive.cdoc_tags
    module_ :: Module -> Text
module_ (Module.Module Text
m) = Text
"m:" forall a. Semigroup a => a -> a -> a
<> Text
m
    arg_tags :: ArgDoc -> [Text]
arg_tags ArgDoc
arg =
        [ CallName -> ArgName -> Text
Sig.prefixed_environ CallName
name (ArgDoc -> ArgName
Derive.arg_name ArgDoc
arg)
        | CallName
name <- [CallName]
names
        ] forall a. [a] -> [a] -> [a]
++ ArgParser -> [Text]
arg_control_tags (ArgDoc -> ArgParser
Derive.arg_parser ArgDoc
arg)
    -- An arg with a control signal default should look like "%sig,.5".
    -- This is a hack, since the default isn't stored in a structured way.
    arg_control_tags :: ArgParser -> [Text]
arg_control_tags (Derive.Defaulted Text
deflt)
        | Text
"%" Text -> Text -> Bool
`Text.isPrefixOf` Text
deflt = [(Char -> Bool) -> Text -> Text
Text.takeWhile (forall a. Eq a => a -> a -> Bool
/=Char
',') Text
deflt]
        | Bool
otherwise = []
    arg_control_tags ArgParser
_ = []


-- * scale doc

type Scale = [CallBindings]

scales_html :: Html.HtmlState -> [CallBindings] -> Html.Html
scales_html :: HtmlState -> [CallBindings] -> Html
scales_html HtmlState
hstate [CallBindings]
scales = HtmlState -> Html
html_header HtmlState
hstate
        forall a. Semigroup a => a -> a -> a
<> Html
"<h2>Scales</h2>\n"
        forall a. Semigroup a => a -> a -> a
<> Html
"<dl class=main-dl>\n" forall a. Semigroup a => a -> a -> a
<> [CallBindings] -> Html
scale_html [CallBindings]
scales forall a. Semigroup a => a -> a -> a
<> Html
"</dl>\n"
    where scale_html :: [CallBindings] -> Html
scale_html = forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap (HtmlState -> Text -> CallBindings -> Html
call_bindings_html HtmlState
hstate Text
"scale")

-- | Extract documentation from scales.
scale_docs :: [(Pitch.ScaleId, Text, Derive.DocumentedCall)] -> [CallBindings]
scale_docs :: [(ScaleId, Text, DocumentedCall)] -> [CallBindings]
scale_docs = [CallBindings] -> [CallBindings]
sort_calls forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallType -> [Entry] -> [CallBindings]
entries CallType
ValCall forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {a} {call}.
Pretty a =>
(a, Text, DocumentedCall) -> Entry call
convert
    where
    convert :: (a, Text, DocumentedCall) -> Entry call
convert (a
scale_id, Text
pattern, DocumentedCall
doc) = forall call. PatternCall call -> Entry call
Library.Pattern forall a b. (a -> b) -> a -> b
$
        forall call.
Text
-> DocumentedCall
-> (Symbol -> Deriver (Maybe call))
-> PatternCall call
Derive.PatternCall Text
desc DocumentedCall
doc (forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing))
        where desc :: Text
desc = forall a. Pretty a => a -> Text
pretty a
scale_id forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
pattern

-- * doc

-- | An intermediate format between 'Derive.Scopes' and the eventual textual
-- output.
type Document = [Section]

type Section = (CallKind, [ScopeDoc])

-- | From the fields of 'Derive.Scope' and 'Derive.Scopes': note, control,
-- pitch, or val.
type CallKind = Text

-- | Documentation for one type of scope.
type ScopeDoc = (ScopeSource, [CallBindings])

-- | Nothing is when the source is irrelevant, so don't put it in the docs.
type ScopeSource = Maybe Derive.CallPriority

-- | Multiple bound symbols with the same DocumentedCall are grouped together:
type CallBindings = ([Binding], CallType, Derive.CallDoc)
type Binding = (SymbolName, Derive.CallName)
-- | This is the name the call is bound to.
type SymbolName = Text

data CallType = ValCall | GeneratorCall | TransformerCall | TrackCall
    deriving (CallType -> CallType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CallType -> CallType -> Bool
$c/= :: CallType -> CallType -> Bool
== :: CallType -> CallType -> Bool
$c== :: CallType -> CallType -> Bool
Eq, Eq CallType
CallType -> CallType -> Bool
CallType -> CallType -> Ordering
CallType -> CallType -> CallType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CallType -> CallType -> CallType
$cmin :: CallType -> CallType -> CallType
max :: CallType -> CallType -> CallType
$cmax :: CallType -> CallType -> CallType
>= :: CallType -> CallType -> Bool
$c>= :: CallType -> CallType -> Bool
> :: CallType -> CallType -> Bool
$c> :: CallType -> CallType -> Bool
<= :: CallType -> CallType -> Bool
$c<= :: CallType -> CallType -> Bool
< :: CallType -> CallType -> Bool
$c< :: CallType -> CallType -> Bool
compare :: CallType -> CallType -> Ordering
$ccompare :: CallType -> CallType -> Ordering
Ord, Width -> CallType -> ShowS
[CallType] -> ShowS
CallType -> String
forall a.
(Width -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CallType] -> ShowS
$cshowList :: [CallType] -> ShowS
show :: CallType -> String
$cshow :: CallType -> String
showsPrec :: Width -> CallType -> ShowS
$cshowsPrec :: Width -> CallType -> ShowS
Show)

instance Pretty CallType where
    pretty :: CallType -> Text
pretty CallType
ctype = case CallType
ctype of
        CallType
ValCall -> Text
"val"
        CallType
GeneratorCall -> Text
"generator"
        CallType
TransformerCall -> Text
"transformer"
        CallType
TrackCall -> Text
"track"


-- ** implementation

-- | Keep only CallDocs whose name or binding name matches the function.
filter_calls :: (SymbolName -> Derive.CallName -> Bool) -> Document -> Document
filter_calls :: (Text -> CallName -> Bool) -> Document -> Document
filter_calls Text -> CallName -> Bool
matches = Document -> Document
strip_empty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {c}.
(a, [([Binding], b, c)]) -> (a, [([Binding], b, c)])
scope_doc))
    where
    scope_doc :: (a, [([Binding], b, c)]) -> (a, [([Binding], b, c)])
scope_doc = forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a b. (a -> b) -> [a] -> [b]
map forall {b} {c}. ([Binding], b, c) -> ([Binding], b, c)
call_bindings)
    call_bindings :: ([Binding], b, c) -> ([Binding], b, c)
call_bindings ([Binding]
bindings, b
call_type, c
call_doc) =
        (forall a. (a -> Bool) -> [a] -> [a]
filter Binding -> Bool
binding [Binding]
bindings, b
call_type, c
call_doc)
    binding :: Binding -> Bool
binding (Text
sym, CallName
call) = Text -> CallName -> Bool
matches Text
sym CallName
call

strip_empty :: Document -> Document
strip_empty :: Document -> Document
strip_empty = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {t :: * -> *} {a} {a} {a} {b} {c}.
Foldable t =>
(a, [(a, [(t a, b, c)])]) -> Maybe (a, [(a, [(t a, b, c)])])
section
    where
    section :: (a, [(a, [(t a, b, c)])]) -> Maybe (a, [(a, [(t a, b, c)])])
section (a
call_kind, [(a, [(t a, b, c)])]
scope_docs) = case forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {t :: * -> *} {a} {a} {b} {c}.
Foldable t =>
(a, [(t a, b, c)]) -> Maybe (a, [(t a, b, c)])
scope_doc [(a, [(t a, b, c)])]
scope_docs of
        [] -> forall a. Maybe a
Nothing
        [(a, [(t a, b, c)])]
stripped -> forall a. a -> Maybe a
Just (a
call_kind, [(a, [(t a, b, c)])]
stripped)
    scope_doc :: (a, [(t a, b, c)]) -> Maybe (a, [(t a, b, c)])
scope_doc (a
scope_source, [(t a, b, c)]
call_bindings) =
        case forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {t :: * -> *} {a} {b} {c}.
Foldable t =>
(t a, b, c) -> Maybe (t a, b, c)
call_binding [(t a, b, c)]
call_bindings of
            [] -> forall a. Maybe a
Nothing
            [(t a, b, c)]
stripped -> forall a. a -> Maybe a
Just (a
scope_source, [(t a, b, c)]
stripped)
    call_binding :: (t a, b, c) -> Maybe (t a, b, c)
call_binding b :: (t a, b, c)
b@(t a
bindings, b
_, c
_)
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
bindings = forall a. Maybe a
Nothing
        | Bool
otherwise = forall a. a -> Maybe a
Just (t a, b, c)
b

-- | Extract all the documentation from the Builtins.  Document extraction is
-- a big mess of walking over nested data and converting it to a parallel
-- nested data structure.  It's tedious, but the types make it hard to get
-- wrong.
builtins :: Derive.Builtins -> [Section]
builtins :: Builtins -> Document
builtins (Derive.Scopes
        (Derive.Scope ModuleMap (Generator Note)
ngen ModuleMap (Generator Control)
cgen ModuleMap (Generator Pitch)
pgen)
        (Derive.Scope ModuleMap (Transformer Note)
ntrans ModuleMap (Transformer Control)
ctrans ModuleMap (Transformer Pitch)
ptrans)
        (Derive.Scope ModuleMap (TrackCall Note)
ntrack ModuleMap (TrackCall Control)
ctrack ModuleMap (TrackCall Pitch)
ptrack)
        ModuleMap ValCall
val) =
    [ (Text
"note", forall gen trans track.
Map Module (CallMap (Call gen))
-> Map Module (CallMap (Call trans))
-> Map Module (CallMap (TrackCall track))
-> [ScopeDoc]
scope ModuleMap (Generator Note)
ngen ModuleMap (Transformer Note)
ntrans ModuleMap (TrackCall Note)
ntrack)
    , (Text
"control", forall gen trans track.
Map Module (CallMap (Call gen))
-> Map Module (CallMap (Call trans))
-> Map Module (CallMap (TrackCall track))
-> [ScopeDoc]
scope ModuleMap (Generator Control)
cgen ModuleMap (Transformer Control)
ctrans ModuleMap (TrackCall Control)
ctrack)
    , (Text
"pitch", forall gen trans track.
Map Module (CallMap (Call gen))
-> Map Module (CallMap (Call trans))
-> Map Module (CallMap (TrackCall track))
-> [ScopeDoc]
scope ModuleMap (Generator Pitch)
pgen ModuleMap (Transformer Pitch)
ptrans ModuleMap (TrackCall Pitch)
ptrack)
    , (Text
"val", forall call mod.
CallType
-> (call -> DocumentedCall) -> Map mod (CallMap call) -> [ScopeDoc]
convert_modules CallType
ValCall ValCall -> DocumentedCall
Derive.extract_val_doc ModuleMap ValCall
val)
    ]

convert_modules :: CallType -> (call -> Derive.DocumentedCall)
    -> Map mod (Derive.CallMap call) -> [ScopeDoc]
convert_modules :: forall call mod.
CallType
-> (call -> DocumentedCall) -> Map mod (CallMap call) -> [ScopeDoc]
convert_modules CallType
ctype call -> DocumentedCall
extract_doc = CallType -> [Entry] -> [ScopeDoc]
imported_scope_doc CallType
ctype
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (CallMap -> [Entry]
call_map_to_entries forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall call. (call -> DocumentedCall) -> CallMap call -> CallMap
call_map_doc call -> DocumentedCall
extract_doc)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
Map.elems

-- | Create docs for generator, transformer, and track calls, and merge and
-- sort them.
scope :: Map Module.Module (Derive.CallMap (Derive.Call gen))
    -> Map Module.Module (Derive.CallMap (Derive.Call trans))
    -> Map Module.Module (Derive.CallMap (Derive.TrackCall track))
    -> [ScopeDoc]
scope :: forall gen trans track.
Map Module (CallMap (Call gen))
-> Map Module (CallMap (Call trans))
-> Map Module (CallMap (TrackCall track))
-> [ScopeDoc]
scope Map Module (CallMap (Call gen))
gen Map Module (CallMap (Call trans))
trans Map Module (CallMap (TrackCall track))
track = [ScopeDoc] -> [ScopeDoc]
merge_scope_docs forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ forall call mod.
CallType
-> (call -> DocumentedCall) -> Map mod (CallMap call) -> [ScopeDoc]
convert_modules CallType
GeneratorCall forall d. Call d -> DocumentedCall
Derive.extract_doc Map Module (CallMap (Call gen))
gen
    , forall call mod.
CallType
-> (call -> DocumentedCall) -> Map mod (CallMap call) -> [ScopeDoc]
convert_modules CallType
TransformerCall forall d. Call d -> DocumentedCall
Derive.extract_doc Map Module (CallMap (Call trans))
trans
    , forall call mod.
CallType
-> (call -> DocumentedCall) -> Map mod (CallMap call) -> [ScopeDoc]
convert_modules CallType
TrackCall forall d. TrackCall d -> DocumentedCall
Derive.extract_track_doc Map Module (CallMap (TrackCall track))
track
    ]

-- | A 'Library.Entry' with the call stripped out and replaced with
-- just documentation.  This is so 'Derive.Call's and 'Derive.ValCall's can
-- be treated uniformly.
type Entry = Library.Entry Derive.DocumentedCall
type CallMap = Derive.CallMap Derive.DocumentedCall

-- | Convert 'Library.Entry' to 'Entry' by stripping out the code part of the
-- call, and replacing it with DocumentedCall.
entry_doc :: (call -> Derive.DocumentedCall) -> Library.Entry call -> Entry
entry_doc :: forall call. (call -> DocumentedCall) -> Entry call -> Entry
entry_doc call -> DocumentedCall
extract_doc (Library.Single Symbol
sym call
call) =
    forall call. Symbol -> call -> Entry call
Library.Single Symbol
sym (call -> DocumentedCall
extract_doc call
call)
entry_doc call -> DocumentedCall
_ (Library.Pattern PatternCall call
pattern) =
    forall call. PatternCall call -> Entry call
Library.Pattern forall a b. (a -> b) -> a -> b
$ PatternCall call
pattern { pat_function :: Symbol -> Deriver (Maybe DocumentedCall)
Derive.pat_function = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing }

call_map_doc :: (call -> Derive.DocumentedCall) -> Derive.CallMap call
    -> CallMap
call_map_doc :: forall call. (call -> DocumentedCall) -> CallMap call -> CallMap
call_map_doc call -> DocumentedCall
extract_doc (Derive.CallMap Map Symbol call
calls [PatternCall call]
patterns) = Derive.CallMap
    { call_map :: Map Symbol DocumentedCall
call_map = call -> DocumentedCall
extract_doc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Symbol call
calls
    , call_patterns :: [PatternCall DocumentedCall]
call_patterns =
        forall a b. (a -> b) -> [a] -> [b]
map (\PatternCall call
p -> PatternCall call
p { pat_function :: Symbol -> Deriver (Maybe DocumentedCall)
Derive.pat_function = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing }) [PatternCall call]
patterns
    }

-- ** instrument doc

-- | Get docs for the calls introduced by an instrument.
instrument_calls :: Derive.InstrumentCalls -> Document
instrument_calls :: InstrumentCalls -> Document
instrument_calls (Derive.Scopes CallMap (Generator Note)
gen CallMap (Transformer Note)
trans CallMap (TrackCall Note)
track CallMap ValCall
vals) =
    [ (Text
"note", [(forall a. a -> Maybe a
Just CallPriority
Derive.PrioInstrument, forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ forall {d}. CallType -> CallMap (Call d) -> [CallBindings]
ctype_entries CallType
GeneratorCall CallMap (Generator Note)
gen
        , forall {d}. CallType -> CallMap (Call d) -> [CallBindings]
ctype_entries CallType
TransformerCall CallMap (Transformer Note)
trans
        , forall {call}.
CallType
-> (call -> DocumentedCall) -> CallMap call -> [CallBindings]
call_map_entries CallType
TrackCall forall d. TrackCall d -> DocumentedCall
Derive.extract_track_doc CallMap (TrackCall Note)
track
        ])])
    , (Text
"val", [(forall a. a -> Maybe a
Just CallPriority
Derive.PrioInstrument,
        forall {call}.
CallType
-> (call -> DocumentedCall) -> CallMap call -> [CallBindings]
call_map_entries CallType
ValCall ValCall -> DocumentedCall
Derive.extract_val_doc CallMap ValCall
vals)])
    ]
    where
    ctype_entries :: CallType -> CallMap (Call d) -> [CallBindings]
ctype_entries CallType
ctype = forall {call}.
CallType
-> (call -> DocumentedCall) -> CallMap call -> [CallBindings]
call_map_entries CallType
ctype forall d. Call d -> DocumentedCall
Derive.extract_doc
    call_map_entries :: CallType
-> (call -> DocumentedCall) -> CallMap call -> [CallBindings]
call_map_entries CallType
ctype call -> DocumentedCall
extract_doc =
        CallType -> [Entry] -> [CallBindings]
entries CallType
ctype forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallMap -> [Entry]
call_map_to_entries forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall call. (call -> DocumentedCall) -> CallMap call -> CallMap
call_map_doc call -> DocumentedCall
extract_doc

-- ** track doc

-- | Get documentation for calls in scope at the given block and track.
track :: Cmd.M m => BlockId -> TrackId -> m Document
track :: forall (m :: * -> *). M m => BlockId -> TrackId -> m Document
track BlockId
block_id TrackId
track_id = do
    Dynamic
dynamic <- forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
Cmd.require Text
"CallDoc.track: no root dynamic"
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => Track -> m (Maybe Dynamic)
Perf.lookup_root_dynamic (BlockId
block_id, forall a. a -> Maybe a
Just TrackId
track_id)
    Type
ttype <- Text -> Type
ParseTitle.track_type forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => TrackId -> m Text
Ui.get_track_title TrackId
track_id
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Type -> Scopes -> Document
track_sections Type
ttype (Dynamic -> Scopes
Derive.state_scopes Dynamic
dynamic)

-- | This is an alternate doc extraction path which extracts the docs from
-- 'Derive.Scopes' instead of 'Derive.Builtins'.
track_sections :: ParseTitle.Type -> Derive.Scopes -> [Section]
track_sections :: Type -> Scopes -> Document
track_sections Type
ttype (Derive.Scopes
        (Derive.Scope ScopePriority (Generator Note)
gen_n ScopePriority (Generator Control)
gen_c ScopePriority (Generator Pitch)
gen_p)
        (Derive.Scope ScopePriority (Transformer Note)
trans_n ScopePriority (Transformer Control)
trans_c ScopePriority (Transformer Pitch)
trans_p)
        (Derive.Scope ScopePriority (TrackCall Note)
track_n ScopePriority (TrackCall Control)
track_c ScopePriority (TrackCall Pitch)
track_p)
        ScopePriority ValCall
val) =
    (\(Text, [ScopeDoc])
d -> [(Text, [ScopeDoc])
d, (Text
"val", [ScopeDoc]
val_doc)]) forall a b. (a -> b) -> a -> b
$ case Type
ttype of
        Type
ParseTitle.NoteTrack -> (Text
"note", forall {d} {d} {d}.
ScopePriority (Call d)
-> ScopePriority (Call d)
-> ScopePriority (TrackCall d)
-> [ScopeDoc]
merge3 ScopePriority (Generator Note)
gen_n ScopePriority (Transformer Note)
trans_n ScopePriority (TrackCall Note)
track_n)
        Type
ParseTitle.ControlTrack -> (Text
"control", forall {d} {d} {d}.
ScopePriority (Call d)
-> ScopePriority (Call d)
-> ScopePriority (TrackCall d)
-> [ScopeDoc]
merge3 ScopePriority (Generator Control)
gen_c ScopePriority (Transformer Control)
trans_c ScopePriority (TrackCall Control)
track_c)
        Type
ParseTitle.TempoTrack -> (Text
"tempo", forall {d} {d} {d}.
ScopePriority (Call d)
-> ScopePriority (Call d)
-> ScopePriority (TrackCall d)
-> [ScopeDoc]
merge3 ScopePriority (Generator Control)
gen_c ScopePriority (Transformer Control)
trans_c ScopePriority (TrackCall Control)
track_c)
        Type
ParseTitle.PitchTrack -> (Text
"pitch", forall {d} {d} {d}.
ScopePriority (Call d)
-> ScopePriority (Call d)
-> ScopePriority (TrackCall d)
-> [ScopeDoc]
merge3 ScopePriority (Generator Pitch)
gen_p ScopePriority (Transformer Pitch)
trans_p ScopePriority (TrackCall Pitch)
track_p)
    where
    merge3 :: ScopePriority (Call d)
-> ScopePriority (Call d)
-> ScopePriority (TrackCall d)
-> [ScopeDoc]
merge3 ScopePriority (Call d)
gen ScopePriority (Call d)
trans ScopePriority (TrackCall d)
track = [(CallType, ScopePriority DocumentedCall)] -> [ScopeDoc]
merged_scope_docs
        [ (CallType
GeneratorCall, forall {d}. ScopePriority (Call d) -> ScopePriority DocumentedCall
convert ScopePriority (Call d)
gen)
        , (CallType
TransformerCall, forall {d}. ScopePriority (Call d) -> ScopePriority DocumentedCall
convert ScopePriority (Call d)
trans)
        , (CallType
TrackCall,
            forall call.
(CallMap call -> CallMap)
-> ScopePriority call -> ScopePriority DocumentedCall
convert_scope (forall call. (call -> DocumentedCall) -> CallMap call -> CallMap
call_map_doc forall d. TrackCall d -> DocumentedCall
Derive.extract_track_doc) ScopePriority (TrackCall d)
track)
        ]
    val_doc :: [ScopeDoc]
val_doc = CallType -> ScopePriority DocumentedCall -> [ScopeDoc]
scope_type CallType
ValCall forall a b. (a -> b) -> a -> b
$
        forall call.
(CallMap call -> CallMap)
-> ScopePriority call -> ScopePriority DocumentedCall
convert_scope (forall call. (call -> DocumentedCall) -> CallMap call -> CallMap
call_map_doc ValCall -> DocumentedCall
Derive.extract_val_doc) ScopePriority ValCall
val
    convert :: ScopePriority (Call d) -> ScopePriority DocumentedCall
convert = forall call.
(CallMap call -> CallMap)
-> ScopePriority call -> ScopePriority DocumentedCall
convert_scope (forall call. (call -> DocumentedCall) -> CallMap call -> CallMap
call_map_doc forall d. Call d -> DocumentedCall
Derive.extract_doc)

convert_scope :: (Derive.CallMap call -> CallMap)
    -> Derive.ScopePriority call -> Derive.ScopePriority Derive.DocumentedCall
convert_scope :: forall call.
(CallMap call -> CallMap)
-> ScopePriority call -> ScopePriority DocumentedCall
convert_scope CallMap call -> CallMap
convert (Derive.ScopePriority Map CallPriority (CallMap call)
prio_map) =
    forall call. Map CallPriority (CallMap call) -> ScopePriority call
Derive.ScopePriority (CallMap call -> CallMap
convert forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map CallPriority (CallMap call)
prio_map)

-- | Create docs for generator and transformer calls, and merge and sort them.
merged_scope_docs :: [(CallType, Derive.ScopePriority Derive.DocumentedCall)]
    -> [ScopeDoc]
merged_scope_docs :: [(CallType, ScopePriority DocumentedCall)] -> [ScopeDoc]
merged_scope_docs = [ScopeDoc] -> [ScopeDoc]
merge_scope_docs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry CallType -> ScopePriority DocumentedCall -> [ScopeDoc]
scope_type)

merge_scope_docs :: [ScopeDoc] -> [ScopeDoc]
merge_scope_docs :: [ScopeDoc] -> [ScopeDoc]
merge_scope_docs = forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ([CallBindings] -> [CallBindings]
sort_calls forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Ord a => [(a, b)] -> [(a, NonNull b)]
Lists.groupFst

sort_calls :: [CallBindings] -> [CallBindings]
sort_calls :: [CallBindings] -> [CallBindings]
sort_calls = forall k a. Ord k => (a -> k) -> [a] -> [a]
Lists.sortOn forall a b. (a -> b) -> a -> b
$ \([Binding]
binds, CallType
_, CallDoc
_) ->
    Text -> Text
Text.toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> Maybe a
Lists.head [Binding]
binds

-- | A 'Derive.Library' only has builtins, but ScopeDoc wants a source so
-- it can work uniformly with 'track_sections', which does have separate
-- sources.
imported_scope_doc :: CallType -> [Entry] -> [ScopeDoc]
imported_scope_doc :: CallType -> [Entry] -> [ScopeDoc]
imported_scope_doc CallType
ctype [Entry]
lookups = [(forall a. Maybe a
Nothing, CallType -> [Entry] -> [CallBindings]
entries CallType
ctype [Entry]
lookups)]

scope_type :: CallType -> Derive.ScopePriority Derive.DocumentedCall
    -> [ScopeDoc]
scope_type :: CallType -> ScopePriority DocumentedCall -> [ScopeDoc]
scope_type CallType
ctype (Derive.ScopePriority Map CallPriority CallMap
prio_map) =
    forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. a -> Maybe a
Just) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toDescList forall a b. (a -> b) -> a -> b
$
        CallType -> [Entry] -> [CallBindings]
entries CallType
ctype forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallMap -> [Entry]
call_map_to_entries forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map CallPriority CallMap
prio_map

call_map_to_entries :: CallMap -> [Entry]
call_map_to_entries :: CallMap -> [Entry]
call_map_to_entries (Derive.CallMap Map Symbol DocumentedCall
calls [PatternCall DocumentedCall]
patterns) =
    forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall call. Symbol -> call -> Entry call
Library.Single) (forall k a. Map k a -> [(k, a)]
Map.toAscList Map Symbol DocumentedCall
calls)
    forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall call. PatternCall call -> Entry call
Library.Pattern [PatternCall DocumentedCall]
patterns

entries :: CallType -> [Entry] -> [CallBindings]
entries :: CallType -> [Entry] -> [CallBindings]
entries CallType
ctype = forall {c} {b}. Ord c => [(b, c)] -> [([b], CallType, c)]
group forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall {a}. (a, DocumentedCall) -> ((a, CallName), CallDoc)
extract forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {b}. (Either Text Symbol, b) -> (Text, b)
go) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Entry -> (Either Text Symbol, DocumentedCall)
flatten
    where
    flatten :: Entry -> (Either Text Symbol, DocumentedCall)
flatten (Library.Pattern PatternCall DocumentedCall
pattern) =
        (forall a b. a -> Either a b
Left (forall call. PatternCall call -> Text
Derive.pat_description PatternCall DocumentedCall
pattern), forall call. PatternCall call -> DocumentedCall
Derive.pat_doc PatternCall DocumentedCall
pattern)
    flatten (Library.Single Symbol
sym DocumentedCall
doc) = (forall a b. b -> Either a b
Right Symbol
sym, DocumentedCall
doc)
    go :: (Either Text Symbol, b) -> (Text, b)
go (Left Text
desc, b
doc) = (Text
"pattern:" forall a. Semigroup a => a -> a -> a
<> Text
desc, b
doc)
    go (Right Symbol
sym, b
doc) = (Symbol -> Text
show_sym Symbol
sym, b
doc)
    show_sym :: Symbol -> Text
show_sym (Expr.Symbol Text
sym)
        | Text -> Bool
Text.null Text
sym = Text
"\"\""
        | Bool
otherwise = Text
sym
    extract :: (a, DocumentedCall) -> ((a, CallName), CallDoc)
extract (a
sym, Derive.DocumentedCall CallName
name CallDoc
doc) = ((a
sym, CallName
name), CallDoc
doc)
    -- Group calls with the same CallDoc.
    group :: [(b, c)] -> [([b], CallType, c)]
group [(b, c)]
docs = [(forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(b, c)]
group, CallType
ctype, c
doc)
        | (c
doc, [(b, c)]
group) <- forall key a. Ord key => (a -> key) -> [a] -> [(key, [a])]
Lists.keyedGroupSort forall a b. (a, b) -> b
snd [(b, c)]
docs]