]> git.wincent.com - docvim.git/blob - lib/Text/Docvim/Printer/Vim.hs
Tweak function and command output in Vim help printer to stand out more
[docvim.git] / lib / Text / Docvim / Printer / Vim.hs
1 {-# LANGUAGE CPP #-}
2 {-# LANGUAGE MultiWayIf #-}
3
4 module Text.Docvim.Printer.Vim (vimHelp) where
5
6 #if !MIN_VERSION_base(4,8,0)
7 import Control.Applicative ((<$>))
8 #endif
9 import Control.Arrow
10 import Control.Monad
11 import Control.Monad.Reader
12 import Control.Monad.State
13 import Data.Char
14 import Data.List
15 import Data.List.Split
16 import Data.Maybe
17 import Data.Tuple
18 import Text.Docvim.AST
19 import Text.Docvim.Parse
20 import Text.Docvim.Visitor.Plugin
21
22 -- TODO: add indentation here (using local, or just stick it in Context)
23
24 -- Instead of building up a [Char], we build up a list of operations, which
25 -- allows us a mechanism of implementing rollback and therefore hard-wrapping
26 -- (eg. append whitespace " ", then on next node, realize that we will exceed
27 -- line length limit, so rollback the " " and instead append "\n" etc).
28 data Operation = Append String
29                | Delete Int -- unconditional delete count of Char
30                | Slurp String -- delete string if present
31 data Metadata = Metadata { pluginName :: Maybe String }
32 data Context = Context { lineBreak :: String
33                        , partialLine :: String
34                        }
35 type Env = ReaderT Metadata (State Context) [Operation]
36
37 textwidth :: Int
38 textwidth = 78
39
40 vimHelp :: Node -> String
41 vimHelp n = if null suppressTrailingWhitespace
42             then ""
43             else suppressTrailingWhitespace ++ "\n"
44   where metadata = Metadata (getPluginName n)
45         context = Context defaultLineBreak ""
46         operations = evalState (runReaderT (node n) metadata) context
47         output = foldl reduce "" operations
48         reduce acc (Append atom) = acc ++ atom
49         reduce acc (Delete count) = take (length acc - count) acc
50         reduce acc (Slurp atom) = if atom `isSuffixOf` acc
51                                   then take (length acc - length atom) acc
52                                   else acc
53         suppressTrailingWhitespace = rstrip $ intercalate "\n" (map rstrip (splitOn "\n" output))
54
55 -- | Helper function that appends and updates `partialLine` context,
56 -- hard-wrapping if necessary to remain under `textwidth`.
57 append :: String -> Env
58 append string = append' string textwidth
59
60 -- | Helper function that appends and updates `partialLine` context
61 -- uncontitionally (no hard-wrapping).
62 appendNoWrap :: String -> Env
63 appendNoWrap string = append' string (maxBound :: Int)
64
65 append' :: String -> Int -> Env
66 append' string width = do
67   context <- get
68   -- TODO obviously tidy this up
69   let (ops, line) = if renderedWidth (partialLine context) + renderedWidth leading >= width
70                     then ( [ Delete (length $ snd $ hardwrap $ partialLine context)
71                            , Slurp " "
72                            , Append (lineBreak context)
73                            , Append (snd $ hardwrap $ partialLine context)
74                            , Append string
75                            ]
76                          , lineBreak context ++ snd (hardwrap $ partialLine context) ++ string
77                          )
78                     else ([Append string], partialLine context ++ string)
79   put (Context (lineBreak context) (end line))
80   return ops
81   where
82     leading = takeWhile (/= '\n') string
83     end l = reverse $ takeWhile (/= '\n') (reverse l)
84
85 -- http://stackoverflow.com/a/9723976/2103996
86 mapTuple :: (b -> c) -> (b, b) -> (c, c)
87 mapTuple = join (***)
88
89 -- Given a string, hardwraps it into two parts by splitting it at the rightmost
90 -- whitespace.
91 hardwrap :: String -> (String, String)
92 hardwrap str = swap $ mapTuple reverse split'
93   where
94     split' = break isSpace (reverse str)
95
96 -- Helper function to conditionally remove a string if it appears at the end of
97 -- the output.
98 slurp :: String -> Env
99 slurp str = do
100   context <- get
101   put (Context (lineBreak context) (partial context))
102   return [Slurp str]
103   where
104     -- eg. (partialLine context) | str        | result
105     --     ----------------------|------------|-------
106     --     ""                    | "\n"       | ""
107     --     "foo"                 | "\n"       | "foo"
108     --     "foo"                 | "bar"      | "foo"
109     --     "abc"                 | "bc"       | "a"
110     --     "abc"                 | "foo\nabc" | ""
111     --
112     -- Note: That last one is unsafe, because we can't guarantee that "foo" is
113     -- there. Caveat emptor!
114     partial context = if str `isSuffixOf` partialLine context
115                       then take (length (partialLine context) - length str) (partialLine context)
116                       else partialLine context
117
118 defaultLineBreak :: String
119 defaultLineBreak = "\n"
120
121 nodes :: [Node] -> Env
122 nodes ns = concat <$> mapM node ns
123
124 node :: Node -> Env
125 node n = case n of
126   Blockquote b               -> blockquote b >>= nl >>= nl
127   BreakTag                   -> breaktag
128   Code c                     -> append $ "`" ++ c ++ "`"
129   CommandAnnotation {}       -> command n
130   CommandsAnnotation         -> heading "commands"
131   DocBlock d                 -> nodes d
132   Fenced f                   -> fenced f
133   FunctionAnnotation {}      -> function n
134   FunctionDeclaration {}     -> nodes $ functionBody n
135   FunctionsAnnotation        -> heading "functions"
136   HeadingAnnotation h        -> heading h
137   Link l                     -> append $ link l
138   LinkTargets l              -> linkTargets l True
139   List ls                    -> nodes ls >>= nl
140   ListItem l                 -> listitem l
141   MappingAnnotation m        -> mapping m
142   MappingsAnnotation         -> heading "mappings"
143   OptionAnnotation {}        -> option n
144   OptionsAnnotation          -> heading "options"
145   Paragraph p                -> nodes p >>= nl >>= nl
146   Plaintext p                -> plaintext p
147   PluginAnnotation name desc -> plugin name desc
148   Project p                  -> nodes p
149   Separator                  -> append $ "---" ++ "\n\n"
150   SubheadingAnnotation s     -> append $ s ++ " ~\n\n"
151   TOC t                      -> toc t
152   Unit u                     -> nodes u
153   Whitespace                 -> whitespace
154   _                          -> append ""
155
156 plugin :: String -> String -> Env
157 plugin name desc = appendNoWrap $
158     center filename desc (target normalized) " " " " ++ "\n\n"
159   where
160     filename = "*" ++ normalized ++ ".txt*"
161     normalized = map toLower name
162     center a b c s1 s2 =
163         if | renderedWidth str >= textwidth -> str
164            | odd $ renderedWidth str        -> center a b c (s1 ++ " ") s2
165            | otherwise                      -> center a b c s1 (s2 ++ " ")
166       where
167         str = a ++ s1 ++ b ++ s2 ++ c
168
169 -- | Append a newline.
170 nl :: [Operation] -> Env
171 nl os = liftM2 (++) (return os) (append "\n")
172
173 breaktag :: Env
174 breaktag = do
175   context <- get
176   append $ lineBreak context
177
178 listitem :: [Node] -> Env
179 listitem l = do
180   context <- get
181   -- TODO: consider using lenses to modify records
182   put (Context customLineBreak (partialLine context))
183   item <- liftM2 (++) (append "- ") (nodes l) >>= nl
184   put (Context defaultLineBreak (partialLine context))
185   return item
186   where
187     customLineBreak = "\n  "
188
189 toc :: [String] -> Env
190 toc t = do
191   metadata <- ask
192   toc' $ fromJust $ pluginName metadata
193   where
194     toc' p = do
195       h <- heading "contents"
196       entries <- append $ intercalate "\n" format ++ "\n\n"
197       return (h ++ entries)
198       where
199         format                = map pad numbered
200         longest               = maximum (map (length . snd) numbered )
201         numbered              = map prefix number
202         number                = zip3 [(1 :: Integer)..] t (map (\x -> normalize $ p ++ "-" ++ x) t)
203         prefix (num, desc, l) = (show num ++ ". " ++ desc ++ "  ", l)
204         pad (lhs, rhs)        = lhs ++ replicate (longest - length lhs) ' ' ++ link rhs
205   -- TODO: consider doing this for markdown format too
206
207 command :: Node -> Env
208 command (CommandAnnotation name params) = do
209   target' <- linkTargets [":" ++ name] False
210   lhs <- append $ concat [":", name, " ", fromMaybe "" params]
211   trailing <- append " ~\n\n"
212   return $ concat [target', lhs, trailing]
213 -- TODO indent what follows until next annotation...
214 -- will require us to hoist it up inside CommandAnnotation
215 -- (and do similar for other sections)
216 -- once that is done, drop the extra newline above
217 command _ = invalidNode
218
219 function :: Node -> Env
220 function (FunctionAnnotation name) = do
221   target' <- linkTargets [name ++ "()"] False
222   lhs <- append $ name ++ "()"
223   trailing <- append " ~\n\n"
224   return $ concat [target', lhs, trailing]
225 -- TODO indent what follows
226 function _ = invalidNode
227
228 mapping :: String -> Env
229 mapping name = linkTargets [name] True
230
231 option :: Node -> Env
232 option (OptionAnnotation n t d) = do
233   targets <- linkTargets [n] True
234   opt <- appendNoWrap $ link n
235   ws <- appendNoWrap " "
236   context <- get
237   meta <- appendNoWrap $ aligned context
238   return $ concat [targets, opt, ws, meta]
239   where
240     aligned context = rightAlign context rhs
241     rhs = t ++ " (default: " ++ fromMaybe "none" d ++ ")\n\n"
242 option _ = invalidNode
243
244 whitespace :: Env
245 whitespace = append " "
246
247 blockquote :: [Node] -> Env
248 blockquote ps = do
249   context <- get
250   put (Context customLineBreak (partialLine context))
251   ps' <- mapM paragraph ps
252   put (Context defaultLineBreak (partialLine context))
253   liftM2 (++) (append "    ") (liftM2 intercalate customParagraphBreak (return ps'))
254   where
255     -- Strip off trailing newlines from each paragraph.
256     paragraph p = fmap trim (node p)
257     trim contents = take (length contents - 2) contents
258     customLineBreak = "\n    "
259     customParagraphBreak = append "\n\n    "
260
261 plaintext :: String -> Env
262 plaintext = append
263
264 fenced :: [String] -> Env
265 fenced f = do
266   cut <- slurp "\n"
267   prefix <- append ">\n"
268   body <- if null f
269           then append ""
270           else appendNoWrap $ "    " ++ intercalate "\n    " f ++ "\n"
271   suffix <- append "<\n"
272   return $ concat [cut, prefix, body, suffix]
273
274 heading :: String -> Env
275 heading h = do
276   metadata <- ask
277   heading' <- appendNoWrap $ map toUpper h ++ " "
278   targ <- maybe (append "\n") (\x -> linkTargets [target' x] False) (pluginName metadata)
279   trailing <- append "\n"
280   return $ concat [heading', targ, trailing]
281   where
282     target' x = normalize $ x ++ "-" ++ h
283
284 normalize :: String -> String
285 normalize = map (toLower . sanitize)
286
287 sanitize :: Char -> Char
288 sanitize x = if isSpace x then '-' else x
289
290 link :: String -> String
291 link l = "|" ++ l ++ "|"
292
293 target :: String -> String
294 target t = "*" ++ t ++ "*"
295
296 -- TODO: be prepared to wrap these if there are a lot of them
297 -- TODO: fix code smell of passing in `wrap` bool here
298 linkTargets :: [String] -> Bool -> Env
299 linkTargets ls wrap = do
300   context <- get
301   if wrap
302   then append $ aligned context
303   else appendNoWrap $ aligned context
304   where
305     aligned context = rightAlign context (targets ++ "\n")
306     targets = unwords (map linkify $ sort ls)
307     linkify l = "*" ++ l ++ "*"
308
309 rightAlign :: Context -> String -> String
310 rightAlign context string = align (partialLine context)
311   where
312     align used = replicate (count used string) ' ' ++ string
313     count used xs = maximum [textwidth - renderedWidth xs - renderedWidth used, 0]
314
315 -- Crude approximation for calculating rendered width, that does so by not
316 -- counting the relatively rare |, *, ` and "\n" -- all of which usually get
317 -- concealed in the rendered output.
318 renderedWidth :: String -> Int
319 renderedWidth = foldr reduce 0
320   where reduce char acc = if char `elem` "\n|*`"
321                         then acc
322                         else acc + 1