]> git.wincent.com - docvim.git/blob - lib/Docvim/Printer/Vim.hs
Be better about hard-wrap placement
[docvim.git] / lib / Docvim / Printer / Vim.hs
1 module Docvim.Printer.Vim
2   ( vimHelp
3   , ppv
4   , pv
5   ) where
6
7 import Control.Arrow ((***))
8 import Control.Monad (join)
9 import Control.Monad.Reader
10 import Control.Monad.State
11 import Data.Char (isSpace, toUpper)
12 import Data.List (intercalate, isSuffixOf, span, sort)
13 import Data.Tuple (swap)
14 import Docvim.AST
15 import Docvim.Parse (parseUnit, rstrip)
16 import Docvim.Visitor.Plugin (getPluginName)
17 import Docvim.Visitor.Symbol (getSymbols)
18
19 -- TODO: add indentation here (using local, or just stick it in Context)
20
21 -- Instead of building up a [Char], we build up a list of operations, which
22 -- allows us a mechanism of implementing rollback and therefore hard-wrapping
23 -- (eg. append whitespace " ", then on next node, realize that we will exceed
24 -- line length limit, so rollback the " " and instead append "\n" etc).
25 data Operation = Append String
26                | Delete Int -- unconditional delete count of Char
27                | Slurp String -- delete string if present
28 data Metadata = Metadata { symbols :: [String]
29                          , pluginName :: Maybe String
30                          }
31 data Context = Context { lineBreak :: String
32                        , partialLine :: String
33                        }
34 type Env = ReaderT Metadata (State Context) [Operation]
35
36 textwidth :: Int
37 textwidth = 78
38
39 vimHelp :: Node -> String
40 vimHelp n = rstrip output ++ "\n"
41   where metadata = Metadata (getSymbols n) (getPluginName n)
42         context = Context defaultLineBreak ""
43         operations = evalState (runReaderT (node n) metadata) context
44         output = foldl reduce "" operations
45         reduce acc (Append atom) = acc ++ atom
46         reduce acc (Delete count) = take (length acc - count) acc
47         reduce acc (Slurp atom) = if isSuffixOf atom acc
48                                   then take (length acc - length atom) acc
49                                   else acc
50
51 -- Helper function that appends and updates `partialLine` context.
52 append :: String -> Env
53 append string = do
54   context <- get
55   -- TODO obviously tidy this up
56   -- TODO: always suppress trailing whitespace (some of it is making it into the
57   -- output)
58   let (ops, line) = if length (partialLine context) + length string >= textwidth
59                     then ([Delete (length $ snd $ split $ partialLine context), Slurp " ", Append (lineBreak context), Append (snd $ split $ partialLine context), Append $ string], lineBreak context ++ (snd $ split $ partialLine context) ++ string)
60                     else ([Append string], partialLine context ++ string)
61   put (Context (lineBreak context) (end line))
62   return ops
63   where
64     trailing str = length $ takeWhile isSpace (reverse str)
65     end l = reverse $ takeWhile (/= '\n') (reverse l)
66     split str = hardwrap str
67
68 -- http://stackoverflow.com/a/9723976/2103996
69 mapTuple = join (***)
70
71 -- Given a string, hardwraps it into two parts by splitting it at the rightmost
72 -- whitespace.
73 hardwrap :: String -> (String, String)
74 hardwrap str = swap $ mapTuple reverse split
75   where
76     split = span (not . isSpace) (reverse str)
77
78 -- Helper function that deletes `count` elements from the end of the
79 --`partialLine` context.
80 delete :: Int -> Env
81 delete count = do
82   context <- get
83   put (Context (lineBreak context) (partial context))
84   return [Delete count]
85   where
86     partial context = take (length (partialLine context) - count) (partialLine context)
87
88 -- Helper function to conditionally remove a string if it appears at the end of
89 -- the output.
90 slurp :: String -> Env
91 slurp str = do
92   context <- get
93   put (Context (lineBreak context) (partial context))
94   return [Slurp str]
95   where
96     -- eg. (partialLine context) | str        | result
97     --     ----------------------|------------|-------
98     --     ""                    | "\n"       | ""
99     --     "foo"                 | "\n"       | "foo"
100     --     "foo"                 | "bar"      | "foo"
101     --     "abc"                 | "bc"       | "a"
102     --     "abc"                 | "foo\nabc" | ""
103     --
104     -- Note: That last one is unsafe, because we can't guarantee that "foo" is
105     -- there. Caveat emptor!
106     partial context = if isSuffixOf str (partialLine context)
107                       then take (length (partialLine context) - length str) (partialLine context)
108                       else (partialLine context)
109
110 defaultLineBreak :: String
111 defaultLineBreak = "\n"
112
113 nodes :: [Node] -> Env
114 nodes ns = concat <$> mapM node ns
115
116 -- TODO: deal with hard-wrapping (still some overlength lines and edge cases to
117 -- deal with)
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   DocBlock d                 -> nodes d
124   Fenced f                   -> fenced f
125   FunctionDeclaration {}     -> nodes $ functionBody n
126   -- TODO: Vim will only highlight this as a heading if it has a trailing
127   -- LinkTarget on the same line; figure out how to handle that; may need to
128   -- address it in the Parser
129   --
130   -- Looking at the Ferret fixtures, seems like I had an idea for this which was
131   -- to auto-gen the targets based on the plugin name + the heading text.
132   --
133   -- I could also just make people specify a target explicitly.
134   HeadingAnnotation h        -> append $ map toUpper h ++ "\n\n"
135   Link l                     -> append $ "|" ++ l ++ "|"
136   LinkTargets l              -> linkTargets l
137   List ls                    -> nodes ls >>= nl
138   ListItem l                 -> listitem l
139   Paragraph p                -> nodes p >>= nl >>= nl
140   Plaintext p                -> plaintext p
141   -- TODO: this should be order-independent and always appear at the top.
142   -- Note that I don't really have anywhere to put the description; maybe I should
143   -- scrap it (nope: need it in the Vim help version).
144   PluginAnnotation name desc -> plugin name desc
145   Project p                  -> nodes p
146   Separator                  -> append $ "---" ++ "\n\n"
147   SubheadingAnnotation s     -> append $ s ++ " ~\n\n"
148   Unit u                     -> nodes u
149   Whitespace                 -> whitespace
150   _                          -> append ""
151
152 -- TODO: right-align trailing link target
153 -- TODO: add {name}.txt to the symbol table?
154 plugin :: String -> String -> Env
155 plugin name desc = append $
156   "*" ++ name ++ ".txt*" ++
157   "    " ++ desc ++ "      " ++
158   "*" ++ name ++ "*" ++ "\n\n"
159
160 -- | Append a newline.
161 nl :: [Operation] -> Env
162 nl os = liftM2 (++) (return os) (append "\n")
163
164 breaktag :: Env
165 breaktag = do
166   state <- get
167   append $ lineBreak state
168
169 listitem :: [Node] -> Env
170 listitem l = do
171   context <- get
172   -- TODO: consider using lenses to modify records
173   put (Context customLineBreak (partialLine context))
174   item <- liftM2 (++) (append "- ") (nodes l) >>= nl
175   put (Context defaultLineBreak (partialLine context))
176   return item
177   where
178     customLineBreak = "\n  "
179
180 whitespace :: Env
181 whitespace =
182   -- if current line > 80 "\n" else " "
183   -- but note, really need to do this BEFORE 80
184   append " "
185
186 blockquote :: [Node] -> Env
187 blockquote ps = do
188   context <- get
189   put (Context customLineBreak (partialLine context))
190   ps' <- mapM paragraph ps
191   put (Context defaultLineBreak (partialLine context))
192   liftM2 (++) (append "    ") (liftM2 intercalate customParagraphBreak (return ps'))
193   where
194     -- Strip off trailing newlines from each paragraph.
195     paragraph p = fmap trim (node p)
196     trim contents = take (length contents - 2) contents
197     customLineBreak = "\n    "
198     customParagraphBreak = append "\n\n    "
199
200 plaintext :: String -> Env
201 plaintext = append
202
203 fenced :: [String] -> Env
204 fenced f = do
205   cut <- slurp "\n"
206   prefix <- append ">\n"
207   body <- if null f
208           then append ""
209           else append $ "    " ++ intercalate "\n    " f ++ "\n"
210   suffix <- append "<\n"
211   return $ concat [cut, prefix, body, suffix]
212
213 -- TODO: be prepared to wrap these if there are a lot of them
214 linkTargets :: [String] -> Env
215 linkTargets ls = append $ rightAlign targets ++ "\n"
216   where
217     targets = unwords (map linkify $ sort ls)
218     linkify l = "*" ++ l ++ "*"
219     rightAlign ws = replicate (count ws) ' ' ++ ws
220     count xs = maximum [textwidth - length xs, 0]
221
222 -- | For unit testing.
223 pv :: String -> String
224 pv input = case parseUnit input of
225             Left error -> show error
226             Right ast -> vimHelp ast
227
228 -- | For logging in the REPL.
229 ppv :: String -> IO ()
230 ppv = putStr . pv