docvim (empty) → 0.1.0.0
raw patch · 30 files changed
+2390/−0 lines, 30 filesdep +basedep +bytestringdep +containerssetup-changed
Dependencies added: base, bytestring, containers, deepseq, directory, dlist, docvim, filepath, hlint, lens, mtl, optparse-applicative, parsec, pretty-show, process, split, tasty, tasty-golden, tasty-hunit, temporary
Files
- LICENSE.md +22/−0
- README.md +227/−0
- Setup.hs +2/−0
- docvim.cabal +151/−0
- lib/Docvim/AST.hs +157/−0
- lib/Docvim/CLI.hs +52/−0
- lib/Docvim/Compile.hs +51/−0
- lib/Docvim/Options.hs +58/−0
- lib/Docvim/Parse.hs +498/−0
- lib/Docvim/Printer/Markdown.hs +150/−0
- lib/Docvim/Printer/Vim.hs +307/−0
- lib/Docvim/ReadDir.hs +20/−0
- lib/Docvim/Util.hs +64/−0
- lib/Docvim/Visitor.hs +55/−0
- lib/Docvim/Visitor/Command.hs +16/−0
- lib/Docvim/Visitor/Commands.hs +19/−0
- lib/Docvim/Visitor/Footer.hs +19/−0
- lib/Docvim/Visitor/Function.hs +22/−0
- lib/Docvim/Visitor/Functions.hs +19/−0
- lib/Docvim/Visitor/Heading.hs +31/−0
- lib/Docvim/Visitor/Mapping.hs +16/−0
- lib/Docvim/Visitor/Mappings.hs +20/−0
- lib/Docvim/Visitor/Option.hs +16/−0
- lib/Docvim/Visitor/Options.hs +19/−0
- lib/Docvim/Visitor/Plugin.hs +37/−0
- lib/Docvim/Visitor/Section.hs +103/−0
- lib/Docvim/Visitor/Symbol.hs +49/−0
- src/Main.hs +8/−0
- tests/HLint.hs +9/−0
- tests/Tasty.hs +173/−0
+ LICENSE.md view
@@ -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.
+ README.md view
@@ -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)+ ```++ + (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)++<html> (we don't want ambiguity with things like <leader> 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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ docvim.cabal view
@@ -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
+ lib/Docvim/AST.hs view
@@ -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
+ lib/Docvim/CLI.hs view
@@ -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 ()
+ lib/Docvim/Compile.hs view
@@ -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+ ]
+ lib/Docvim/Options.hs view
@@ -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" )
+ lib/Docvim/Parse.hs view
@@ -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) <?> "<br />"+ where+ htmlTag = string' "<br>"+ xhtmlTag = string' "<br" >> 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
+ lib/Docvim/Printer/Markdown.hs view
@@ -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 "<br />\n" (custom, context-aware separator; see Vim.hs)+ BreakTag -> return "<br />"+ 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 <strong>+ then "<strong>[`" ++ l ++ "`](" ++ gitHubAnchor l ++ ")</strong>"+ else "<strong>`" ++ l ++ "`</strong>" -- 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 = "<p align=\"right\">"+ ++ unwords (map linkify $ sort ls)+ ++ "</p>"+ ++ "\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 `<code>`/`</code>` tags.+-- TODO: remember why I'm not using backticks here.+codify :: String -> String+codify s = "<code>" ++ s ++ "</code>"++a :: Anchor -> String+a (Anchor attributes target) = "<a" ++ attrs ++ ">" ++ target ++ "</a>"+ 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 ++ "`"
+ lib/Docvim/Printer/Vim.hs view
@@ -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
+ lib/Docvim/ReadDir.hs view
@@ -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)
+ lib/Docvim/Util.hs view
@@ -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
+ lib/Docvim/Visitor.hs view
@@ -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
+ lib/Docvim/Visitor/Command.hs view
@@ -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
+ lib/Docvim/Visitor/Commands.hs view
@@ -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
@@ -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
+ lib/Docvim/Visitor/Function.hs view
@@ -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
+ lib/Docvim/Visitor/Functions.hs view
@@ -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
+ lib/Docvim/Visitor/Heading.hs view
@@ -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
+ lib/Docvim/Visitor/Mapping.hs view
@@ -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
+ lib/Docvim/Visitor/Mappings.hs view
@@ -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
+ lib/Docvim/Visitor/Option.hs view
@@ -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
+ lib/Docvim/Visitor/Options.hs view
@@ -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
+ lib/Docvim/Visitor/Plugin.hs view
@@ -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
+ lib/Docvim/Visitor/Section.hs view
@@ -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
+ lib/Docvim/Visitor/Symbol.hs view
@@ -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
+ src/Main.hs view
@@ -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
+ tests/HLint.hs view
@@ -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
+ tests/Tasty.hs view
@@ -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+ ]