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