docvim 0.2.0.0 → 0.3.0.0
raw patch · 52 files changed
+1983/−1877 lines, 52 files
Files
- README.md +25/−1
- docvim.cabal +53/−25
- lib/Docvim/AST.hs +0/−157
- lib/Docvim/CLI.hs +0/−52
- lib/Docvim/Compile.hs +0/−51
- lib/Docvim/Options.hs +0/−58
- lib/Docvim/Parse.hs +0/−498
- lib/Docvim/Printer/Markdown.hs +0/−150
- lib/Docvim/Printer/Vim.hs +0/−307
- lib/Docvim/ReadDir.hs +0/−20
- lib/Docvim/Util.hs +0/−64
- lib/Docvim/Visitor.hs +0/−55
- lib/Docvim/Visitor/Command.hs +0/−16
- lib/Docvim/Visitor/Commands.hs +0/−19
- lib/Docvim/Visitor/Footer.hs +0/−19
- lib/Docvim/Visitor/Function.hs +0/−22
- lib/Docvim/Visitor/Functions.hs +0/−19
- lib/Docvim/Visitor/Heading.hs +0/−31
- lib/Docvim/Visitor/Mapping.hs +0/−16
- lib/Docvim/Visitor/Mappings.hs +0/−20
- lib/Docvim/Visitor/Option.hs +0/−16
- lib/Docvim/Visitor/Options.hs +0/−19
- lib/Docvim/Visitor/Plugin.hs +0/−37
- lib/Docvim/Visitor/Section.hs +0/−103
- lib/Docvim/Visitor/Symbol.hs +0/−49
- lib/Text/Docvim/AST.hs +160/−0
- lib/Text/Docvim/CLI.hs +54/−0
- lib/Text/Docvim/Compile.hs +44/−0
- lib/Text/Docvim/Optimize.hs +35/−0
- lib/Text/Docvim/Options.hs +58/−0
- lib/Text/Docvim/Parse.hs +487/−0
- lib/Text/Docvim/Printer/Markdown.hs +160/−0
- lib/Text/Docvim/Printer/Vim.hs +307/−0
- lib/Text/Docvim/ReadDir.hs +20/−0
- lib/Text/Docvim/Util.hs +69/−0
- lib/Text/Docvim/Visitor.hs +55/−0
- lib/Text/Docvim/Visitor/Command.hs +16/−0
- lib/Text/Docvim/Visitor/Commands.hs +19/−0
- lib/Text/Docvim/Visitor/Footer.hs +19/−0
- lib/Text/Docvim/Visitor/Function.hs +22/−0
- lib/Text/Docvim/Visitor/Functions.hs +19/−0
- lib/Text/Docvim/Visitor/Heading.hs +29/−0
- lib/Text/Docvim/Visitor/Mapping.hs +16/−0
- lib/Text/Docvim/Visitor/Mappings.hs +20/−0
- lib/Text/Docvim/Visitor/Option.hs +16/−0
- lib/Text/Docvim/Visitor/Options.hs +19/−0
- lib/Text/Docvim/Visitor/Plugin.hs +37/−0
- lib/Text/Docvim/Visitor/Section.hs +103/−0
- lib/Text/Docvim/Visitor/Symbol.hs +45/−0
- src/Main.hs +1/−1
- tests/HLint.hs +2/−2
- tests/Tasty.hs +73/−50
README.md view
@@ -31,6 +31,12 @@ -v,--verbose Be verbose during processing ``` +## Installation++```+cabal install docvim+```+ ## Syntax ```vim@@ -79,13 +85,16 @@ ### Annotations - `@command`+- `@commands` - `@dedent` - `@footer` - `@function`+- `@functions` - `@indent` - `@mapping` - `@mappings` - `@option`+- `@options` - `@plugin` ## Development@@ -141,7 +150,7 @@ # Cabal: cabal repl-> import Docvim.Parse+> import Text.Docvim.Parse > pp "let l:test=1" -- pretty-prints AST ``` @@ -201,6 +210,21 @@ hlint src # If you have HLint installed under $PATH. ```++### Release process++```bash+vim docvim.cabal # update version number in two places+git commit -p # git tag, git push --follow-tags etc...+cabal check+cabal sdist+open dist # upload candidate to https://hackage.haskell.org/packages/candidates/upload+cabal upload dist/docvim-$VERSION.tar.gz+```++## Links++- [Hackage package](https://hackage.haskell.org/package/docvim) ## FAQ
docvim.cabal view
@@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.2.0.0+version: 0.3.0.0 -- A short (one-line) description of the package. synopsis: Documentation generator for Vim plug-ins@@ -55,7 +55,7 @@ source-repository this type: git location: https://github.com/wincent/docvim.git- tag: 0.2.0.0+ tag: 0.3.0.0 executable docvim -- .hs or .lhs file containing the Main module.@@ -71,6 +71,8 @@ build-depends: base >=4.8 && <4.9 , docvim + ghc-options: -W -Wall+ -- Directories containing source files. hs-source-dirs: src @@ -92,36 +94,39 @@ , 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+ exposed-modules: Text.Docvim.AST+ , Text.Docvim.CLI+ , Text.Docvim.Compile+ , Text.Docvim.Optimize+ , Text.Docvim.Options+ , Text.Docvim.Parse+ , Text.Docvim.Printer.Markdown+ , Text.Docvim.Printer.Vim+ , Text.Docvim.ReadDir+ , Text.Docvim.Util+ , Text.Docvim.Visitor+ , Text.Docvim.Visitor.Command+ , Text.Docvim.Visitor.Commands+ , Text.Docvim.Visitor.Footer+ , Text.Docvim.Visitor.Function+ , Text.Docvim.Visitor.Functions+ , Text.Docvim.Visitor.Heading+ , Text.Docvim.Visitor.Mapping+ , Text.Docvim.Visitor.Mappings+ , Text.Docvim.Visitor.Option+ , Text.Docvim.Visitor.Options+ , Text.Docvim.Visitor.Plugin+ , Text.Docvim.Visitor.Section+ , Text.Docvim.Visitor.Symbol , Paths_docvim+ ghc-options: -W -Wall hs-source-dirs: lib test-suite hlint build-depends: base , hlint default-language: Haskell2010+ ghc-options: -W -Wall hs-source-dirs: tests main-is: HLint.hs type: exitcode-stdio-1.0@@ -131,6 +136,7 @@ , bytestring , containers , deepseq+ , directory , dlist , docvim , filepath@@ -144,7 +150,29 @@ , tasty-golden , tasty-hunit , temporary+ other-modules: Text.Docvim.AST+ , Text.Docvim.Compile+ , Text.Docvim.Optimize+ , Text.Docvim.Parse+ , Text.Docvim.Printer.Markdown+ , Text.Docvim.Printer.Vim+ , Text.Docvim.Util+ , Text.Docvim.Visitor+ , Text.Docvim.Visitor.Command+ , Text.Docvim.Visitor.Commands+ , Text.Docvim.Visitor.Footer+ , Text.Docvim.Visitor.Function+ , Text.Docvim.Visitor.Functions+ , Text.Docvim.Visitor.Heading+ , Text.Docvim.Visitor.Mapping+ , Text.Docvim.Visitor.Mappings+ , Text.Docvim.Visitor.Option+ , Text.Docvim.Visitor.Options+ , Text.Docvim.Visitor.Plugin+ , Text.Docvim.Visitor.Section+ , Text.Docvim.Visitor.Symbol default-language: Haskell2010+ ghc-options: -W -Wall hs-source-dirs: tests , lib main-is: Tasty.hs
− lib/Docvim/AST.hs
@@ -1,157 +0,0 @@-{-# 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
@@ -1,52 +0,0 @@-{-# 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
@@ -1,51 +0,0 @@-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
@@ -1,58 +0,0 @@--- | 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
@@ -1,498 +0,0 @@-{-# 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
@@ -1,150 +0,0 @@-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
@@ -1,307 +0,0 @@-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
@@ -1,20 +0,0 @@--- | 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
@@ -1,64 +0,0 @@--- | 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
@@ -1,55 +0,0 @@-{-# 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
@@ -1,16 +0,0 @@-{-# 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
@@ -1,19 +0,0 @@-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
@@ -1,19 +0,0 @@-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
@@ -1,22 +0,0 @@-{-# 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
@@ -1,19 +0,0 @@-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
@@ -1,31 +0,0 @@-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
@@ -1,16 +0,0 @@-{-# 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
@@ -1,20 +0,0 @@-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
@@ -1,16 +0,0 @@-{-# 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
@@ -1,19 +0,0 @@-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
@@ -1,37 +0,0 @@-{-# 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
@@ -1,103 +0,0 @@-{-# 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
@@ -1,49 +0,0 @@-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
+ lib/Text/Docvim/AST.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RankNTypes #-}++module Text.Docvim.AST where++import Control.Lens.Fold+import Control.Lens.Getter+import Control.Lens.Plated+import Data.Char+import Data.Data+import Data.Data.Lens+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++invalidNode :: forall t. t+invalidNode = error "Invalid Node type"
+ lib/Text/Docvim/CLI.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE MultiWayIf #-}++-- | The runnable part of the docvim executable.+module Text.Docvim.CLI (run) where++import Control.Monad+import Data.Maybe+import System.FilePath hiding (hasExtension)+import System.IO+import Text.Docvim.Compile+import Text.Docvim.Options+import Text.Docvim.Parse+import Text.Docvim.Printer.Markdown+import Text.Docvim.Printer.Vim+import Text.Docvim.ReadDir+import Text.Show.Pretty++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+ when (debug opts) (hPutStrLn stderr ("Compiled:\n" ++ ppShow project))+ 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/Text/Docvim/Compile.hs view
@@ -0,0 +1,44 @@+module Text.Docvim.Compile (compile) where++import Text.Docvim.AST+import Text.Docvim.Optimize+import Text.Docvim.Visitor+import Text.Docvim.Visitor.Command+import Text.Docvim.Visitor.Commands+import Text.Docvim.Visitor.Footer+import Text.Docvim.Visitor.Function+import Text.Docvim.Visitor.Functions+import Text.Docvim.Visitor.Heading+import Text.Docvim.Visitor.Mapping+import Text.Docvim.Visitor.Mappings+import Text.Docvim.Visitor.Option+import Text.Docvim.Visitor.Options+import Text.Docvim.Visitor.Plugin+import Text.Docvim.Visitor.Section++-- | "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 steps = [ extract extractPlugin+ , extract extractCommands+ , extract extractCommand+ , extract extractMappings+ , extract extractMapping+ , extract extractOptions+ , extract extractOption+ , extract extractFunctions+ , extract extractFunction+ , extract extractFooter+ ]+ let (remainder, sections) = foldl reduce (ast, []) steps+ let (beginning, rest) = splitAt 1 sections+ optimize $ injectTOC $ Project $ (concat . concat) [beginning, [[remainder]], rest]+ where+ reduce (remainder', sections') step = do+ let (r', s') = step remainder'+ (r', sections' ++ [s'])
+ lib/Text/Docvim/Optimize.hs view
@@ -0,0 +1,35 @@+module Text.Docvim.Optimize (optimize) where++import Control.Lens hiding (Empty)+import Text.Docvim.AST++-- | "Optimize" a Project's AST by eliminating empty paths.+optimize :: Node -> Node+optimize = transform prune++-- | Marks a node for pruning by returning Empty if it has no non-Empty+-- children.+prune :: Node -> Node+prune n | not (null (children n)) = checkChildren+ | container n = Empty+ | otherwise = n+ where+ checkChildren | all empty (children n) = Empty+ | any empty (children n) = filterChildren n+ | otherwise = n+ filterChildren (Project cs) = Project $ filter (not . empty) cs+ filterChildren (Unit cs) = Unit $ filter (not . empty) cs+ filterChildren (DocBlock cs) = DocBlock $ filter (not . empty) cs+ filterChildren _ = n++-- | Returns True if the supplied node is the Empty node.+empty :: Node -> Bool+empty Empty = True+empty _ = False++-- | Returns True if the supplied node is a (potentially) prunable container.+container :: Node -> Bool+container (Project _) = True+container (Unit _) = True+container (DocBlock _) = True+container _ = False
+ lib/Text/Docvim/Options.hs view
@@ -0,0 +1,58 @@+-- | Options parser for the docvim executable.+module Text.Docvim.Options (Options(..), options) where++import Options.Applicative+import Data.Version+import qualified Paths_docvim++-- 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/Text/Docvim/Parse.hs view
@@ -0,0 +1,487 @@+{-# LANGUAGE FlexibleContexts #-}++module Text.Docvim.Parse ( parse+ , rstrip+ , strip+ , unit+ ) where++import Control.Applicative hiding ((<|>), many, optional)+import Data.Char+import Data.List (groupBy, intercalate)+import System.Exit+import System.IO+import Text.Docvim.AST+import Text.Parsec hiding (newline, parse)+import Text.Parsec.String++-- | 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 :: String -> Parser ()+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)+ remainder [] = error "Unexpected empty remainder"++function :: Parser Node+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 :: Parser ()+endfunction = lookAhead (string "endf" >> notFollowedBy (string "o"))+ >> command "endf[unction]"+ <* eos++lStatement :: Parser Node+lStatement = lookAhead (char 'l')+ >> choice [ try (lookAhead (string "lw")) >> lwindow+ , try (lookAhead (string "let")) >> letStatement+ , lexpr+ ]++lwindow :: Parser Node+lwindow = LwindowStatement <$> (lw *> height <* eos)+ where+ lw = command "l[window]"+ height = optionMaybe (wsc *> number)+ number = liftA read (many1 digit)++lexpr :: Parser Node+lexpr = LexprStatement+ <$> (command "lex[pr]" *> bang <* wsc)+ <*> restOfLine++-- "let" is a reserved word in Haskell, so we call this "letStatement" instead.+letStatement :: Parser Node+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 :: Parser Node+unlet = UnletStatement+ <$> (unl *> bang <* wsc)+ <*> word+ <* eos+ where+ unl = command "unl[et]"++quote :: Parser String+quote = string "\"" <?> "quote"++commentStart :: Parser String+commentStart = quote <* (notFollowedBy quote >> optional ws)++docBlockStart :: Parser String+docBlockStart = (string "\"\"" <* optional ws) <?> "\"\""++separator :: Parser Node+separator = Separator <$ (try (string "---") >> optional ws) <?> "wat"++fenced :: Parser Node+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 :: Parser Node+blockquote = lookAhead (char '>')+ >> Blockquote+ <$> paragraph' `sepBy1` blankLine+ where+ paragraph' = Paragraph <$> body+ body = paragraphBody firstLine otherLine+ 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 :: Parser Node+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 :: Parser Node+listItem = lookAhead (char '-' >> notFollowedBy (char '-'))+ >> ListItem+ <$> body+ where+ body = paragraphBody firstLine otherLine+ firstLine = char '-' >> optional ws >> many1 (choice [phrasing, whitespace])+ 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 :: Parser ()+newline = (char '\n' >> optional ws) <|> eof++newlines :: Parser [()]+newlines = many1 (char '\n' >> optional ws)+ <|> (eof >> return [()])++-- | Whitespace (specifically, horizontal whitespace: spaces and tabs).+ws :: Parser String+ws = many1 (oneOf " \t")++-- | Continuation-aware whitespace (\).+wsc :: Parser String+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 :: Parser ()+comment = try+ $ quote+ >> notFollowedBy quote+ >> restOfLine+ >> skipMany (char '\n' >> optional ws)++-- | Optional bang suffix for VimL commands.+bang :: Parser Bool+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 :: Parser ()+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 :: Parser Node+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 :: Parser Node+paragraph = Paragraph <$> body+ where+ body = paragraphBody firstLine otherLine+ firstLine = many1 $ choice [phrasing, whitespace]+ otherLine = try $ newline+ >> (commentStart <|> docBlockStart)+ >> optional ws+ >> notFollowedBy special+ >> firstLine++paragraphBody :: Parser [Node] -> Parser [Node] -> Parser [Node]+paragraphBody firstLine otherLine = 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 )++-- | 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 :: Parser Node+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 :: Parser Node+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' :: Char -> Parser Char+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' :: String -> Parser String+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 :: Parser Node+whitespace = Whitespace <$ ws++br :: Parser Node+br = BreakTag <$ (try htmlTag <|> try xhtmlTag) <?> "<br />"+ where+ htmlTag = string' "<br>"+ xhtmlTag = string' "<br" >> optional ws >> string "/>"++link :: Parser Node+link = Link <$> (bar *> linkText <* bar)+ where+ bar = char '|'+ linkText = many1 $ noneOf " \t\n|"++code :: Parser Node+code = Code <$> (backtick *> codeText <* backtick)+ where+ backtick = char '`'+ codeText = many $ noneOf "\n`"++linkTargets :: Parser Node+linkTargets = LinkTargets <$> many1 (star *> target <* (star >> optional ws))+ where+ star = char '*'+ target = many1 $ noneOf " \t\n*"++vimL :: Parser Node+vimL = choice [ block+ , statement+ ]++block :: Parser Node+block = choice [ function ]++statement :: Parser Node+statement = choice [ lStatement+ , unlet+ , genericStatement+ ]++-- | Generic VimL node parser to represent stuff that we haven't built out full parsing+-- for yet.+genericStatement :: Parser Node+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 :: String -> String+strip = lstrip . rstrip++-- | Strip leading (left) whitespace.+lstrip :: String -> String+lstrip = dropWhile (`elem` " \n\t")++-- | Strip trailing (right) whitespace.+rstrip :: String -> String+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 :: Parser String+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 :: Parser [()]+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/Text/Docvim/Printer/Markdown.hs view
@@ -0,0 +1,160 @@+module Text.Docvim.Printer.Markdown (markdown) where++import Control.Monad.Reader+import Data.List+import Data.Maybe+import Text.Docvim.AST+import Text.Docvim.Parse+import Text.Docvim.Visitor.Plugin+import Text.Docvim.Visitor.Symbol++data Metadata = Metadata { pluginName :: Maybe String+ , symbols :: [String]+ }+type Env = Reader Metadata String++data Anchor = Anchor [Attribute] String+data Attribute = Attribute String String++markdown :: Node -> String+markdown n = rstrip (runReader (node n) metadata) ++ "\n"+ where metadata = Metadata (getPluginName n) (getSymbols 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 {} -> command n+ CommandsAnnotation -> h2 "Commands"+ DocBlock d -> nodes d+ Fenced f -> return $ fenced f ++ "\n\n"+ FunctionDeclaration {} -> nodes $ functionBody n+ FunctionsAnnotation -> h2 "Functions"+ HeadingAnnotation h -> h2 h+ Link l -> link l+ LinkTargets l -> return $ linkTargets l+ List ls -> nodes ls >>= nl+ ListItem l -> fmap ("- " ++) (nodes l) >>= nl+ MappingAnnotation m -> mapping m+ MappingsAnnotation -> h2 "Mappings"+ OptionAnnotation {} -> option n+ OptionsAnnotation -> h2 "Options"+ 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 _ -> h1 name+ Project p -> nodes p+ Separator -> return $ "---" ++ "\n\n"+ SubheadingAnnotation s -> 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 -> Env+h1 = heading 1++h2 :: String -> Env+h2 = heading 2++h3 :: String -> Env+h3 = heading 3++heading :: Int -> String -> Env+heading level string = do+ metadata <- ask+ return $ replicate level '#' ++ " " ++ string ++ anch (pluginName metadata) ++ "\n\n"+ where+ anch name = a $ Anchor [ Attribute "name" (sanitizeAnchor $ pre ++ string)+ , Attribute "href" (gitHubAnchor $ pre ++ string)+ ]+ ""+ where+ pre = maybe "" (++ "-") name++-- | 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 -> Env+option (OptionAnnotation n t d) = do+ h <- h3 $ "`" ++ n ++ "` (" ++ t ++ ", default: " ++ def ++ ")"+ return $ targets ++ h+ where targets = linkTargets [n]+ def = fromMaybe "none" d+option _ = invalidNode++command :: Node -> Env+command (CommandAnnotation name params) = do+ content <- h3 $ "`:" ++ annotation ++ "`"+ return $ target ++ content+ where target = linkTargets [":" ++ name]+ annotation = rstrip $ name ++ " " ++ fromMaybe "" params+command _ = invalidNode++mapping :: String -> Env+mapping name = h3 $ "`" ++ name ++ "`"
+ lib/Text/Docvim/Printer/Vim.hs view
@@ -0,0 +1,307 @@+{-# LANGUAGE MultiWayIf #-}++module Text.Docvim.Printer.Vim (vimHelp) where++import Control.Arrow+import Control.Monad+import Control.Monad.Reader+import Control.Monad.State+import Data.Char+import Data.List+import Data.List.Split+import Data.Maybe+import Data.Tuple+import Text.Docvim.AST+import Text.Docvim.Parse+import Text.Docvim.Visitor.Plugin++-- 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 { 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 (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+ end l = reverse $ takeWhile (/= '\n') (reverse l)++-- http://stackoverflow.com/a/9723976/2103996+mapTuple :: (b -> c) -> (b, b) -> (c, c)+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 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 ""++plugin :: String -> String -> Env+plugin name desc = appendNoWrap $+ center filename desc (target normalized) " " " " ++ "\n\n"+ where+ filename = "*" ++ normalized ++ ".txt*"+ normalized = map toLower name+ center a b c s1 s2 =+ if | renderedWidth str >= textwidth -> str+ | odd $ renderedWidth str -> center a b c (s1 ++ " ") s2+ | otherwise -> center a b c s1 (s2 ++ " ")+ where+ str = a ++ s1 ++ b ++ s2 ++ c++-- | Append a newline.+nl :: [Operation] -> Env+nl os = liftM2 (++) (return os) (append "\n")++breaktag :: Env+breaktag = do+ context <- get+ append $ lineBreak context++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 :: Integer)..] 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+command _ = invalidNode++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"+option _ = invalidNode++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 ++ " "+ targ <- maybe (append "\n") (\x -> linkTargets [target' x] False) (pluginName metadata)+ trailing <- append "\n"+ return $ concat [heading', targ, 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 ++ "|"++target :: String -> String+target t = "*" ++ t ++ "*"++-- 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/Text/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 Text.Docvim.ReadDir (readDir) where++import Control.Monad+import System.Directory+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/Text/Docvim/Util.hs view
@@ -0,0 +1,69 @@+-- | Functions to facilitate automated and manual testing.+module Text.Docvim.Util ( compileUnits+ , p+ , parseUnit+ , pm+ , pp+ , ppm+ , ppv+ , pv+ ) where++import Text.Docvim.AST+import Text.Docvim.Compile+import Text.Docvim.Parse+import Text.Docvim.Printer.Markdown+import Text.Docvim.Printer.Vim+import Text.Parsec+import Text.Show.Pretty++-- | Parse a string containing a translation unit.+parseUnit :: String -> Either ParseError Node+parseUnit = runParser unit () "(eval)"++-- | Parse and compile a list of strings containing a translation units.+compileUnits :: [String] -> Either ParseError Node+compileUnits inputs = do+ parsed <- mapM parseUnit inputs+ return $ compile parsed++-- | Convenience function: Parse and compile a list of strings containing+-- translation units, but always returns a string even in the case of an error.+p :: [String] -> String+p inputs = case compileUnits inputs of+ Left err -> show err+ 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 input = putStrLn $ p [input]++-- | Parse and compile a list of input strings into Vim help format.+pv :: [String] -> String+pv inputs = case compileUnits inputs of+ Left err -> show err+ 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 input = putStr $ pv [input]++-- | Parse and compile a list of input strings into Markdown help format.+pm :: [String] -> String+pm inputs = case compileUnits inputs of+ Left err -> show err+ 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 input = putStr $ pm [input]
+ lib/Text/Docvim/Visitor.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleContexts #-}++module Text.Docvim.Visitor (endSection, extract, extractBlocks) where++import Control.Applicative+import Control.Monad+import Control.Monad.Writer+import Data.Data.Lens+import Text.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 noExtract extract' (start x)+ where+ noExtract = (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/Text/Docvim/Visitor/Command.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE LambdaCase #-}++module Text.Docvim.Visitor.Command (extractCommand) where++import Control.Applicative+import Text.Docvim.AST+import Text.Docvim.Visitor++-- | 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/Text/Docvim/Visitor/Commands.hs view
@@ -0,0 +1,19 @@+module Text.Docvim.Visitor.Commands (extractCommands) where++import Control.Applicative+import Text.Docvim.AST+import Text.Docvim.Visitor++-- | 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 Text.Docvim.Visitor.Footer (extractFooter) where++import Control.Applicative+import Text.Docvim.AST+import Text.Docvim.Visitor++-- | 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/Text/Docvim/Visitor/Function.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE LambdaCase #-}++module Text.Docvim.Visitor.Function (extractFunction) where++import Control.Applicative+import Text.Docvim.AST+import Text.Docvim.Visitor++-- | 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/Text/Docvim/Visitor/Functions.hs view
@@ -0,0 +1,19 @@+module Text.Docvim.Visitor.Functions (extractFunctions) where++import Control.Applicative+import Text.Docvim.AST+import Text.Docvim.Visitor++-- | 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/Text/Docvim/Visitor/Heading.hs view
@@ -0,0 +1,29 @@+module Text.Docvim.Visitor.Heading ( getHeadings+ , injectTOC+ ) where++import Control.Lens+import Text.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/Text/Docvim/Visitor/Mapping.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE LambdaCase #-}++module Text.Docvim.Visitor.Mapping (extractMapping) where++import Control.Applicative+import Text.Docvim.AST+import Text.Docvim.Visitor++-- | 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/Text/Docvim/Visitor/Mappings.hs view
@@ -0,0 +1,20 @@+module Text.Docvim.Visitor.Mappings (extractMappings) where++import Control.Applicative+import Text.Docvim.AST+import Text.Docvim.Visitor++-- | 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/Text/Docvim/Visitor/Option.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE LambdaCase #-}++module Text.Docvim.Visitor.Option (extractOption) where++import Control.Applicative+import Text.Docvim.AST+import Text.Docvim.Visitor++-- | 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/Text/Docvim/Visitor/Options.hs view
@@ -0,0 +1,19 @@+module Text.Docvim.Visitor.Options (extractOptions) where++import Control.Applicative+import Text.Docvim.AST+import Text.Docvim.Visitor++-- | 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/Text/Docvim/Visitor/Plugin.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE LambdaCase #-}++module Text.Docvim.Visitor.Plugin ( getPluginName+ , extractPlugin+ ) where++import Control.Applicative+import Text.Docvim.AST+import Text.Docvim.Visitor++-- | 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/Text/Docvim/Visitor/Section.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TemplateHaskell #-}++module Text.Docvim.Visitor.Section ( injectCommands+ , injectFunctions+ , injectMappings+ , injectOptions+ ) where++import Control.Lens+import Control.Monad.State+import Data.Data.Lens+import Text.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, wrapped in a DocBlock, to the end of a Project.+inject :: Node -> Node -> Node+inject (Project ns) n = Project $ ns ++ [DocBlock [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/Text/Docvim/Visitor/Symbol.hs view
@@ -0,0 +1,45 @@+module Text.Docvim.Visitor.Symbol (getSymbols) where++import Data.List+import Text.Docvim.AST+import Text.Docvim.Visitor.Plugin+import qualified Data.Set as Set++-- 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 [_] = []+ f (x:xs) = if x == head xs+ then x : f xs+ else f xs
src/Main.hs view
@@ -1,7 +1,7 @@ -- | The docvim executable. module Main (main) where -import Docvim.CLI (run)+import Text.Docvim.CLI -- | Run the executable using the supplied options. main :: IO ()
tests/HLint.hs view
@@ -1,7 +1,7 @@ module Main (main) where -import Language.Haskell.HLint (hlint)-import System.Exit (exitFailure, exitSuccess)+import Language.Haskell.HLint+import System.Exit main :: IO () main = do
tests/Tasty.hs view
@@ -1,43 +1,38 @@+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+ 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 Control.DeepSeq+import Control.Exception hiding (assert) 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 Data.Char+import Data.List --(isPrefixOf, sort)+import Data.Monoid+import System.Directory+import System.Exit+import System.FilePath+import System.IO+import System.IO.Temp+import System.Process+import Test.Tasty+import Test.Tasty.Golden+import Test.Tasty.Golden.Advanced import Test.Tasty.HUnit+import Text.Docvim.AST+import Text.Docvim.Util+import Text.Docvim.Visitor.Symbol+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Lazy as LazyByteString -- | 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 "Compile empty unit" $ assert $ parseSuccess (compileUnits [""])+ , testCase "Compile whitespace-only unit" $ assert $ parseSuccess (compileUnits [" \n "]) , testCase "Counting all nodes" $ 7 @=? let@@ -95,27 +90,47 @@ in symbols ] -goldenTests :: String -> [FilePath] -> (String -> String) -> TestTree+diff :: String -> String -> [String]+diff ref new = [ "git"+ , "diff"+ , "--color"+ , "--diff-algorithm=histogram"+ , ref+ , new+ ]++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+ 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"+ return $ goldenVsStringDiff' name diff golden run where groupName = "Golden " ++ description ++ " tests" +integrationTests :: [FilePath] -> TestTree+integrationTests sources = testGroup "Integration tests" $+ concat [ run "ast" (p)+ , run "markdown" (pm)+ , run "plaintext" (pv)+ ]+ where+ run kind process = do+ source <- sources -- list monad+ let+ output = do+ inputs <- getFixtures $ source </> "input"+ contents <- mapM readFile inputs+ return $ pack $ normalize $ process contents+ name = takeBaseName source+ golden = "tests/fixtures/integration" </> (takeBaseName source) </> "golden/" ++ kind ++ ".golden"+ return $ goldenVsStringDiff' (name ++ " (" ++ kind ++ ")") diff golden output+ -- | Normalize a string to always end with a newline, unless zero-length, to -- match standard text editor behavior. normalize :: String -> String@@ -134,20 +149,20 @@ -- - 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 =+goldenVsStringDiff' name diff' golden run = goldenTest name (ByteString.readFile golden) (LazyByteString.toStrict <$> run)- compare+ cmp 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+ cmp _ actBS = withSystemTempFile template $ \tmpFile tmpHandle -> do ByteString.hPut tmpHandle actBS >> hFlush tmpHandle- let cmd = diff golden tmpFile+ let cmd = diff' golden tmpFile (_, Just sout, _, pid) <- createProcess (proc (head cmd) (tail cmd)) { std_out = CreatePipe } out <- LazyByteString.hGetContents sout evaluate . rnf $ out@@ -157,17 +172,25 @@ _ -> Just (strip out) update = ByteString.writeFile golden -getFixtures :: String -> IO [FilePath]+getFixtures :: FilePath -> IO [FilePath] getFixtures = findByExtension [".vim"] +getIntegrationFixtures :: FilePath -> IO [FilePath]+getIntegrationFixtures path = do+ names <- getDirectoryContents path+ let filtered = filter (\name -> not $ "." `isPrefixOf` name) names+ return $ map (\name -> path </> name) filtered+ main :: IO () main = do parserSources <- getFixtures "tests/fixtures/parser" markdownSources <- getFixtures "tests/fixtures/markdown" vimHelpSources <- getFixtures "tests/fixtures/vim"+ integrationSources <- getIntegrationFixtures "tests/fixtures/integration" defaultMain $ testGroup "Test suite" [ unitTests , goldenTests "parser" parserSources p , goldenTests "Markdown printer" markdownSources pm , goldenTests "Vim help printer" vimHelpSources pv+ , integrationTests integrationSources ]