module App.ExtractDoc where
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO
import qualified System.Environment as Environment
import qualified Text.Printf as Printf
import qualified Util.Html as Html
import qualified Util.Lists as Lists
import qualified Util.Texts as Texts
import qualified App.Path as Path
import qualified Cmd.CallDoc as CallDoc
import qualified Cmd.Cmd as Cmd
import qualified Cmd.GlobalKeymap as GlobalKeymap
import qualified Cmd.KeyLayouts as KeyLayouts
import qualified Cmd.NoteTrackKeymap as NoteTrackKeymap
import qualified Derive.C.All as C.All
import qualified Derive.Scale.All as Scale.All
import qualified Ui.Key as Key
import Global
main :: IO ()
main :: IO ()
main = do
[String]
args <- IO [String]
Environment.getArgs
AppDir
app_dir <- IO AppDir
Path.get_app_dir
case [String]
args of
[String
"keymap"] -> Text -> IO ()
Text.IO.putStr Text
keymap_doc
[String
"calls"] -> do
HtmlState
hstate <- String -> AppDir -> IO HtmlState
Html.get_html_state String
"../haddock" AppDir
app_dir
Text -> IO ()
Text.IO.putStr forall a b. (a -> b) -> a -> b
$ Html -> Text
Html.un_html forall a b. (a -> b) -> a -> b
$ HtmlState -> Document -> Html
CallDoc.doc_html HtmlState
hstate forall a b. (a -> b) -> a -> b
$
Builtins -> Document
CallDoc.builtins Builtins
C.All.builtins
[String
"scales"] -> do
HtmlState
hstate <- String -> AppDir -> IO HtmlState
Html.get_html_state String
"../haddock" AppDir
app_dir
Text -> IO ()
Text.IO.putStr forall a b. (a -> b) -> a -> b
$ Html -> Text
Html.un_html forall a b. (a -> b) -> a -> b
$ HtmlState -> [CallBindings] -> Html
CallDoc.scales_html HtmlState
hstate forall a b. (a -> b) -> a -> b
$
[(ScaleId, Text, DocumentedCall)] -> [CallBindings]
CallDoc.scale_docs [(ScaleId, Text, DocumentedCall)]
Scale.All.docs
[String]
_ -> forall a. HasCallStack => String -> a
error String
"usage: extract_doc [ keymap | calls | scales ]"
keymap_doc :: Text
keymap_doc :: Text
keymap_doc = [Text] -> Text
Text.unlines
[ Text
"<html> <head> <title> keymaps </title> </head> <body>"
, Text -> Binds -> Text
html_fmt Text
"global" forall a b. (a -> b) -> a -> b
$ Keymap CmdId -> Binds
extract Keymap CmdId
GlobalKeymap.all_keymap
, Text -> Binds -> Text
html_fmt Text
"note track" forall a b. (a -> b) -> a -> b
$ Keymap CmdId -> Binds
extract Keymap CmdId
NoteTrackKeymap.keymap
, Text
"</body> </html>"
]
type Binds = [(Text, [Cmd.KeySpec])]
extract :: Cmd.Keymap Cmd.CmdId -> Binds
= Binds -> Binds
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. Binds -> Binds
strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). [(KeySpec, NamedCmd m)] -> Binds
group forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList
sort :: Binds -> Binds
sort :: Binds -> Binds
sort = forall k a. Ord k => (a -> k) -> [a] -> [a]
Lists.sortOn (forall a b. (a -> b) -> [a] -> [b]
map KeySpec -> ((Int, Bindable), Set Modifier)
key forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
where
key :: KeySpec -> ((Int, Bindable), Set Modifier)
key (Cmd.KeySpec Set Modifier
mods Bindable
bindable) = (Bindable -> (Int, Bindable)
bindable_key Bindable
bindable, Set Modifier
mods)
bindable_key :: Bindable -> (Int, Bindable)
bindable_key k :: Bindable
k@(Cmd.Key Bool
_ (Key.Char Char
c)) =
(forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (forall k a. Map k a -> Int
Map.size Map Char Int
key_order forall a. Num a => a -> a -> a
+ Int
1) Char
c Map Char Int
key_order, Bindable
k)
bindable_key Bindable
k = (forall k a. Map k a -> Int
Map.size Map Char Int
key_order forall a. Num a => a -> a -> a
+ Int
2, Bindable
k)
key_order :: Map Char Int
key_order = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip String
KeyLayouts.qwerty_unshifted [Int
0,Int
2..]
forall a. [a] -> [a] -> [a]
++ forall a b. [a] -> [b] -> [(a, b)]
zip String
KeyLayouts.qwerty_shifted [Int
1,Int
3..]
group :: [(Cmd.KeySpec, Cmd.NamedCmd m)] -> [(Text, [Cmd.KeySpec])]
group :: forall (m :: * -> *). [(KeySpec, NamedCmd m)] -> Binds
group = 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. (a, b) -> a
fst)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key a. Ord key => (a -> key) -> [a] -> [(key, [a])]
Lists.keyedGroupSort (forall (m :: * -> *). NamedCmd m -> Text
Cmd.cmd_name forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
strip :: Binds -> Binds
strip :: Binds -> Binds
strip = forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second [KeySpec] -> [KeySpec]
strip_keyspecs)
strip_keyspecs :: [Cmd.KeySpec] -> [Cmd.KeySpec]
strip_keyspecs :: [KeySpec] -> [KeySpec]
strip_keyspecs = forall a b. (a -> b) -> [a] -> [b]
map KeySpec -> KeySpec
stripm forall b c a. (b -> c) -> (a -> b) -> a -> c
. [KeySpec] -> [KeySpec]
strip_drag forall b c a. (b -> c) -> (a -> b) -> a -> c
. [KeySpec] -> [KeySpec]
strip_repeatable
where
strip_drag :: [KeySpec] -> [KeySpec]
strip_drag [KeySpec]
mods
| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any KeySpec -> Bool
is_drag [KeySpec]
mods = forall a. (a -> Bool) -> [a] -> [a]
filter KeySpec -> Bool
is_drag [KeySpec]
mods
| Bool
otherwise = [KeySpec]
mods
is_drag :: KeySpec -> Bool
is_drag (Cmd.KeySpec Set Modifier
_ (Cmd.Drag {})) = Bool
True
is_drag KeySpec
_ = Bool
False
strip_repeatable :: [KeySpec] -> [KeySpec]
strip_repeatable [KeySpec]
mods
| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any KeySpec -> Bool
is_repeatable [KeySpec]
mods = forall a. (a -> Bool) -> [a] -> [a]
filter KeySpec -> Bool
is_repeatable [KeySpec]
mods
| Bool
otherwise = [KeySpec]
mods
is_repeatable :: KeySpec -> Bool
is_repeatable (Cmd.KeySpec Set Modifier
_ (Cmd.Key Bool
is_repeat Key
_)) = Bool
is_repeat
is_repeatable KeySpec
_ = Bool
False
stripm :: KeySpec -> KeySpec
stripm (Cmd.KeySpec Set Modifier
mods Bindable
bindable) =
Set Modifier -> Bindable -> KeySpec
Cmd.KeySpec (forall a. Ord a => [a] -> Set a
Set.fromList (Bindable -> [Modifier] -> [Modifier]
strip_mods Bindable
bindable (forall a. Set a -> [a]
Set.toList Set Modifier
mods)))
Bindable
bindable
strip_mods :: Cmd.Bindable -> [Cmd.Modifier] -> [Cmd.Modifier]
strip_mods :: Bindable -> [Modifier] -> [Modifier]
strip_mods Bindable
bindable [Modifier]
mods = case Bindable
bindable of
Cmd.Click {} -> [Modifier]
stripped
Cmd.Drag {} -> [Modifier]
stripped
Bindable
_ -> [Modifier]
mods
where
stripped :: [Modifier]
stripped = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Modifier -> Bool
is_mouse) [Modifier]
mods
is_mouse :: Modifier -> Bool
is_mouse (Cmd.MouseMod {}) = Bool
True
is_mouse Modifier
_ = Bool
False
txt_fmt :: Binds -> Text
txt_fmt :: Binds -> Text
txt_fmt = [Text] -> Text
Text.unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> [KeySpec] -> Text
show_binding)
show_binding :: Text -> [Cmd.KeySpec] -> Text
show_binding :: Text -> [KeySpec] -> Text
show_binding Text
name [KeySpec]
keyspecs = forall a. Textlike a => a -> a -> a -> a
Texts.join2 Text
" - " Text
mods Text
name
where mods :: Text
mods = Text
"[" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Text
pretty [KeySpec]
keyspecs) forall a. Semigroup a => a -> a -> a
<> Text
"]"
html_fmt :: Text -> Binds -> Text
html_fmt :: Text -> Binds -> Text
html_fmt Text
title Binds
binds = Text -> Int -> [Text] -> Text
columns Text
title Int
3 (forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> [KeySpec] -> Text
html_binding) Binds
binds)
columns :: Text -> Int -> [Text] -> Text
columns :: Text -> Int -> [Text] -> Text
columns Text
title Int
n [Text]
contents = [Text] -> Text
Text.unlines forall a b. (a -> b) -> a -> b
$
[ Text
"<table width=100%>"
, String -> Text
txt forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
Printf.printf String
"<tr> <th colspan=%d> %s </th> </tr>" Int
n (Text -> String
untxt Text
title)
, Text
"<tr>"
] forall a. [a] -> [a] -> [a]
++ [Text
"<td valign=top>" forall a. Semigroup a => a -> a -> a
<> Text
t forall a. Semigroup a => a -> a -> a
<> Text
"</td>" | Text
t <- [Text]
tables]
forall a. [a] -> [a] -> [a]
++ [Text
"</tr>", Text
"</table>"]
where
size :: Double
size = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
contents) forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
tables :: [Text]
tables = forall a b. (a -> b) -> [a] -> [b]
map [Text] -> Text
fmt_table (forall a. Int -> [a] -> [[a]]
chunk (forall a b. (RealFrac a, Integral b) => a -> b
ceiling Double
size) [Text]
contents)
fmt_table :: [Text] -> Text
fmt_table [Text]
rows = [Text] -> Text
Text.unlines forall a b. (a -> b) -> a -> b
$ [Text
"<table>"] forall a. [a] -> [a] -> [a]
++ [Text] -> [Text]
fmt_rows [Text]
rows forall a. [a] -> [a] -> [a]
++ [Text
"</table>"]
fmt_rows :: [Text] -> [Text]
fmt_rows [Text]
rows =
[ String -> Text
txt forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
Printf.printf String
"<tr bgcolor=%s> %s </tr>" (String
color :: String)
(Text -> String
untxt Text
row)
| (String
color, Text
row) <- forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. [a] -> [a]
cycle [String
"white", String
"#dddddd"]) [Text]
rows
]
chunk :: Int -> [a] -> [[a]]
chunk :: forall a. Int -> [a] -> [[a]]
chunk Int
_ [] = []
chunk Int
n [a]
xs = [a]
c forall a. a -> [a] -> [a]
: forall a. Int -> [a] -> [[a]]
chunk Int
n [a]
rest
where ([a]
c, [a]
rest) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [a]
xs
html_binding :: Text -> [Cmd.KeySpec] -> Text
html_binding :: Text -> [KeySpec] -> Text
html_binding Text
name [KeySpec]
keyspecs =
Text
"<td>" forall a. Semigroup a => a -> a -> a
<> Text
mods forall a. Semigroup a => a -> a -> a
<> Text
"</td> <td> <em>" forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
"</em> </td>"
where mods :: Text
mods = Text -> [Text] -> Text
Text.intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map KeySpec -> Text
html_keyspec [KeySpec]
keyspecs)
html_keyspec :: Cmd.KeySpec -> Text
html_keyspec :: KeySpec -> Text
html_keyspec (Cmd.KeySpec Set Modifier
mods Bindable
bindable) =
forall a. Textlike a => a -> a -> a -> a
Texts.join2 Text
" " (Set Modifier -> Text
show_mods Set Modifier
mods)
(Text
"<b>" forall a. Semigroup a => a -> a -> a
<> Bool -> Bindable -> Text
Cmd.show_bindable Bool
False Bindable
bindable forall a. Semigroup a => a -> a -> a
<> Text
"</b>")
where show_mods :: Set Modifier -> Text
show_mods = Text -> [Text] -> Text
Text.intercalate Text
" + " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Modifier -> Text
Cmd.show_mod forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
Set.toList