Rakka/Wiki/Interpreter/Image.hs

   1 module Rakka.Wiki.Interpreter.Image
   2     ( interpreters
   3     )
   4     where
   5
   6 import           Control.Monad
   7 import           Data.Maybe
   8 import           Network.URI
   9 import           Rakka.Page
  10 import           Rakka.SystemConfig
  11 import           Rakka.Wiki.Interpreter
  12 import           Rakka.Wiki
  13
  14
  15 interpreters :: [Interpreter]
  16 interpreters = [ imageInterp
  17                , imgFrameInterp
  18                ]
  19
  20
  21 -- <img src="[PageName]"
  22 --      alt="[Alternative]"   -- 省略可能
  23 --      link="[PageName]"     -- 省略可能、省略時は画像そのものへのリンク
  24 --      link="[Absolute URI]" -- 絶對 URI の場合はその URI へのリンク
  25 --      link="" />            -- 空文字列の場合はリンク無し
  26
  27 -- <a href="..." class="inlineImage ...">
  28 --   <img src="..." alt="..." />
  29 -- </a>
  30 imageInterp :: Interpreter
  31 imageInterp
  32     = InlineCommandInterpreter {
  33         iciName      = "img"
  34       , iciInterpret
  35           = \ ctx (InlineCommand _ attrs _) ->
  36             do BaseURI baseURI <- getSysConf (ctxSysConf ctx)
  37
  38                let name        = case lookup "src" attrs of
  39                                    Just x  -> x
  40                                    Nothing -> error "\"src\" attribute is missing"
  41                    link        = case lookup "link" attrs of
  42                                    Just "" -> Nothing
  43                                    Just x  -> if isURI x then
  44                                                   Just x
  45                                               else
  46                                                   Just (uriToString id (mkPageURI baseURI x) "")
  47                                    Nothing -> Just (uriToString id (mkPageURI baseURI name) "")
  48                    alt         = lookup "alt" attrs
  49                    classAttr   = case lookup "float" attrs of
  50                                    Nothing      -> "inlineImage"
  51                                    Just "left"  -> "inlineImage leftFloat"
  52                                    Just "right" -> "inlineImage rightFloat"
  53                                    Just others  -> error ("unknown \"float\" attribute: " ++ others)
  54                    result      = case link of
  55                                    Nothing -> Span [("class", classAttr)] [Image (Right name) alt]
  56                                    Just x  -> Anchor [ ("class", classAttr)
  57                                                      , ("href" , x        ) ] [Image (Right name) alt]
  58                return result
  59       }
  60
  61
  62 -- <div class="imageFrame ...">
  63 --   <div class="imageData">
  64 --     <a href="...">
  65 --       <img src="..." />
  66 --     </a>
  67 --   </div>
  68 --   <div class="imageCaption">
  69 --     ...
  70 --   </div>
  71 -- </div>
  72 imgFrameInterp :: Interpreter
  73 imgFrameInterp
  74     = BlockCommandInterpreter {
  75         bciName      = "imgframe"
  76       , bciInterpret
  77           = \ ctx (BlockCommand _ attrs inside) ->
  78             do BaseURI baseURI <- getSysConf (ctxSysConf ctx)
  79
  80                let name        = case lookup "src" attrs of
  81                                    Just x  -> x
  82                                    Nothing -> error "\"src\" attribute is missing"
  83                    link        = case lookup "link" attrs of
  84                                    Just "" -> Nothing
  85                                    Just x  -> if isURI x then
  86                                                   Just x
  87                                               else
  88                                                   Just (uriToString id (mkPageURI baseURI x) "")
  89                                    Nothing -> Just (uriToString id (mkPageURI baseURI name) "")
  90                    classAttr   = case lookup "float" attrs of
  91                                    Nothing      -> ("class", "imageFrame")
  92                                    Just "left"  -> ("class", "imageFrame leftFloat")
  93                                    Just "right" -> ("class", "imageFrame rightFloat")
  94                                    Just others  -> error ("unknown \"float\" attribute: " ++ others)
  95                    image       = case link of
  96                                    Nothing -> Image (Right name) Nothing
  97                                    Just x  -> Anchor [("href" , x)] [Image (Right name) Nothing]
  98
  99                return (Div [classAttr]
 100                        [ Block (Div [("class", "imageData")]
 101                                         [ Inline image ])
 102                        , Block (Div [("class", "imageCaption")]
 103                                         [ Block x | x <- inside ])
 104                        ]
 105                       )
 106       }