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