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 ++ "`"