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