diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,22 @@ +Copyright (c) 2015-present Greg Hurrell + +# MIT License + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,227 @@ +# docvim: a documentation generator for Vim plug-ins + +docvim is a documentation generator for Vim plug-ins, written in Haskell. + +## Quickstart + +```bash +# Print Markdown-formatted help documentation for files in current directory +docvim + +# Write Markdown README + Vim help text file for $PLUGIN +docvim -c ~/code/$PLUGIN ~/code/$PLUGIN/doc/$PLUGIN.txt ~/code/$PLUGIN/README.md +``` + +## Usage + +``` +docvim - a documentation generator for Vim plug-ins + +Usage: docvim [--version] [OUTFILES...] [-d|--debug] [-c|--directory DIRECTORY] + [-v|--verbose] + Generate documentation for a Vim plug-in + +Available options: + -h,--help Show this help text + --version Print version information + OUTFILES... Target file(s) for generated output (default: + standard output) + -d,--debug Print debug information during processing + -c,--directory DIRECTORY Change to DIRECTORY before processing (default: ".") + -v,--verbose Be verbose during processing +``` + +## Syntax + +```vim +"" +" Docblocks start with a pair of double quotes, followed +" by standard Vim comments (with a double quote prefix) +" containing Markdown-like text and optional annotations +" that look like this: +" +" ``` +" @command :Ack {pattern} {options} +" ``` +``` + +### Supported Markdown features + + # Top-level heading + + ## Sub-heading + + --- (Horizontal dividers) + + > Blockquote + + `inline code` + + ``` + fenced codeblocks (leading space syntax not supported) + ``` + + ![alt text](http://example.com/image.jpg) + (becomes a link in vimdoc, but an image in markdown) + + - Lists. + +### Unsupported Markdown syntax + +``` +*foo* (emphasis; turns into Vim doc targets instead) + +*,+ (list syntax; just use - instead) + + (we don't want ambiguity with things like and so on) +``` + +### Annotations + +- `@command` +- `@dedent` +- `@footer` +- `@function` +- `@indent` +- `@mapping` +- `@mappings` +- `@option` +- `@plugin` + +## Development + +### Convenience wrappers + +```bash +bin/accept # Accept current "golden" test output. +bin/docvim # Run the docvim executable. +bin/golden # Run just the "golden" tests. +bin/haddock # Produce Haddock documentation. +bin/lint # Run the linter. +bin/tasty # Run just the Tasty tests. +bin/test # Run all tests, including lints. +``` + +These are wrappers for the explicit invocations described below. + +### Set-up + +You can set-up a development environment using [Stack] (recommended) or [Cabal]: + +```bash +# Stack: +brew install haskell-stack +stack build + +# Cabal: +brew install cabal-install +cabal sandbox init +cabal install --only-dependencies --enable-tests +cabal build +``` + +### Running + +Run using `stack exec` (or `cabal run`) and passing in docvim-specific `OPTIONS`: + +```bash +# Stack: +stack exec docvim [OPTIONS] + +# Cabal: +cabal run -- [OPTIONS] +``` + +You can also run the modules from inside the REPL: + +```bash +# Stack: +stack repl +> pp "let l:test=1" -- pretty-prints AST + +# Cabal: +cabal repl +> import Docvim.Parse +> pp "let l:test=1" -- pretty-prints AST +``` + +### Building + +```bash +stack build --file-watch +``` + +### Building and viewing the code-level documentation + +```bash +# Stack: +stack haddock +open .stack-work/dist/x86_64-osx/Cabal-1.22.5.0/doc/html/docvim/index.html + +# Cabal: +cabal haddock --executables +open dist/doc/html/docvim/docvim/index.html +``` + +### Testing + +```bash +# Stack: +stack test # Runs all test suites, including linting. +stack test :tasty # Runs just the Tasty test suite. + +# Cabal: +cabal test # Runs all test suites, including linting. +cabal test tasty # Runs just the Tasty test suite. +``` + +#### Updating "golden" files + +```bash +# Stack: +stack test --test-arguments=--accept # Runs all test suites. +stack test :tasty --test-arguments=--accept # Runs just the Tasty test suite. + +# Cabal: +cabal test --test-options=---accept # Runs all test suites. +cabal test tasty --test-options=---accept # Runs just the Tasty test suite. +``` + +### Linting + +```bash +# Stack: +stack test # Runs linter as part of overall set of suites. +stack test :hlint # Runs linter alone. + +# Cabal: +cabal install hlint # (First-time only). +cabal test # Runs linter as part of overall set of suites. +cabal test hlint # Runs linter alone. + +hlint src # If you have HLint installed under $PATH. +``` + +## FAQ + +### Why a new tool and not an existing one like [Vimdoc]? + +* I wanted to target multiple output formats (Vim help files and Markdown). +* I wanted total control over the presentation of the output. +* It's fun to build new things from scratch. +* The project is a great fit for my learn-me-a-Haskell goal this year. + +### Why is it called "Docvim"? + +"Vimdoc" was the first name that occurred to me when I started this project, but: + +* The number one hit for "vimdoc" is [this online copy of Vim's own documentation](http://vimdoc.sourceforge.net/). +* The name "Vimdoc" is already taken by [a similar project](https://github.com/google/vimdoc). + +So, in a remarkable flash of profound creativity, I settled on "Docvim" instead, which right now yields this pleasing search result: + +> Did you mean: dacvim + +[Cabal]: https://www.haskell.org/cabal/ +[Stack]: http://haskellstack.org/ +[Vimdoc]: https://github.com/google/vimdoc diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/docvim.cabal b/docvim.cabal new file mode 100644 --- /dev/null +++ b/docvim.cabal @@ -0,0 +1,151 @@ +-- Initial docvim.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +-- The name of the package. +name: docvim + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- http://www.haskell.org/haskellwiki/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +-- A short (one-line) description of the package. +synopsis: Documentation generator for Vim plug-ins + +-- A longer description of the package. +description: Produces Vim help and HTML (via Markdown) documentation. + +-- URL for the project homepage or repository. +homepage: https://github.com/wincent/docvim + +-- The license under which the package is released. +license: MIT + +-- The file containing the license text. +license-file: LICENSE.md + +-- The package author(s). +author: Greg Hurrell + +-- An email address to which users can send suggestions, bug reports, and +-- patches. +maintainer: greg@hurrell.net + +-- A copyright notice. +copyright: 2015-present Greg Hurrell + +category: Development + +build-type: Simple + +-- Extra files to be distributed with the package, such as examples or a +-- README. +extra-source-files: README.md + +-- Constraint on the version of Cabal needed to build this package. +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/wincent/docvim.git + +source-repository this + type: git + location: https://github.com/wincent/docvim.git + tag: 0.1 + +executable docvim + -- .hs or .lhs file containing the Main module. + main-is: Main.hs + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: base >=4.8 && <4.9 + , docvim + + -- Directories containing source files. + hs-source-dirs: src + + -- Base language which the package is written in. + default-language: Haskell2010 + +library + build-depends: base + , containers + , directory + , filepath + + -- Third party + , dlist + , lens + , mtl + , optparse-applicative + , parsec + , pretty-show + , split + default-language: Haskell2010 + exposed-modules: Docvim.AST + , Docvim.CLI + , Docvim.Compile + , Docvim.Options + , Docvim.Parse + , Docvim.Printer.Markdown + , Docvim.Printer.Vim + , Docvim.ReadDir + , Docvim.Util + , Docvim.Visitor + , Docvim.Visitor.Command + , Docvim.Visitor.Commands + , Docvim.Visitor.Footer + , Docvim.Visitor.Function + , Docvim.Visitor.Functions + , Docvim.Visitor.Heading + , Docvim.Visitor.Mapping + , Docvim.Visitor.Mappings + , Docvim.Visitor.Option + , Docvim.Visitor.Options + , Docvim.Visitor.Plugin + , Docvim.Visitor.Section + , Docvim.Visitor.Symbol + , Paths_docvim + hs-source-dirs: lib + +test-suite hlint + build-depends: base + , hlint + default-language: Haskell2010 + hs-source-dirs: tests + main-is: HLint.hs + type: exitcode-stdio-1.0 + +test-suite tasty + build-depends: base >= 4 && < 5 + , bytestring + , containers + , deepseq + , dlist + , docvim + , filepath + , lens + , mtl + , parsec + , pretty-show + , process + , split + , tasty + , tasty-golden + , tasty-hunit + , temporary + default-language: Haskell2010 + hs-source-dirs: tests + , lib + main-is: Tasty.hs + type: exitcode-stdio-1.0 diff --git a/lib/Docvim/AST.hs b/lib/Docvim/AST.hs new file mode 100644 --- /dev/null +++ b/lib/Docvim/AST.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Docvim.AST where + +import Control.Lens.Fold (foldlOf) +import Control.Lens.Getter (to) +import Control.Lens.Plated (Plated, cosmosOf) +import Data.Char (toLower) +import Data.Data +import Data.Data.Lens (uniplate) +import Data.List (intercalate) +import Data.Monoid ((<>)) + +data Node + -- Roots + = Project [Node] -- list of translation units (files) + | Unit [Node] -- translation unit (file) + + -- To remove any node from the tree, we can just replace it with this. + | Empty + + -- VimL nodes + | FunctionDeclaration { functionBang :: Bool + , functionName :: String + , functionArguments :: ArgumentList + , functionAttributes :: [String] + , functionBody :: [Node] + } + | LetStatement { letLexpr :: String + , letValue :: String + } + | LexprStatement { lexprBang :: Bool + , lexprExpr :: String + } + | LwindowStatement { lwindowHeight :: Maybe Int } + | UnletStatement { unletBang :: Bool + , unletBody :: String + } + | GenericStatement String -- ^ For the stuff we only crudely parse for now. + + -- Docvim nodes: "block-level" elements + | DocBlock [Node] + | Paragraph [Node] + | LinkTargets [String] + | List [Node] + | ListItem [Node] + | Blockquote [Node] + | Fenced [String] + | Separator + + -- Docvim nodes: "phrasing content" elements + | Plaintext String + | BreakTag + | Link String + | Code String + | Whitespace + + -- Docvim nodes: annotations + | PluginAnnotation Name Description + | FunctionsAnnotation + | FunctionAnnotation Name -- not sure if I will want more here + | IndentAnnotation + | DedentAnnotation + | CommandsAnnotation + | CommandAnnotation Name (Maybe Parameters) + | FooterAnnotation + | MappingsAnnotation + | MappingAnnotation Name + | OptionsAnnotation + | OptionAnnotation Name Type (Maybe Default) + | HeadingAnnotation String + | SubheadingAnnotation String + + -- Docvim nodes: synthesized nodes + | TOC [String] + deriving (Data, Eq, Show, Typeable) + +-- The VimScript (VimL) grammar is embodied in the implementation of +-- https://github.com/vim/vim/blob/master/src/eval.c; there is no formal +-- specification for it, and there are many ambiguities that can only be +-- resolved at runtime. We aim to parse a loose subset. + +-- TODO: deal with bar | +-- note that `function X() |` does not work, and `endf` must be on a line +-- of its own too (not a syntax error to do `| endf`, but it doesn't work +-- , so you need to add another `endf`, which will blow up at runtime. +-- TODO: validate name = CapitalLetter or s:foo or auto#loaded + +data ArgumentList = ArgumentList [Argument] + deriving (Data, Eq, Show, Typeable) + +data Argument = Argument String + deriving (Data, Eq, Show, Typeable) + +instance Plated Node + +type Default = String +type Description = String +type Name = String +type Type = String +type Parameters = String + +-- | Walks an AST node calling the supplied visitor function. +-- +-- This is an in-order traversal. +-- +-- For example, to implement a visitor which counts all nodes: +-- +-- > import Data.Monoid +-- > count = getSum $ walk (\_ -> 1) (Sum 0) tree +-- +-- For comparison, here is a (probably inefficient) alternative way using +-- `Control.Lens.Plated` instead of `walk`: +-- +-- > import Control.Lens.Operators +-- > import Control.Lens.Plated +-- > import Data.Data.Lens +-- > count = length $ tree ^.. cosmosOf uniplate +-- +-- Another example; accumulating `SubheadingAnnotation` nodes into a list: +-- +-- > accumulator node@(SubheadingAnnotation _) = [node] +-- > accumulator _ = [] -- skip everything else +-- > nodes = walk accumulator [] tree +-- +-- Again, for comparison, the same without `walk`, this time using a list +-- comprehension: +-- +-- > import Control.Lens.Operators +-- > import Control.Lens.Plated +-- > import Data.Data.Lens +-- > [n | n@(SubheadingAnnotation _) <- tree ^.. cosmosOf uniplate] +-- +walk :: Monoid a => (Node -> a) -> a -> Node -> a +walk f = foldlOf (cosmosOf uniplate . to f) (<>) +-- TODO: consider making it possible for `f` to return `Nothing` to +-- short-circuit traversal, or `Just a` to continue with the current `mappend` +-- behavior. + +-- | Sanitizes a link target similar to the way that GitHub does: +-- +-- - Downcase. +-- - Filter, keeping only letter, number, space, hyphen. +-- - Change spaces to hyphens. +-- - Uniquify by appending "-1", "-2", "-3" etc (not yet implemented). +-- +-- We use this both for generating GitHub friendly link targets, and for +-- auto-generating new link targets for use inside Vim help files. +-- +-- Source: https://gist.github.com/asabaylus/3071099#gistcomment-1593627 +sanitizeAnchor :: String -> String +sanitizeAnchor = hyphenate . keepValid . downcase + where + hyphenate = map spaceToHyphen + spaceToHyphen c = if c == ' ' then '-' else c + keepValid = filter (`elem` (['a'..'z'] ++ ['0'..'9'] ++ " -")) + downcase = map toLower diff --git a/lib/Docvim/CLI.hs b/lib/Docvim/CLI.hs new file mode 100644 --- /dev/null +++ b/lib/Docvim/CLI.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE MultiWayIf #-} + +-- | The runnable part of the docvim executable. +module Docvim.CLI (run) where + +import Control.Monad (when) +import Data.Maybe (fromMaybe) +import Docvim.Options (Options(..), options) +import Docvim.Compile (compile) +import Docvim.Parse (parse) +import Docvim.Printer.Markdown (markdown) +import Docvim.Printer.Vim (vimHelp) +import Docvim.ReadDir (readDir) +import System.FilePath (takeExtension) +import System.IO (hPutStrLn, stderr) + +hasExtension :: String -> FilePath -> Bool +hasExtension ext fp = takeExtension fp == ext + +isMarkdown :: FilePath -> Bool +isMarkdown = hasExtension ".md" + +isText :: FilePath -> Bool +isText = hasExtension ".txt" + +isVimScript :: FilePath -> Bool +isVimScript = hasExtension ".vim" + +run :: IO () +run = do + opts <- options + paths <- readDir (directory opts) + let filtered = filter isVimScript paths + parsed <- mapM (\path -> do + when (verbose opts) (hPutStrLn stderr ("Parsing " ++ path)) + parse path + ) filtered + let project = compile parsed + let targets = fromMaybe [""] (outfiles opts) + mapM_ (\target -> + if | target == "" -> do + when (verbose opts) (hPutStrLn stderr "No output target: defaulting to standard out") + putStrLn $ markdown project + | isText target -> do + when (verbose opts) (hPutStrLn stderr ("Outputting in text format to " ++ target)) + writeFile target (vimHelp project) + | isMarkdown target -> do + when (verbose opts) (hPutStrLn stderr ("Outputting in markdown format to " ++ target)) + writeFile target (markdown project) + | otherwise -> hPutStrLn stderr ("Unrecognized output format for " ++ target) + ) targets + return () diff --git a/lib/Docvim/Compile.hs b/lib/Docvim/Compile.hs new file mode 100644 --- /dev/null +++ b/lib/Docvim/Compile.hs @@ -0,0 +1,51 @@ +module Docvim.Compile (compile) where + +import Docvim.AST (Node(Project)) +import Docvim.Visitor.Command (extractCommand) +import Docvim.Visitor.Commands (extractCommands) +import Docvim.Visitor.Footer (extractFooter) +import Docvim.Visitor.Function (extractFunction) +import Docvim.Visitor.Functions (extractFunctions) +import Docvim.Visitor.Heading (injectTOC) +import Docvim.Visitor.Mapping (extractMapping) +import Docvim.Visitor.Mappings (extractMappings) +import Docvim.Visitor.Option (extractOption) +import Docvim.Visitor.Options (extractOptions) +import Docvim.Visitor.Plugin (extractPlugin) +import Docvim.Visitor.Section ( injectCommands + , injectFunctions + , injectMappings + , injectOptions + ) +import Docvim.Visitor (extract) + +-- | "Compile" a set of translation units into a project. +compile :: [Node] -> Node +compile ns = do + let ast = foldr ($) (Project ns) [ injectCommands + , injectFunctions + , injectMappings + , injectOptions + ] + let (ast2, plugin) = extract extractPlugin ast + let (ast3, commands) = extract extractCommands ast2 + let (ast4, command) = extract extractCommand ast3 + let (ast5, functions) = extract extractFunctions ast4 + let (ast6, function) = extract extractFunction ast5 + let (ast7, mappings) = extract extractMappings ast6 + let (ast8, mapping) = extract extractMapping ast7 + let (ast9, options) = extract extractOptions ast8 + let (ast10, option) = extract extractOption ast9 + let (ast11, footer) = extract extractFooter ast10 + injectTOC $ Project $ concat [ plugin + , [ast11] + , commands + , command + , mappings + , mapping + , options + , option + , functions + , function + , footer + ] diff --git a/lib/Docvim/Options.hs b/lib/Docvim/Options.hs new file mode 100644 --- /dev/null +++ b/lib/Docvim/Options.hs @@ -0,0 +1,58 @@ +-- | Options parser for the docvim executable. +module Docvim.Options (Options(..), options) where + +import Options.Applicative +import Data.Version (showVersion) +import qualified Paths_docvim (version) + +-- TODO: figure out where (and if!) to expand ~ and such in path options +data Options = Options + { outfiles :: Maybe [FilePath] + , debug :: Bool + , directory :: String + , verbose :: Bool } + +parseOutfiles :: Parser [String] +parseOutfiles = some $ argument str + ( metavar "OUTFILES..." + <> help (unlines [ "Target file(s) for generated output" + , "(default: standard output)" ])) + +version :: Parser (a -> a) +version = infoOption (showVersion Paths_docvim.version) + ( long "version" + <> help "Print version information" ) + +parseDebug :: Parser Bool +parseDebug = switch + $ long "debug" + <> short 'd' + <> help "Print debug information during processing" + +parseDirectory :: Parser String +parseDirectory = strOption + $ long "directory" + <> short 'c' + <> metavar "DIRECTORY" + <> value "." + <> showDefault + <> help "Change to DIRECTORY before processing" + +parseVerbose :: Parser Bool +parseVerbose = switch + $ long "verbose" + <> short 'v' + <> help "Be verbose during processing" + +parseOptions :: Parser Options +parseOptions = Options + <$> optional parseOutfiles + <*> parseDebug + <*> parseDirectory + <*> parseVerbose + +options :: IO Options +options = execParser $ info (helper <*> version <*> parseOptions) + ( fullDesc + <> progDesc "Generate documentation for a Vim plug-in" + <> header "docvim - a documentation generator for Vim plug-ins" ) diff --git a/lib/Docvim/Parse.hs b/lib/Docvim/Parse.hs new file mode 100644 --- /dev/null +++ b/lib/Docvim/Parse.hs @@ -0,0 +1,498 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Docvim.Parse ( parse + , rstrip + , strip + , unit + ) where + +import Control.Applicative ( (*>) + , (<$) + , (<$>) + , (<*) + , (<*>) + , liftA + , liftA2 + ) +import Data.Char (toUpper) +import Data.List (groupBy, intercalate) +import Docvim.AST +import System.Exit (exitFailure) +import System.IO (hPutStrLn, stderr) +-- TODO: custom error messages with +import Text.Parsec ( (<|>) + , () + , ParseError + , choice + , digit + , lookAhead + , many + , many1 + , manyTill + , notFollowedBy + , option + , optionMaybe + , optional + , parseTest + , satisfy + , sepBy + , sepBy1 + , sepEndBy + , sepEndBy1 + , skipMany + , skipMany1 + , try + , unexpected + ) +import Text.Parsec.String (Parser, parseFromFile) +import Text.Parsec.Combinator (eof) +import Text.ParserCombinators.Parsec.Char ( alphaNum + , anyChar + , char + , noneOf + , oneOf + , string + , upper + ) + +-- | Given a `description` like "fu[nction]", returns a parser that matches +-- "fu", "fun", "func", "funct", "functi", "functio" and "function". +-- +-- Beware, may explode at runtime if passed an invalid `description`, due to the +-- use of `init`. +-- +-- Requires the FlexibleContexts extension, for reasons that I don't yet fully +-- understand. +command description = try (string prefix >> remainder rest) + prefix ++ rest + where prefix = takeWhile (/= '[') description + rest = init (snd (splitAt (1 + length prefix) description)) + remainder [r] = optional (char r) + remainder (r:rs) = optional (char r >> remainder rs) + +function = FunctionDeclaration + <$> (fu *> bang <* wsc) + <*> (name <* optional wsc) + <*> arguments + <*> (attributes <* optional wsc) + <*> (skippable *> many node <* (optional ws >> endfunction)) + where + fu = command "fu[nction]" + name = choice [script, normal, autoloaded] <* optional wsc + script = liftA2 (++) (try $ string "s:") (many $ oneOf identifier) + normal = liftA2 (++) (many1 upper) (many $ oneOf identifier) + autoloaded = do + a <- many1 $ oneOf identifier + b <- string "#" + c <- sepBy1 (many1 $ oneOf identifier) (string "#") + return $ a ++ b ++ intercalate "#" c + identifier = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_" + arguments = (char '(' >> optional wsc) + *> (ArgumentList <$> argument `sepBy` (char ',' >> optional wsc)) + <* (optional wsc >> char ')' >> optional wsc) + argument = Argument <$> (string "..." <|> many1 alphaNum) <* optional wsc + attributes = choice [string "abort", string "range", string "dict"] `sepEndBy` wsc + +-- Disambiguate `:endf[unction]` and `:endfo[r]` +endfunction = lookAhead (string "endf" >> notFollowedBy (string "o")) + >> command "endf[unction]" + <* eos + +lStatement = lookAhead (char 'l') + >> choice [ try (lookAhead (string "lw")) >> lwindow + , try (lookAhead (string "let")) >> letStatement + , lexpr + ] + +lwindow = LwindowStatement <$> (lw *> height <* eos) + where + lw = command "l[window]" + height = optionMaybe (wsc *> number) + number = liftA read (many1 digit) + +lexpr = LexprStatement + <$> (command "lex[pr]" *> bang <* wsc) + <*> restOfLine + +-- "let" is a reserved word in Haskell, so we call this "letStatement" instead. +letStatement = LetStatement + <$> (string "let" >> wsc >> lhs) + <*> (optional wsc >> char '=' >> optional wsc *> rhs <* eos) + where + -- Kludge alert! Until we get a full expression parser, we use this crude + -- thing. + lhs = many1 $ noneOf "\"\n=" + rhs = many1 $ noneOf "\n" + +unlet = UnletStatement + <$> (unl *> bang <* wsc) + <*> word + <* eos + where + unl = command "unl[et]" + +quote = string "\"" "quote" +commentStart = quote <* (notFollowedBy quote >> optional ws) +docBlockStart = (string "\"\"" <* optional ws) "\"\"" + +separator = Separator <$ (try (string "---") >> optional ws) "wat" + +fenced = fence >> newline >> Fenced <$> body + where + fence = try $ string "```" >> optional ws + body = do + lines <- manyTill line (try $ (commentStart <|> docBlockStart) >> optional ws >> fence) + let indent = foldr countLeadingSpaces infinity lines + return $ map (trimLeadingSpace indent) lines + where + -- Find minimum count of leading spaces. + countLeadingSpaces line = min (length (takeWhile (' ' ==) line)) + trimLeadingSpace count = if count > 0 + then drop count + else id + infinity = maxBound :: Int + line = (commentStart' <|> docBlockStart') >> restOfLine <* newline + commentStart' = quote <* notFollowedBy quote + docBlockStart' = string "\"\"" "\"\"" + +blockquote = lookAhead (char '>') + >> Blockquote + <$> paragraph `sepBy1` blankLine + where + paragraph = Paragraph <$> body + body = do + first <- firstLine + rest <- many otherLine + -- Make every line end with whitespace. + let nodes = concatMap appendWhitespace (first:rest) + -- Collapse consecutive whitespace. + let compressed = compress nodes + -- Trim final whitespace. + return ( if last compressed == Whitespace + then init compressed + else compressed ) + firstLine = char '>' + >> optional ws + >> many1 (choice [phrasing, whitespace]) + otherLine = try $ newline + >> (commentStart <|> docBlockStart) + >> firstLine + blankLine = try $ newline + >> (commentStart <|> docBlockStart) + >> many1 (try $ char '>' + >> optional ws + >> newline + >> (commentStart <|> docBlockStart)) + +list = lookAhead (char '-' >> notFollowedBy (char '-')) + >> List + <$> listItem `sepBy1` separator + where + -- Yes, this is a bit hideous. + separator = try $ newline + >> (commentStart <|> docBlockStart) + >> optional ws + >> lookAhead (char '-') + +listItem = lookAhead (char '-' >> notFollowedBy (char '-')) + >> ListItem + <$> body + where + body = do + first <- char '-' >> optional ws >> many1 (choice [phrasing, whitespace]) + rest <- many otherLine + -- Make every line end with whitespace. + let nodes = concatMap appendWhitespace (first:rest) + -- Collapse consecutive whitespace. + let compressed = compress nodes + -- Trim final whitespace. + return ( if last compressed == Whitespace + then init compressed + else compressed ) + otherLine = try $ newline + >> (commentStart <|> docBlockStart) + -- TODO ^ DRY this up? + >> optional ws + >> lookAhead (noneOf "-") + >> many1 (choice [phrasing, whitespace]) + +-- | Newline (and slurps up following horizontal whitespace as well). +newline = (char '\n' >> optional ws) <|> eof +newlines = many1 (char '\n' >> optional ws) + <|> (eof >> return [()]) + +-- | Whitespace (specifically, horizontal whitespace: spaces and tabs). +ws = many1 (oneOf " \t") + +-- | Continuation-aware whitespace (\). +wsc = many1 $ choice [whitespace, continuation] + where + whitespace = oneOf " \t" + continuation = try $ char '\n' >> ws >> char '\\' + +-- TODO: string literals; some nasty lookahead might be required +comment = try + $ quote + >> notFollowedBy quote + >> restOfLine + >> skipMany (char '\n' >> optional ws) + +-- | Optional bang suffix for VimL commands. +bang = option False (True <$ char '!') + +-- | End-of-statement. +-- TODO: see `:h :bar` for a list of commands which see | as an arg instead of a +-- command separator. +eos = optional ws >> choice [bar, ws', skipMany1 comment] + where + bar = char '|' >> optional wsc + ws' = newlines >> notFollowedBy wsc + +node :: Parser Node +node = choice [ docBlock + , vimL + ] + <* optional skippable + +docBlock = lookAhead docBlockStart + >> (DocBlock <$> many1 blockElement) + <* trailingBlankCommentLines + where + blockElement = try $ start + >> skipMany emptyLines + *> choice [ annotation + , try subheading -- must come before heading + , heading + , linkTargets + , separator + , list + , blockquote + , fenced + , paragraph -- must come last + ] + <* next + start = try docBlockStart <|> commentStart + emptyLines = try $ newline >> start + next = optional ws >> newline + trailingBlankCommentLines = skipMany $ start >> newline + +paragraph = Paragraph <$> body + where + body = do + first <- firstLine + rest <- many otherLine + -- Make every line end with whitespace + let nodes = concatMap appendWhitespace (first:rest) + -- Collapse consecutive whitespace + let compressed = compress nodes + -- Trim final whitespace + return ( if last compressed == Whitespace + then init compressed + else compressed ) + firstLine = many1 $ choice [phrasing, whitespace] + otherLine = try $ newline + >> (commentStart <|> docBlockStart) + >> optional ws + >> notFollowedBy special + >> firstLine + +-- | Used in lookahead rules to make sure that we don't greedily consume special +-- tokens as if they were just phrasing content. +special :: Parser String +special = choice [ string "-" <* notFollowedBy (char '-') + , string ">" + , string "---" + , string "-" <* string "--" + , string "```" + , string "`" <* string "``" + , string "@" + , string "#" + ] + +phrasing = choice [ br + , link + , code + , plaintext + ] + +-- | Appends a Whitespace token to a list of nodes. +appendWhitespace :: [Node] -> [Node] +appendWhitespace xs = xs ++ [Whitespace] + +-- | Compress whitespace. +-- Consecutive Whitespace tokens are replaced with a single token. +-- If a run of whitespace includes a BreakTag, the run is replaced with the +-- BreakTag. +compress :: [Node] -> [Node] +compress = map prioritizeBreakTag . group + where + group = groupBy fn + fn BreakTag Whitespace = True + fn Whitespace BreakTag = True + fn Whitespace Whitespace = True + fn _ _ = False + prioritizeBreakTag xs = if hasBreakTag xs + then BreakTag + else head xs + hasBreakTag = elem BreakTag +-- similar to "word"... might end up replacing "word" later on... +-- something more sophisticated here with satisfy? +plaintext = Plaintext <$> wordChars + where + wordChars = many1 $ choice [ try $ char '<' <* notFollowedBy (string' "br") + , noneOf " \n\t<|`" + ] + +-- | Case-insensitive char match. +-- +-- Based on `caseChar` function in: +-- https://hackage.haskell.org/package/hsemail-1.3/docs/Text-ParserCombinators-Parsec-Rfc2234.html +char' c = satisfy $ \x -> toUpper x == toUpper c + +-- | Case-insensitive string match. +-- +-- Based on `caseString` function in: +-- https://hackage.haskell.org/package/hsemail-1.3/docs/Text-ParserCombinators-Parsec-Rfc2234.html +string' s = mapM_ char' s >> pure s s + +-- | Tokenized whitespace. +-- +-- Most whitespace is insignificant and gets omitted from the AST, but +-- whitespace inside "phrasing content" is significant so is preserved (in +-- normalized form) in the AST. +whitespace = Whitespace <$ ws + +br = BreakTag <$ (try htmlTag <|> try xhtmlTag) "
" + where + htmlTag = string' "
" + xhtmlTag = string' "> optional ws >> string "/>" + +link = Link <$> (bar *> linkText <* bar) + where + bar = char '|' + linkText = many1 $ noneOf " \t\n|" + +code = Code <$> (backtick *> codeText <* backtick) + where + backtick = char '`' + codeText = many $ noneOf "\n`" + +-- TODO: record this in symbol table similar to +-- https://github.com/wincent/docvim/blob/js/src/SymbolVisitor.js +-- (probably want to make this a post-processing step?) +linkTargets = LinkTargets <$> many1 (star *> target <* (star >> optional ws)) + where + star = char '*' + target = many1 $ noneOf " \t\n*" + +vimL = choice [ block + , statement + ] + +block = choice [ function ] +statement = choice [ lStatement + , unlet + , genericStatement + ] + +-- | Generic VimL node parser to represent stuff that we haven't built out full parsing +-- for yet. +genericStatement = do + -- Make sure we never recognize `endfunction` as a generic statement. This is + -- necessary because we call `node` recursively inside `function` while + -- parsing the function body. We must stop `node` from consuming + -- `endfunction`, otherwise the `function` parse will fail to find it. + notFollowedBy endfunction + atoms <- sepEndBy1 word (optional wsc) + eos + return $ GenericStatement $ unwords atoms + +-- | Remainder of the line up to but not including a newline. +-- Does not include any trailing whitespace. +restOfLine :: Parser String +restOfLine = do + rest <- many (noneOf "\n") + return $ rstrip rest + +-- | Strip trailing and leading whitespace. +-- +-- Not efficient, but chosen for readablility. +-- +-- TODO: switch to Data.Text (http://stackoverflow.com/a/6270382/2103996) for +-- efficiency. +strip = lstrip . rstrip + +-- | Strip leading (left) whitespace. +lstrip = dropWhile (`elem` " \n\t") + +-- | Strip trailing (right) whitespace. +rstrip = reverse . lstrip . reverse + +heading :: Parser Node +heading = char '#' + >> notFollowedBy (char '#') + >> optional ws + >> HeadingAnnotation <$> restOfLine + +subheading :: Parser Node +subheading = string "##" + >> optional ws + >> SubheadingAnnotation <$> restOfLine + +-- | Match a "word" of non-whitespace characters. +word = many1 (noneOf " \n\t") + +-- TODO: only allow these after "" and " at start of line +annotation :: Parser Node +annotation = char '@' *> annotationName + where + annotationName = + choice [ try $ string "commands" >> pure CommandsAnnotation -- must come before function + , command + , string "dedent" >> pure DedentAnnotation + , try $ string "footer" >> pure FooterAnnotation -- must come before function + , try $ string "functions" >> pure FunctionsAnnotation -- must come before function + , function + , string "indent" >> pure IndentAnnotation + , try $ string "mappings" >> pure MappingsAnnotation -- must come before mapping + , mapping + , try $ string "options" >> pure OptionsAnnotation -- must come before option + , option + , plugin + ] + + command = string "command" >> ws >> CommandAnnotation <$> commandName <*> commandParameters + commandName = char ':' *> many1 alphaNum <* optional ws + commandParameters = optionMaybe $ many1 (noneOf "\n") + + function = string "function" >> ws >> FunctionAnnotation <$> word <* optional ws + + mapping = string "mapping" >> ws >> MappingAnnotation <$> mappingName + mappingName = word <* optional ws + + option = string "option" >> ws >> OptionAnnotation <$> optionName <*> optionType <*> optionDefault + optionName = many1 (alphaNum <|> char ':') <* ws "option name" + optionType = many1 alphaNum <* optional ws "option type" + optionDefault = optionMaybe word "option default value" + + plugin = string "plugin" >> ws >> PluginAnnotation <$> pluginName <*> plugInDescription + pluginName = many1 alphaNum <* ws + plugInDescription = restOfLine + +-- | Parses a translation unit (file contents) into an AST. +unit :: Parser Node +unit = Unit + <$> (skippable >> many node) + <* eof + +skippable = many $ choice [ comment + , skipMany1 ws + , skipMany1 (char '\n') + ] + +parse :: String -> IO Node +parse fileName = parseFromFile unit fileName >>= either report return + where + report err = do + hPutStrLn stderr $ "Error: " ++ show err + exitFailure diff --git a/lib/Docvim/Printer/Markdown.hs b/lib/Docvim/Printer/Markdown.hs new file mode 100644 --- /dev/null +++ b/lib/Docvim/Printer/Markdown.hs @@ -0,0 +1,150 @@ +module Docvim.Printer.Markdown (markdown) where + +import Control.Monad.Reader +import Data.List (intercalate, sort) +import Data.Maybe (fromMaybe) +import Docvim.AST +import Docvim.Parse (rstrip) +import Docvim.Visitor.Plugin (getPluginName) +import Docvim.Visitor.Symbol (getSymbols) + +data Metadata = Metadata { symbols :: [String] + , pluginName :: Maybe String + } +type Env = Reader Metadata String + +data Anchor = Anchor [Attribute] String +data Attribute = Attribute { attributeName :: String + , attributeValue :: String + } + +markdown :: Node -> String +markdown n = rstrip (runReader (node n) metadata) ++ "\n" + where metadata = Metadata (getSymbols n) (getPluginName n) + +nodes :: [Node] -> Env +nodes ns = concat <$> mapM node ns + +node :: Node -> Env +node n = case n of + Blockquote b -> blockquote b >>= nl >>= nl + -- TODO, for readability, this should be "
\n" (custom, context-aware separator; see Vim.hs) + BreakTag -> return "
" + Code c -> return $ "`" ++ c ++ "`" + CommandAnnotation {} -> return $ command n + CommandsAnnotation -> return $ h2 "Commands" -- TODO link to foocommands + DocBlock d -> nodes d + Fenced f -> return $ fenced f ++ "\n\n" + FunctionDeclaration {} -> nodes $ functionBody n + FunctionsAnnotation -> return $ h2 "Functions" -- TODO link to foofunctions + -- TODO: add an anchor here + HeadingAnnotation h -> return $ h2 h -- TODO link? + Link l -> link l + LinkTargets l -> return $ linkTargets l + List ls -> nodes ls >>= nl + ListItem l -> fmap ("- " ++) (nodes l) >>= nl + MappingAnnotation m -> return $ mapping m + MappingsAnnotation -> return $ h2 "Mappings" -- TODO link to foomappings + OptionAnnotation {} -> return $ option n + OptionsAnnotation -> return $ h2 "Options" -- TODO link to foooptions + Paragraph p -> nodes p >>= nl >>= nl + Plaintext p -> return p + -- TODO: this should be order-independent and always appear at the top. + -- Note that I don't really have anywhere to put the description; maybe I should + -- scrap it (nope: need it in the Vim help version). + PluginAnnotation name _ -> return $ h1 name + Project p -> nodes p + Separator -> return $ "---" ++ "\n\n" + SubheadingAnnotation s -> return $ h3 s + Unit u -> nodes u + Whitespace -> return " " + _ -> return "" + +-- | Append a newline. +nl :: String -> Env +nl = return . (++ "\n") + +blockquote :: [Node] -> Env +blockquote ps = do + ps' <- mapM paragraph ps + return $ "> " ++ intercalate "\n>\n> " ps' + where + -- Strip off trailing newlines from each paragraph. + paragraph p = fmap trim (node p) + trim contents = take (length contents - 2) contents + +-- TODO: handle "interesting" link text like containing [, ], " +link :: String -> Env +link l = do + metadata <- ask + return $ if l `elem` symbols metadata + -- TODO: beware names with < ` etc in them + -- TODO: consider not using + then "[`" ++ l ++ "`](" ++ gitHubAnchor l ++ ")" + else "`" ++ l ++ "`" -- TODO: + -- may want to try producing a link to Vim + -- online help if I can find a search for it + +fenced :: [String] -> String +fenced f = "```\n" ++ code ++ "```" + where code = if null f + then "" + else intercalate "\n" f ++ "\n" + +linkTargets :: [String] -> String +linkTargets ls = "

" + ++ unwords (map linkify $ sort ls) + ++ "

" + ++ "\n" + where + linkify l = a $ Anchor [ Attribute "name" (sanitizeAnchor l) + , Attribute "href" (gitHubAnchor l) + ] + (codify l) + +h1 :: String -> String +h1 = heading 1 + +h2 :: String -> String +h2 = heading 2 + +h3 :: String -> String +h3 = heading 3 + +heading :: Int -> String -> String +heading level string = replicate level '#' ++ " " ++ string ++ "\n\n" + +-- | Wraps a string in ``/`` tags. +-- TODO: remember why I'm not using backticks here. +codify :: String -> String +codify s = "" ++ s ++ "" + +a :: Anchor -> String +a (Anchor attributes target) = "" ++ target ++ "" + where + attrs = if not (null attributes) + then " " ++ attributesString attributes + else "" + +attributesString :: [Attribute] -> String +attributesString as = unwords (map attributeToString as) + where attributeToString (Attribute name value) = name ++ "=\"" ++ value ++ "\"" + +gitHubAnchor :: String -> String +gitHubAnchor n = "#user-content-" ++ sanitizeAnchor n + +-- TODO: make sure symbol table knows about option targets too +option :: Node -> String +option (OptionAnnotation n t d) = targets ++ h + where targets = linkTargets [n] + h = h3 $ "`" ++ n ++ "` (" ++ t ++ ", default: " ++ def ++ ")" + def = fromMaybe "none" d + +command :: Node -> String +command (CommandAnnotation name params) = target ++ content + where target = linkTargets [":" ++ name] + content = h3 $ "`:" ++ annotation ++ "`" + annotation = rstrip $ name ++ " " ++ fromMaybe "" params + +mapping :: String -> String +mapping name = h3 $ "`" ++ name ++ "`" diff --git a/lib/Docvim/Printer/Vim.hs b/lib/Docvim/Printer/Vim.hs new file mode 100644 --- /dev/null +++ b/lib/Docvim/Printer/Vim.hs @@ -0,0 +1,307 @@ +module Docvim.Printer.Vim (vimHelp) where + +import Control.Arrow ((***)) +import Control.Monad (join) +import Control.Monad.Reader +import Control.Monad.State +import Data.Char (isSpace, toLower, toUpper) +import Data.List (intercalate, isSuffixOf, span, sort) +import Data.List.Split (splitOn) +import Data.Maybe (fromJust, fromMaybe) +import Data.Tuple (swap) +import Docvim.AST +import Docvim.Parse (rstrip) +import Docvim.Visitor.Plugin (getPluginName) +import Docvim.Visitor.Symbol (getSymbols) + +-- TODO: add indentation here (using local, or just stick it in Context) + +-- Instead of building up a [Char], we build up a list of operations, which +-- allows us a mechanism of implementing rollback and therefore hard-wrapping +-- (eg. append whitespace " ", then on next node, realize that we will exceed +-- line length limit, so rollback the " " and instead append "\n" etc). +data Operation = Append String + | Delete Int -- unconditional delete count of Char + | Slurp String -- delete string if present +data Metadata = Metadata { symbols :: [String] + , pluginName :: Maybe String + } +data Context = Context { lineBreak :: String + , partialLine :: String + } +type Env = ReaderT Metadata (State Context) [Operation] + +textwidth :: Int +textwidth = 78 + +vimHelp :: Node -> String +vimHelp n = suppressTrailingWhitespace output ++ "\n" + where metadata = Metadata (getSymbols n) (getPluginName n) + context = Context defaultLineBreak "" + operations = evalState (runReaderT (node n) metadata) context + output = foldl reduce "" operations + reduce acc (Append atom) = acc ++ atom + reduce acc (Delete count) = take (length acc - count) acc + reduce acc (Slurp atom) = if atom `isSuffixOf` acc + then take (length acc - length atom) acc + else acc + suppressTrailingWhitespace str = rstrip $ intercalate "\n" (map rstrip (splitOn "\n" str)) + +-- | Helper function that appends and updates `partialLine` context, +-- hard-wrapping if necessary to remain under `textwidth`. +append :: String -> Env +append string = append' string textwidth + +-- | Helper function that appends and updates `partialLine` context +-- uncontitionally (no hard-wrapping). +appendNoWrap :: String -> Env +appendNoWrap string = append' string (maxBound :: Int) + +append' :: String -> Int -> Env +append' string width = do + context <- get + -- TODO obviously tidy this up + let (ops, line) = if renderedWidth (partialLine context) + renderedWidth leading >= width + then ( [ Delete (length $ snd $ hardwrap $ partialLine context) + , Slurp " " + , Append (lineBreak context) + , Append (snd $ hardwrap $ partialLine context) + , Append string + ] + , lineBreak context ++ snd (hardwrap $ partialLine context) ++ string + ) + else ([Append string], partialLine context ++ string) + put (Context (lineBreak context) (end line)) + return ops + where + leading = takeWhile (/= '\n') string + trailing str = length $ takeWhile isSpace (reverse str) + end l = reverse $ takeWhile (/= '\n') (reverse l) + +-- http://stackoverflow.com/a/9723976/2103996 +mapTuple = join (***) + +-- Given a string, hardwraps it into two parts by splitting it at the rightmost +-- whitespace. +hardwrap :: String -> (String, String) +hardwrap str = swap $ mapTuple reverse split + where + split = break isSpace (reverse str) + +-- Helper function that deletes `count` elements from the end of the +--`partialLine` context. +delete :: Int -> Env +delete count = do + context <- get + put (Context (lineBreak context) (partial context)) + return [Delete count] + where + partial context = take (length (partialLine context) - count) (partialLine context) + +-- Helper function to conditionally remove a string if it appears at the end of +-- the output. +slurp :: String -> Env +slurp str = do + context <- get + put (Context (lineBreak context) (partial context)) + return [Slurp str] + where + -- eg. (partialLine context) | str | result + -- ----------------------|------------|------- + -- "" | "\n" | "" + -- "foo" | "\n" | "foo" + -- "foo" | "bar" | "foo" + -- "abc" | "bc" | "a" + -- "abc" | "foo\nabc" | "" + -- + -- Note: That last one is unsafe, because we can't guarantee that "foo" is + -- there. Caveat emptor! + partial context = if str `isSuffixOf` partialLine context + then take (length (partialLine context) - length str) (partialLine context) + else partialLine context + +defaultLineBreak :: String +defaultLineBreak = "\n" + +nodes :: [Node] -> Env +nodes ns = concat <$> mapM node ns + +node :: Node -> Env +node n = case n of + Blockquote b -> blockquote b >>= nl >>= nl + BreakTag -> breaktag + Code c -> append $ "`" ++ c ++ "`" + CommandAnnotation {} -> command n + CommandsAnnotation -> heading "commands" + DocBlock d -> nodes d + Fenced f -> fenced f + FunctionsAnnotation -> heading "functions" + FunctionDeclaration {} -> nodes $ functionBody n + HeadingAnnotation h -> heading h + Link l -> append $ link l + LinkTargets l -> linkTargets l True + List ls -> nodes ls >>= nl + ListItem l -> listitem l + MappingAnnotation m -> mapping m + MappingsAnnotation -> heading "mappings" + OptionAnnotation {} -> option n + OptionsAnnotation -> heading "options" + Paragraph p -> nodes p >>= nl >>= nl + Plaintext p -> plaintext p + PluginAnnotation name desc -> plugin name desc + Project p -> nodes p + Separator -> append $ "---" ++ "\n\n" + SubheadingAnnotation s -> append $ s ++ " ~\n\n" + TOC t -> toc t + Unit u -> nodes u + Whitespace -> whitespace + _ -> append "" + +-- TODO: add {name}.txt to the symbol table? +plugin :: String -> String -> Env +plugin name desc = append $ + "*" ++ name ++ ".txt*" ++ + " " ++ desc ++ " " ++ + "*" ++ name ++ "*" ++ "\n\n" + +-- | Append a newline. +nl :: [Operation] -> Env +nl os = liftM2 (++) (return os) (append "\n") + +breaktag :: Env +breaktag = do + state <- get + append $ lineBreak state + +listitem :: [Node] -> Env +listitem l = do + context <- get + -- TODO: consider using lenses to modify records + put (Context customLineBreak (partialLine context)) + item <- liftM2 (++) (append "- ") (nodes l) >>= nl + put (Context defaultLineBreak (partialLine context)) + return item + where + customLineBreak = "\n " + +toc :: [String] -> Env +toc t = do + metadata <- ask + toc' $ fromJust $ pluginName metadata + where + toc' p = do + h <- heading "contents" + entries <- append $ intercalate "\n" format ++ "\n\n" + return (h ++ entries) + where + format = map pad numbered + longest = maximum (map (length . snd) numbered ) + numbered = map prefix number + number = zip3 [1..] t (map (\x -> normalize $ p ++ "-" ++ x) t) + prefix (num, desc, l) = (show num ++ ". " ++ desc ++ " ", l) + pad (lhs, rhs) = lhs ++ replicate (longest - length lhs) ' ' ++ link rhs + -- TODO: consider doing this for markdown format too + +command :: Node -> Env +command (CommandAnnotation name params) = do + lhs <- append $ concat [":", name, " ", fromMaybe "" params] + ws <- append " " + target <- linkTargets [":" ++ name] False + trailing <- append "\n" + return $ concat [lhs, ws, target, trailing] +-- TODO indent what follows until next annotation... +-- will require us to hoist it up inside CommandAnnotation +-- (and do similar for other sections) +-- once that is done, drop the extra newline above + +mapping :: String -> Env +mapping name = linkTargets [name] True + +option :: Node -> Env +option (OptionAnnotation n t d) = do + targets <- linkTargets [n] True + opt <- appendNoWrap $ link n + ws <- appendNoWrap " " + context <- get + meta <- appendNoWrap $ aligned context + return $ concat [targets, opt, ws, meta] + where + aligned context = rightAlign context rhs + rhs = t ++ " (default: " ++ fromMaybe "none" d ++ ")\n\n" + +whitespace :: Env +whitespace = append " " + +blockquote :: [Node] -> Env +blockquote ps = do + context <- get + put (Context customLineBreak (partialLine context)) + ps' <- mapM paragraph ps + put (Context defaultLineBreak (partialLine context)) + liftM2 (++) (append " ") (liftM2 intercalate customParagraphBreak (return ps')) + where + -- Strip off trailing newlines from each paragraph. + paragraph p = fmap trim (node p) + trim contents = take (length contents - 2) contents + customLineBreak = "\n " + customParagraphBreak = append "\n\n " + +plaintext :: String -> Env +plaintext = append + +fenced :: [String] -> Env +fenced f = do + cut <- slurp "\n" + prefix <- append ">\n" + body <- if null f + then append "" + else appendNoWrap $ " " ++ intercalate "\n " f ++ "\n" + suffix <- append "<\n" + return $ concat [cut, prefix, body, suffix] + +heading :: String -> Env +heading h = do + metadata <- ask + heading' <- appendNoWrap $ map toUpper h ++ " " + target <- maybe (append "\n") (\x -> linkTargets [target x] False) (pluginName metadata) + trailing <- append "\n" + return $ concat [heading', target, trailing] + where + target x = normalize $ x ++ "-" ++ h + +normalize :: String -> String +normalize = map (toLower . sanitize) + +sanitize :: Char -> Char +sanitize x = if isSpace x then '-' else x + +link :: String -> String +link l = "|" ++ l ++ "|" + +-- TODO: be prepared to wrap these if there are a lot of them +-- TODO: fix code smell of passing in `wrap` bool here +linkTargets :: [String] -> Bool -> Env +linkTargets ls wrap = do + context <- get + if wrap + then append $ aligned context + else appendNoWrap $ aligned context + where + aligned context = rightAlign context (targets ++ "\n") + targets = unwords (map linkify $ sort ls) + linkify l = "*" ++ l ++ "*" + +rightAlign :: Context -> String -> String +rightAlign context string = align (partialLine context) + where + align used = replicate (count used string) ' ' ++ string + count used xs = maximum [textwidth - renderedWidth xs - renderedWidth used, 0] + +-- Crude approximation for calculating rendered width, that does so by not +-- counting the relatively rare |, *, ` and "\n" -- all of which usually get +-- concealed in the rendered output. +renderedWidth :: String -> Int +renderedWidth = foldr reduce 0 + where reduce char acc = if char `elem` "\n|*`" + then acc + else acc + 1 diff --git a/lib/Docvim/ReadDir.hs b/lib/Docvim/ReadDir.hs new file mode 100644 --- /dev/null +++ b/lib/Docvim/ReadDir.hs @@ -0,0 +1,20 @@ +-- | Recursively read the paths in a directory. +-- +-- Based on `RecursiveContents` example in chapter 9 of "Real World Haskell". +module Docvim.ReadDir (readDir) where + +import Control.Monad (forM) +import System.Directory (doesDirectoryExist, getDirectoryContents) +import System.FilePath (()) + +readDir :: FilePath -> IO [FilePath] +readDir dir = do + names <- getDirectoryContents dir + let properNames = filter (`notElem` [".", ".."]) names + paths <- forM properNames $ \name -> do + let path = dir name + isDirectory <- doesDirectoryExist path + if isDirectory + then readDir path + else return [path] + return (concat paths) diff --git a/lib/Docvim/Util.hs b/lib/Docvim/Util.hs new file mode 100644 --- /dev/null +++ b/lib/Docvim/Util.hs @@ -0,0 +1,64 @@ +-- | Functions to facilitate automated and manual testing. +module Docvim.Util ( compileUnit + , p + , pm + , pp + , ppm + , ppv + , pv + ) where + +import Docvim.AST (Node) +import Docvim.Compile (compile) +import Docvim.Parse (unit) +import Docvim.Printer.Markdown (markdown) +import Docvim.Printer.Vim (vimHelp) +import Text.Parsec (ParseError, runParser) +import Text.Show.Pretty (ppShow) + +-- | Parse and compile a string containing a translation unit. +compileUnit :: String -> Either ParseError Node +compileUnit input = do + parsed <- runParser unit () "(eval)" input + return $ compile [parsed] + +-- | Convenience function: Parse and compile a string containing a translation +-- unit, but always returns a string even in the case of an error. +p :: String -> String +p input = case compileUnit input of + Left error -> show error + Right ast -> ppShow ast + +-- | Pretty-prints the result of parsing and compiling an input string. +-- +-- To facilitate quick testing in the REPL; example: +-- +-- pp "unlet g:var" +pp :: String -> IO () +pp = putStrLn . p + +-- | Parse and compile an input string into Vim help format. +pv :: String -> String +pv input = case compileUnit input of + Left error -> show error + Right ast -> vimHelp ast + +-- | Pretty-prints the result of parsing and compiling an input string and +-- transforming into Vim help format. +-- +-- For logging in the REPL. +ppv :: String -> IO () +ppv = putStr . pv + +-- | Parse and compile an input string into Markdown help format. +pm :: String -> String +pm input = case compileUnit input of + Left error -> show error + Right ast -> markdown ast + +-- | Pretty-prints the result of parsing and compiling an input string and +-- transforming into Markdown format. +-- +-- For logging in the REPL. +ppm :: String -> IO () +ppm = putStr . pm diff --git a/lib/Docvim/Visitor.hs b/lib/Docvim/Visitor.hs new file mode 100644 --- /dev/null +++ b/lib/Docvim/Visitor.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleContexts #-} + +module Docvim.Visitor (endSection, extract, extractBlocks) where + +import Control.Applicative (Alternative, (<|>), empty) +import Control.Monad ((>=>)) +import Control.Monad.Writer (runWriter, tell) +import Data.Data.Lens +import Docvim.AST +import qualified Data.DList as DList + +-- | Returns True if a node marks the end of a region/block/section. +endSection :: Node -> Bool +endSection = \case + CommandAnnotation {} -> True + CommandsAnnotation -> True + FooterAnnotation -> True + FunctionAnnotation _ -> True + FunctionsAnnotation -> True + MappingAnnotation _ -> True + MappingsAnnotation -> True + OptionAnnotation {} -> True + OptionsAnnotation -> True + PluginAnnotation {} -> True + _ -> False + +extract :: ([Node] -> ([[a]], [Node])) -> Node -> (Node, [a]) +extract extractNodes = toList . runWriter . postorder uniplate extractor + where + toList (ast, dlist) = (ast, concat $ DList.toList dlist) + extractor (DocBlock nodes) = do + let (extracted, remainder) = extractNodes nodes + tell (DList.fromList extracted) + return (DocBlock remainder) + extractor node = return node + +extractBlocks :: Alternative f => (a -> Maybe (a -> Bool)) -> [a] -> (f [a], [a]) +extractBlocks start = go + where + go [] = (empty, []) + go (x:xs) = maybe no_extract extract (start x) + where + no_extract = (extracted, x:unextracted) + where + ~(extracted, unextracted) = go xs + extract stop = (pure (x:block) <|> extracted, unextracted) + where + ~(block, remainder) = break stop xs + ~(extracted, unextracted) = go remainder + +postorder :: Monad m => ((a -> m c) -> (a -> m b)) -> (b -> m c) -> (a -> m c) +postorder t f = go + where + go = t go >=> f diff --git a/lib/Docvim/Visitor/Command.hs b/lib/Docvim/Visitor/Command.hs new file mode 100644 --- /dev/null +++ b/lib/Docvim/Visitor/Command.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE LambdaCase #-} + +module Docvim.Visitor.Command (extractCommand) where + +import Control.Applicative (Alternative) +import Docvim.AST (Node(CommandAnnotation)) +import Docvim.Visitor (endSection, extractBlocks) + +-- | Extracts a list of nodes (if any exist) identified by the `@command` +-- annotation of the source code. +extractCommand :: Alternative f => [Node] -> (f [Node], [Node]) +extractCommand = extractBlocks f + where + f = \case + CommandAnnotation {} -> Just endSection + _ -> Nothing diff --git a/lib/Docvim/Visitor/Commands.hs b/lib/Docvim/Visitor/Commands.hs new file mode 100644 --- /dev/null +++ b/lib/Docvim/Visitor/Commands.hs @@ -0,0 +1,19 @@ +module Docvim.Visitor.Commands (extractCommands) where + +import Control.Applicative (Alternative) +import Docvim.AST (Node(CommandsAnnotation)) +import Docvim.Visitor (endSection, extractBlocks) + +-- | Extracts a list of nodes (if any exist) from the `@commands` section(s) of +-- the source code. +-- +-- It is not recommended to have multiple `@commands` sections in a project. If +-- multiple such sections (potentially across multiple translation units) exist, +-- there are no guarantees about order; they just get concatenated in the order +-- we see them. +extractCommands :: Alternative f => [Node] -> (f [Node], [Node]) +extractCommands = extractBlocks f + where + f x = if x == CommandsAnnotation + then Just endSection + else Nothing diff --git a/lib/Docvim/Visitor/Footer.hs b/lib/Docvim/Visitor/Footer.hs new file mode 100644 --- /dev/null +++ b/lib/Docvim/Visitor/Footer.hs @@ -0,0 +1,19 @@ +module Docvim.Visitor.Footer (extractFooter) where + +import Control.Applicative (Alternative) +import Docvim.AST (Node(FooterAnnotation)) +import Docvim.Visitor (endSection, extractBlocks) + +-- | Extracts a list of nodes (if any exist) from the `@footer` section(s) of +-- the source code. +-- +-- It is not recommended to have multiple footers in a project. If multiple +-- footers (potentially across multiple translation units) exist, there are no +-- guarantees about order but they just get concatenated in the order we see +-- them. +extractFooter :: Alternative f => [Node] -> (f [Node], [Node]) +extractFooter = extractBlocks f + where + f x = if x == FooterAnnotation + then Just endSection + else Nothing diff --git a/lib/Docvim/Visitor/Function.hs b/lib/Docvim/Visitor/Function.hs new file mode 100644 --- /dev/null +++ b/lib/Docvim/Visitor/Function.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE LambdaCase #-} + +module Docvim.Visitor.Function (extractFunction) where + +import Control.Applicative (Alternative) +import Docvim.AST (Node(FunctionAnnotation)) +import Docvim.Visitor (endSection, extractBlocks) + +-- | Extracts a list of nodes (if any exist) identified by the `@function` +-- annotation of the source code. +extractFunction :: Alternative f => [Node] -> (f [Node], [Node]) +extractFunction = extractBlocks f + where + f = \case + FunctionAnnotation _ -> Just endSection + _ -> Nothing +-- TODO: plug this in to the Compile module +-- (note will need to implement printing as well) +-- TODO: verify that these do what we think they should do... (should they wrap +-- what they return in an array, or do they all get merged, and if they do, is +-- that ok? it probably is) +-- TODO: DRY these visitors up; they are all almost exactly the same diff --git a/lib/Docvim/Visitor/Functions.hs b/lib/Docvim/Visitor/Functions.hs new file mode 100644 --- /dev/null +++ b/lib/Docvim/Visitor/Functions.hs @@ -0,0 +1,19 @@ +module Docvim.Visitor.Functions (extractFunctions) where + +import Control.Applicative (Alternative) +import Docvim.AST (Node(FunctionsAnnotation)) +import Docvim.Visitor (endSection, extractBlocks) + +-- | Extracts a list of nodes (if any exist) from the `@functions` section(s) of +-- the source code. +-- +-- It is not recommended to have multiple `@functions` sections in a project. If +-- multiple such sections (potentially across multiple translation units) exist, +-- there are no guarantees about order; they just get concatenated in the order +-- we see them. +extractFunctions :: Alternative f => [Node] -> (f [Node], [Node]) +extractFunctions = extractBlocks f + where + f x = if x == FunctionsAnnotation + then Just endSection + else Nothing diff --git a/lib/Docvim/Visitor/Heading.hs b/lib/Docvim/Visitor/Heading.hs new file mode 100644 --- /dev/null +++ b/lib/Docvim/Visitor/Heading.hs @@ -0,0 +1,31 @@ +module Docvim.Visitor.Heading ( getHeadings + , injectTOC + ) where + +import Control.Lens +import Control.Lens.Plated (transform) +import Data.Data.Lens (uniplate) +import Docvim.AST + +-- | Returns a list of all headings, in the order in which they appear in the +-- AST. +getHeadings :: Node -> [String] +getHeadings = walk gather [] + where + gather CommandsAnnotation = ["Commands"] + gather FunctionsAnnotation = ["Functions"] + gather (HeadingAnnotation h) = [h] + gather MappingsAnnotation = ["Mappings"] + gather OptionsAnnotation = ["Options"] + gather _ = [] + +-- | Injects a table of contents immediately after any `PluginAnnotation` in an +-- AST (note: there should only be one). +-- TODO: warn or error if there is more than one. +-- or use a monadic variant of transform to do only the first... +injectTOC :: Node -> Node +injectTOC ast = transform inject ast + where + inject n = case n of + PluginAnnotation {} -> DocBlock $ n : [TOC $ getHeadings ast] + _ -> n diff --git a/lib/Docvim/Visitor/Mapping.hs b/lib/Docvim/Visitor/Mapping.hs new file mode 100644 --- /dev/null +++ b/lib/Docvim/Visitor/Mapping.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE LambdaCase #-} + +module Docvim.Visitor.Mapping (extractMapping) where + +import Control.Applicative (Alternative) +import Docvim.AST (Node(MappingAnnotation)) +import Docvim.Visitor (endSection, extractBlocks) + +-- | Extracts a list of nodes (if any exist) identified by the `@mapping` +-- annotation of the source code. +extractMapping :: Alternative f => [Node] -> (f [Node], [Node]) +extractMapping = extractBlocks f + where + f = \case + MappingAnnotation _ -> Just endSection + _ -> Nothing diff --git a/lib/Docvim/Visitor/Mappings.hs b/lib/Docvim/Visitor/Mappings.hs new file mode 100644 --- /dev/null +++ b/lib/Docvim/Visitor/Mappings.hs @@ -0,0 +1,20 @@ +module Docvim.Visitor.Mappings (extractMappings) where + +import Control.Applicative (Alternative) +import Docvim.AST (Node(MappingsAnnotation)) +import Docvim.Visitor (endSection, extractBlocks) + +-- | Extracts a list of nodes (if any exist) from the `@mappings` section(s) of +-- the source code. +-- +-- It is not recommended to have multiple `@mappings` sections in a project. If +-- multiple such sections (potentially across multiple translation units) exist, +-- there are no guarantees about order; they just get concatenated in the order +-- we see them. +extractMappings :: Alternative f => [Node] -> (f [Node], [Node]) +extractMappings = extractBlocks f + where + f x = if x == MappingsAnnotation + then Just endSection + else Nothing +-- TODO: DRY all these up diff --git a/lib/Docvim/Visitor/Option.hs b/lib/Docvim/Visitor/Option.hs new file mode 100644 --- /dev/null +++ b/lib/Docvim/Visitor/Option.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE LambdaCase #-} + +module Docvim.Visitor.Option (extractOption) where + +import Control.Applicative (Alternative) +import Docvim.AST (Node(OptionAnnotation)) +import Docvim.Visitor (endSection, extractBlocks) + +-- | Extracts a list of nodes (if any exist) identified by the `@option` +-- annotation of the source code. +extractOption :: Alternative f => [Node] -> (f [Node], [Node]) +extractOption = extractBlocks f + where + f = \case + OptionAnnotation {} -> Just endSection + _ -> Nothing diff --git a/lib/Docvim/Visitor/Options.hs b/lib/Docvim/Visitor/Options.hs new file mode 100644 --- /dev/null +++ b/lib/Docvim/Visitor/Options.hs @@ -0,0 +1,19 @@ +module Docvim.Visitor.Options (extractOptions) where + +import Control.Applicative (Alternative) +import Docvim.AST (Node(OptionsAnnotation)) +import Docvim.Visitor (endSection, extractBlocks) + +-- | Extracts a list of nodes (if any exist) from the `@options` section(s) of +-- the source code. +-- +-- It is not recommended to have multiple `@options` sections in a project. If +-- multiple such sections (potentially across multiple translation units) exist, +-- there are no guarantees about order; they just get concatenated in the order +-- we see them. +extractOptions :: Alternative f => [Node] -> (f [Node], [Node]) +extractOptions = extractBlocks f + where + f x = if x == OptionsAnnotation + then Just endSection + else Nothing diff --git a/lib/Docvim/Visitor/Plugin.hs b/lib/Docvim/Visitor/Plugin.hs new file mode 100644 --- /dev/null +++ b/lib/Docvim/Visitor/Plugin.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE LambdaCase #-} + +module Docvim.Visitor.Plugin ( getPluginName + , extractPlugin + ) where + +import Control.Applicative (Alternative) +import Docvim.AST (Node(PluginAnnotation), walk) +import Docvim.Visitor (endSection, extractBlocks) + +-- | Returns the name of the plug-in or Nothing if none is found. +-- +-- In the event that there are multiple `@plugin` annotations competing to +-- define the name of plugin, the first encountered one wins. +getPluginName :: Node -> Maybe String +getPluginName node = name + where + name = if null names + then Nothing + else Just $ head names + names = walk getName [] node + getName (PluginAnnotation name _) = [name] + getName _ = [] + +-- | Extracts a list of nodes (if any exist) from the `@plugin` section(s) of +-- the source code. +-- +-- It is not recommended to have multiple `@plugin` sections in a project. If +-- multiple such sections (potentially across multiple translation units) exist, +-- there are no guarantees about order; they just get concatenated in the order +-- we see them. +extractPlugin :: Alternative f => [Node] -> (f [Node], [Node]) +extractPlugin = extractBlocks f + where + f = \case + PluginAnnotation {} -> Just endSection + _ -> Nothing diff --git a/lib/Docvim/Visitor/Section.hs b/lib/Docvim/Visitor/Section.hs new file mode 100644 --- /dev/null +++ b/lib/Docvim/Visitor/Section.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TemplateHaskell #-} + +module Docvim.Visitor.Section ( injectCommands + , injectFunctions + , injectMappings + , injectOptions + ) where + +import Control.Lens +import Control.Monad.State +import Data.Data.Lens (uniplate) +import Docvim.AST + +data SectionInfo = SectionInfo { _hasCommand :: Bool + , _hasCommands :: Bool + , _hasFunction :: Bool + , _hasFunctions :: Bool + , _hasMapping :: Bool + , _hasMappings :: Bool + , _hasOption :: Bool + , _hasOptions :: Bool + } deriving (Show) + +-- Could also have written record setters by hand, but too lazy to do this: +-- +-- setHasCommand :: SectionInfo -> SectionInfo +-- setHasCommand info = info { hasCommand = True } +-- +-- With lenses, we can auto-generate functions that we call like this: +-- +-- view hasCommand info (reading) +-- info ^. hasCommand (reading, using operator) +-- set hasCommand True info (writing) +-- info & hasCommand .~ True (writing, using operators) +-- +-- Or, given that we are using the State monad here, we'll be using the `.=` +-- operator to update the state using a lens. +-- +makeLenses ''SectionInfo + +defaultSectionInfo :: SectionInfo +defaultSectionInfo = SectionInfo { _hasCommand = False + , _hasCommands = False + , _hasFunction = False + , _hasFunctions = False + , _hasMapping = False + , _hasMappings = False + , _hasOption = False + , _hasOptions = False + } + +-- | Walks the supplied AST detecting whether it contains +-- `@commands`/`@command`, `@functions`/`@function`, `@mappings`/`@mapping` or +-- `@options`/`@options` sections. +-- +-- Will be used as follows: +-- - DO have @commands? -> do nothing +-- - DON'T have @commands but DO have @command? -> Synthesize CommandsAnnotation +-- - DON'T we have either? -> do nothing +-- +getSectionInfo :: Node -> SectionInfo +getSectionInfo n = execState (mapMOf_ (cosmosOf uniplate) check n) defaultSectionInfo + where + check CommandAnnotation {} = hasCommand .= True + check CommandsAnnotation = hasCommands .= True + check (FunctionAnnotation _) = hasFunction .= True + check FunctionsAnnotation = hasFunctions .= True + check (MappingAnnotation _) = hasMapping .= True + check MappingsAnnotation = hasMappings .= True + check OptionAnnotation {} = hasOption .= True + check OptionsAnnotation = hasOptions .= True + check _ = modify id + +-- | Appends a node to the end of a Project. +inject :: Node -> Node -> Node +inject (Project ns) n = Project $ ns ++ [n] +inject other _ = other + +injectCommands :: Node -> Node +injectCommands n = + if | getSectionInfo n ^. hasCommands -> n + | getSectionInfo n ^. hasCommand -> inject n CommandsAnnotation + | otherwise -> n + +injectFunctions :: Node -> Node +injectFunctions n = + if | getSectionInfo n ^. hasFunctions -> n + | getSectionInfo n ^. hasFunction -> inject n FunctionsAnnotation + | otherwise -> n + +injectMappings :: Node -> Node +injectMappings n = + if | getSectionInfo n ^. hasMappings -> n + | getSectionInfo n ^. hasMapping -> inject n MappingsAnnotation + | otherwise -> n + +injectOptions :: Node -> Node +injectOptions n = + if | getSectionInfo n ^. hasOptions -> n + | getSectionInfo n ^. hasOption -> inject n OptionsAnnotation + | otherwise -> n diff --git a/lib/Docvim/Visitor/Symbol.hs b/lib/Docvim/Visitor/Symbol.hs new file mode 100644 --- /dev/null +++ b/lib/Docvim/Visitor/Symbol.hs @@ -0,0 +1,49 @@ +module Docvim.Visitor.Symbol (getSymbols) where + +import Data.Char (toLower) +import Data.List (nub, sort) +import qualified Data.Set as Set +import Docvim.AST +import Docvim.Visitor.Plugin (getPluginName) + +-- TODO: return Set instead of [String] +-- TODO: use Either instead of dying unceremoniously with `error` +getSymbols :: Node -> [String] +getSymbols node = if length symbols == Set.size set + then symbols + -- BUG: validation doesn't seem to run at all for: + -- ppm "\"\" @plugin ZZZZ thing\n\" # thing\n\" # thingz\n\" # thingy\n\" thing\n\"\n\" # thingz\n\" # thingz\n" + -- but it does run for: + -- ppm "\"\" @plugin ZZZZ thing\n\" # thing\n\" # thingz\n\" # thingy\n\" |thing|\n\"\n\" # thingz\n\" # thingz\n" + -- yet the AST for the first tree does trip us up in here: + -- let x (Right y) = y + -- let y = parseUnit "\"\" @plugin ZZZZ thing\n\" # thing\n\" # thingz\n\" # thingy\n\" thing\n\"\n\" # thingz\n\" # thingz\n" + -- getSymbols (x y) -- BOOM! + -- what's making the expection get swallowed in the ppm case? + else error $ "Duplicate symbol table entries: " ++ show duplicates + where + set = Set.fromList symbols + symbols = walk gatherSymbols [] node + gatherSymbols (CommandAnnotation n _) = [":" ++ n] + gatherSymbols CommandsAnnotation = genHeading "commands" + gatherSymbols FunctionsAnnotation = genHeading "functions" + gatherSymbols (HeadingAnnotation h) = genHeading h + gatherSymbols (LinkTargets ts) = ts + -- TODO: probably don't want this target to exist in the symbol table when + -- emitting Markdown + gatherSymbols (PluginAnnotation name _) = [name, name ++ ".txt"] + gatherSymbols (MappingAnnotation m) = [m] + gatherSymbols MappingsAnnotation = genHeading "mappings" + gatherSymbols OptionsAnnotation = genHeading "options" + gatherSymbols _ = [] + genHeading h = maybe [] (\x -> [sanitizeAnchor $ x ++ "-" ++ h]) (getPluginName node) + duplicates = nub $ f (sort symbols) + where + f [] = [] + f [x] = [] + f (x:xs) = if x == head xs + then x : f xs + else f xs + +downcase :: String -> String +downcase = map toLower diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,8 @@ +-- | The docvim executable. +module Main (main) where + +import Docvim.CLI (run) + +-- | Run the executable using the supplied options. +main :: IO () +main = run diff --git a/tests/HLint.hs b/tests/HLint.hs new file mode 100644 --- /dev/null +++ b/tests/HLint.hs @@ -0,0 +1,9 @@ +module Main (main) where + +import Language.Haskell.HLint (hlint) +import System.Exit (exitFailure, exitSuccess) + +main :: IO () +main = do + hints <- hlint ["lib", "src"] + if null hints then exitSuccess else exitFailure diff --git a/tests/Tasty.hs b/tests/Tasty.hs new file mode 100644 --- /dev/null +++ b/tests/Tasty.hs @@ -0,0 +1,173 @@ +module Main (main) where + +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Lazy as LazyByteString +import Control.DeepSeq (rnf) +import Control.Exception (evaluate) +import Data.ByteString.Lazy.Char8 (pack, unpack) +import Data.Char (chr) +import Data.List (isPrefixOf, sort) +import Data.Monoid (Sum(..)) +import Docvim.AST +import Docvim.Util (compileUnit, p, pm, pv) +import Docvim.Visitor.Symbol (getSymbols) +import System.Exit (ExitCode(ExitSuccess)) +import System.FilePath ((<.>), replaceExtension, takeBaseName, takeFileName) +import System.IO (hFlush, readFile) +import System.IO.Temp (withSystemTempFile) +import System.Process ( StdStream(CreatePipe) + , createProcess + , proc + , std_out + , waitForProcess + ) +import Test.Tasty (testGroup, TestName, TestTree, defaultMain) +import Test.Tasty.Golden (findByExtension) +import Test.Tasty.Golden.Advanced (goldenTest) +import Test.Tasty.HUnit + +-- | Crude check to see if parse worked. +parseSuccess :: Either a b -> Bool +parseSuccess (Left _) = False +parseSuccess _ = True + +parseFailure :: Either a b -> Bool +parseFailure = not . parseSuccess + +unitTests :: TestTree +unitTests = testGroup "Unit tests" + [ testCase "Compile empty unit" $ assert $ parseSuccess (compileUnit "") + , testCase "Compile whitespace-only unit" $ assert $ parseSuccess (compileUnit " \n ") + + , testCase "Counting all nodes" $ + 7 @=? let + tree = Unit + [ FunctionDeclaration True + "name" + (ArgumentList []) + [] + [UnletStatement True "foo"] + , DocBlock [ HeadingAnnotation "foo" + , SubheadingAnnotation "bar" + , SubheadingAnnotation "baz" + ] + ] + counter _ = 1 + nodeCount = getSum $ walk counter (Sum 0) tree + in nodeCount + + , testCase "Gathering specific nodes" $ + [SubheadingAnnotation "bar", SubheadingAnnotation "baz"] @=? let + tree = DocBlock [ HeadingAnnotation "foo" + , SubheadingAnnotation "bar" + , SubheadingAnnotation "baz" + ] + accumulateSubheadings node@(SubheadingAnnotation _) = [node] + accumulateSubheadings _ = [] -- skip everything else + selection = walk accumulateSubheadings [] tree + in selection + + , testCase "Extracting symbols" $ + sort ["foo", "bar", "baz"] @=? let + tree = DocBlock [ LinkTargets ["foo"] + , LinkTargets ["bar", "baz"] + ] + symbols = sort $ getSymbols tree + in symbols + + , testCase "Synthesizing symbols from the @plugin annotation" $ + sort ["foo", "foo.txt", "bar"] @=? let + tree = DocBlock [ PluginAnnotation "foo" "some plugin" + , LinkTargets ["bar"] + ] + symbols = sort $ getSymbols tree + in symbols + + , testCase "Synthesizing symbols from the headings" $ + -- will need to pass in plugin name (prefix) to make this work + sort ["foo", "foo.txt", "foo-history", "foo-troubleshooting-tips", "bar"] @=? let + tree = DocBlock [ PluginAnnotation "foo" "some plugin" + , HeadingAnnotation "History" + , HeadingAnnotation "Troubleshooting tips" + , LinkTargets ["bar"] + ] + symbols = sort $ getSymbols tree + in symbols + ] + +goldenTests :: String -> [FilePath] -> (String -> String) -> TestTree +goldenTests description sources transform = testGroup groupName $ do + file <- sources -- list monad + let + run = do + input <- readFile file + let output = normalize $ transform input + return $ pack output -- pack because tasty-golden wants a ByteString + name = takeBaseName file + golden = replaceExtension file ".golden" + diff ref new = [ "git" + , "diff" + , "--color" + , "--diff-algorithm=histogram" + , ref + , new + ] + return $ goldenVsStringDiff' name diff golden run + where + groupName = "Golden " ++ description ++ " tests" + +-- | Normalize a string to always end with a newline, unless zero-length, to +-- match standard text editor behavior. +normalize :: String -> String +normalize s | s == "" = "" + | otherwise = if last s == '\n' then s else s ++ "\n" + +-- | This is based on `goldenVsStringDiff` function defined in: +-- https://github.com/feuerbach/tasty-golden/blob/470e7af018/Test/Tasty/Golden.hs#L150-L191 +-- +-- Differences: +-- +-- - Omission of the verbose/ugly failure output message (this is the +-- motivating change here). +-- - Strip diff headers up to first "@@" (again, for brevity). +-- - Some revised names to make things a little clearer. +-- - Removed an `error` call which I am not worried about needing. +-- +goldenVsStringDiff' :: TestName -> (FilePath -> FilePath -> [String]) -> FilePath -> IO LazyByteString.ByteString -> TestTree +goldenVsStringDiff' name diff golden run = + goldenTest + name + (ByteString.readFile golden) + (LazyByteString.toStrict <$> run) + compare + update + where + template = takeFileName golden <.> "actual" + hunkHeader = map chr [0x1b, 0x5b, 0x33, 0x36, 0x6d] ++ "@@ " + strip out = unlines $ dropWhile (not . isPrefixOf hunkHeader) (lines $ unpack out) + compare _ actBS = withSystemTempFile template $ \tmpFile tmpHandle -> do + ByteString.hPut tmpHandle actBS >> hFlush tmpHandle + let cmd = diff golden tmpFile + (_, Just sout, _, pid) <- createProcess (proc (head cmd) (tail cmd)) { std_out = CreatePipe } + out <- LazyByteString.hGetContents sout + evaluate . rnf $ out + r <- waitForProcess pid + return $ case r of + ExitSuccess -> Nothing + _ -> Just (strip out) + update = ByteString.writeFile golden + +getFixtures :: String -> IO [FilePath] +getFixtures = findByExtension [".vim"] + +main :: IO () +main = do + parserSources <- getFixtures "tests/fixtures/parser" + markdownSources <- getFixtures "tests/fixtures/markdown" + vimHelpSources <- getFixtures "tests/fixtures/vim" + defaultMain $ testGroup "Test suite" + [ unitTests + , goldenTests "parser" parserSources p + , goldenTests "Markdown printer" markdownSources pm + , goldenTests "Vim help printer" vimHelpSources pv + ]