Rakka/Wiki/Interpreter/Image.hs

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