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