]> git.wincent.com - docvim.git/blob - lib/Text/Docvim/Printer/Markdown.hs
fix: add extra space after images
[docvim.git] / lib / Text / Docvim / Printer / Markdown.hs
1 {-# LANGUAGE CPP #-}
2
3 module Text.Docvim.Printer.Markdown (markdown) where
4
5 #if !MIN_VERSION_base(4,8,0)
6 import Control.Applicative ((<$>))
7 #endif
8 import Control.Monad.Reader
9 import Data.List
10 import Data.Maybe
11 import Text.Docvim.AST
12 import Text.Docvim.Parse
13 import Text.Docvim.Visitor.Plugin
14 import Text.Docvim.Visitor.Symbol
15
16 data Metadata = Metadata { pluginName :: Maybe String
17                          , symbols :: [String]
18                          }
19 type Env = Reader Metadata String
20
21 data Anchor = Anchor [Attribute] String
22 data Attribute = Attribute String String
23
24 markdown :: Node -> String
25 markdown n = if null stripped
26              then ""
27              else stripped ++ "\n"
28   where
29     metadata = Metadata (getPluginName n) (getSymbols n)
30     stripped = rstrip (runReader (node n) metadata)
31
32 nodes :: [Node] -> Env
33 nodes ns = concat <$> mapM node ns
34
35 node :: Node -> Env
36 node n = case n of
37   Blockquote b            -> blockquote b >>= nl >>= nl
38   -- TODO, for readability, this should be "<br />\n" (custom, context-aware separator; see Vim.hs)
39   BreakTag                -> return "<br />"
40   Code c                  -> return $ "`" ++ c ++ "`"
41   CommandAnnotation {}    -> command n
42   CommandsAnnotation      -> h2 "Commands"
43   DocBlock d              -> nodes d
44   Fenced f                -> return $ fenced f ++ "\n\n"
45   FunctionAnnotation {}   -> function n
46   FunctionDeclaration {}  -> nodes $ functionBody n
47   FunctionsAnnotation     -> h2 "Functions"
48   HeadingAnnotation h     -> h2 h
49   ImageAnnotation {}      -> image n
50   Link l                  -> link l
51   LinkTargets l           -> return $ linkTargets l
52   List ls                 -> nodes ls >>= nl
53   ListItem l              -> fmap ("- " ++) (nodes l) >>= nl
54   MappingAnnotation m     -> mapping m
55   MappingsAnnotation      -> h2 "Mappings"
56   OptionAnnotation {}     -> option n
57   OptionsAnnotation       -> h2 "Options"
58   Paragraph p             -> nodes p >>= nl >>= nl
59   Plaintext p             -> return $ sanitize p
60   -- TODO: this should be order-independent and always appear at the top.
61   -- Note that I don't really have anywhere to put the description; maybe I should
62   -- scrap it (nope: need it in the Vim help version).
63   PluginAnnotation name _ -> h1 name
64   Project p               -> nodes p
65   Separator               -> return $ "---" ++ "\n\n"
66   SubheadingAnnotation s  -> h3 s
67   Unit u                  -> nodes u
68   Whitespace              -> return " "
69   _                       -> return ""
70
71 -- | Split a string into a list of strings, each containing a single character.
72 split :: String -> [String]
73 split [] = []
74 split (s:xs) = [s]:rest where rest = split xs
75
76 -- | Sanitize a string for use inside markdown, escaping special HTML
77 -- characters.
78 sanitize :: String -> String
79 sanitize s = concatMap repl (split s)
80   where
81     repl "<" = "&lt;"
82     repl ">" = "&gt;"
83     repl "&" = "&amp;"
84     repl "\"" = "&quot;"
85     repl other = other
86
87 -- | Append a newline.
88 nl :: String -> Env
89 nl = return . (++ "\n")
90
91 blockquote :: [Node] -> Env
92 blockquote ps = do
93   ps' <- mapM paragraph ps
94   return $ "> " ++ intercalate "\n>\n> " ps'
95   where
96     -- Strip off trailing newlines from each paragraph.
97     paragraph p = fmap trim (node p)
98     trim contents = take (length contents - 2) contents
99
100 -- TODO: handle "interesting" link text like containing [, ], "
101 link :: String -> Env
102 link l = do
103   metadata <- ask
104   return $ if l `elem` symbols metadata
105            -- TODO: beware names with < ` etc in them
106            -- TODO: consider not using <strong>
107            then "<strong>[`" ++ l ++ "`](" ++ gitHubAnchor l ++ ")</strong>"
108            else "<strong>`" ++ l ++ "`</strong>" -- TODO:
109                                 -- may want to try producing a link to Vim
110                                 -- online help if I can find a search for it
111
112 fenced :: [String] -> String
113 fenced f = "```\n" ++ code ++ "```"
114   where code = if null f
115                then ""
116                else intercalate "\n" f ++ "\n"
117
118 linkTargets :: [String] -> String
119 linkTargets ls =  "<p align=\"right\">"
120                ++ unwords (map linkify $ sort ls)
121                ++ "</p>"
122                ++ "\n"
123                ++ "\n"
124   where
125     linkify l = a $ Anchor [ Attribute "name" (sanitizeAnchor l)
126                            , Attribute "href" (gitHubAnchor l)
127                            ]
128                            (codify l)
129
130 h1 :: String -> Env
131 h1 = heading 1
132
133 h2 :: String -> Env
134 h2 = heading 2
135
136 h3 :: String -> Env
137 h3 = heading 3
138
139 heading :: Int -> String -> Env
140 heading level string = do
141   metadata <- ask
142   return $ replicate level '#' ++ " " ++ string ++ anch (pluginName metadata) ++ "\n\n"
143   where
144     anch name = a $ Anchor [ Attribute "name" (sanitizeAnchor $ pre ++ string)
145                            , Attribute "href" (gitHubAnchor $ pre ++ string)
146                            ]
147                            ""
148       where
149         pre = maybe "" (++ "-") name
150
151 -- | Wraps a string in `<code>`/`</code>` tags.
152 -- TODO: remember why I'm not using backticks here.
153 codify :: String -> String
154 codify s = "<code>" ++ s ++ "</code>"
155
156 a :: Anchor -> String
157 a (Anchor attributes target) = "<a" ++ attrs ++ ">" ++ target ++ "</a>"
158   where
159     attrs = if not (null attributes)
160             then " " ++ attributesString attributes
161             else ""
162
163 attributesString :: [Attribute] -> String
164 attributesString as = unwords (map attributeToString as)
165   where attributeToString (Attribute name value) = name ++ "=\"" ++ value ++ "\""
166
167 gitHubAnchor :: String -> String
168 gitHubAnchor n = "#user-content-" ++ sanitizeAnchor n
169
170 option :: Node -> Env
171 option (OptionAnnotation n t d) = do
172   h <- h3 $ "`" ++ n ++ "` (" ++ t ++ ", default: " ++ def ++ ")"
173   return $ targets ++ h
174   where targets = linkTargets [n]
175         def = fromMaybe "none" d
176 option _ = invalidNode
177
178 command :: Node -> Env
179 command (CommandAnnotation name params) = do
180   content <- h3 $ "`:" ++ annotation ++ "`"
181   return $ target ++ content
182   where target = linkTargets [":" ++ name]
183         annotation = rstrip $ name ++ " " ++ fromMaybe "" params
184 command _ = invalidNode
185
186 function :: Node -> Env
187 function (FunctionAnnotation name) = do
188   content <- h3 $ "`" ++ name ++ "()`"
189   return $ target ++ content
190   where target = linkTargets [name ++ "()"]
191 function _ = invalidNode
192
193 image :: Node -> Env
194 image (ImageAnnotation source alignment) = do
195   return $ open ++ img ++ close
196   where open = "<p" ++ (align alignment) ++ ">\n"
197         align (Just al) = " align=\"" ++ al ++ "\""
198         align Nothing = ""
199         img = "  <img src=\"" ++ source ++ "\" />\n"
200         close = "</p>\n\n"
201 image _ = invalidNode
202
203 mapping :: String -> Env
204 mapping name = h3 $ "`" ++ name ++ "`"