]> git.wincent.com - docvim.git/blob - lib/Text/Docvim/Printer/Vim.hs
Add additional blank line above headings
[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   lhs <- append $ concat [":", name, " ", fromMaybe "" params]
210   ws <- append " "
211   target' <- linkTargets [":" ++ name] False
212   trailing <- append "\n"
213   return $ concat [lhs, ws, target', trailing]
214 -- TODO indent what follows until next annotation...
215 -- will require us to hoist it up inside CommandAnnotation
216 -- (and do similar for other sections)
217 -- once that is done, drop the extra newline above
218 command _ = invalidNode
219
220 function :: Node -> Env
221 function (FunctionAnnotation name) = do
222   lhs <- append $ name ++ "()"
223   ws <- append " "
224   target' <- linkTargets [name ++ "()"] False
225   trailing <- append "\n"
226   return $ concat [lhs, ws, target', trailing]
227 -- TODO indent what follows
228 function _ = invalidNode
229
230 mapping :: String -> Env
231 mapping name = linkTargets [name] True
232
233 option :: Node -> Env
234 option (OptionAnnotation n t d) = do
235   targets <- linkTargets [n] True
236   opt <- appendNoWrap $ link n
237   ws <- appendNoWrap " "
238   context <- get
239   meta <- appendNoWrap $ aligned context
240   return $ concat [targets, opt, ws, meta]
241   where
242     aligned context = rightAlign context rhs
243     rhs = t ++ " (default: " ++ fromMaybe "none" d ++ ")\n\n"
244 option _ = invalidNode
245
246 whitespace :: Env
247 whitespace = append " "
248
249 blockquote :: [Node] -> Env
250 blockquote ps = do
251   context <- get
252   put (Context customLineBreak (partialLine context))
253   ps' <- mapM paragraph ps
254   put (Context defaultLineBreak (partialLine context))
255   liftM2 (++) (append "    ") (liftM2 intercalate customParagraphBreak (return ps'))
256   where
257     -- Strip off trailing newlines from each paragraph.
258     paragraph p = fmap trim (node p)
259     trim contents = take (length contents - 2) contents
260     customLineBreak = "\n    "
261     customParagraphBreak = append "\n\n    "
262
263 plaintext :: String -> Env
264 plaintext = append
265
266 fenced :: [String] -> Env
267 fenced f = do
268   cut <- slurp "\n"
269   prefix <- append ">\n"
270   body <- if null f
271           then append ""
272           else appendNoWrap $ "    " ++ intercalate "\n    " f ++ "\n"
273   suffix <- append "<\n"
274   return $ concat [cut, prefix, body, suffix]
275
276 heading :: String -> Env
277 heading h = do
278   metadata <- ask
279   heading' <- appendNoWrap $ map toUpper h ++ " "
280   targ <- maybe (append "\n") (\x -> linkTargets [target' x] False) (pluginName metadata)
281   trailing <- append "\n"
282   return $ concat [heading', targ, trailing]
283   where
284     target' x = normalize $ x ++ "-" ++ h
285
286 normalize :: String -> String
287 normalize = map (toLower . sanitize)
288
289 sanitize :: Char -> Char
290 sanitize x = if isSpace x then '-' else x
291
292 link :: String -> String
293 link l = "|" ++ l ++ "|"
294
295 target :: String -> String
296 target t = "*" ++ t ++ "*"
297
298 -- TODO: be prepared to wrap these if there are a lot of them
299 -- TODO: fix code smell of passing in `wrap` bool here
300 linkTargets :: [String] -> Bool -> Env
301 linkTargets ls wrap = do
302   context <- get
303   if wrap
304   then append $ aligned context
305   else appendNoWrap $ aligned context
306   where
307     aligned context = rightAlign context (targets ++ "\n")
308     targets = unwords (map linkify $ sort ls)
309     linkify l = "*" ++ l ++ "*"
310
311 rightAlign :: Context -> String -> String
312 rightAlign context string = align (partialLine context)
313   where
314     align used = replicate (count used string) ' ' ++ string
315     count used xs = maximum [textwidth - renderedWidth xs - renderedWidth used, 0]
316
317 -- Crude approximation for calculating rendered width, that does so by not
318 -- counting the relatively rare |, *, ` and "\n" -- all of which usually get
319 -- concealed in the rendered output.
320 renderedWidth :: String -> Int
321 renderedWidth = foldr reduce 0
322   where reduce char acc = if char `elem` "\n|*`"
323                         then acc
324                         else acc + 1