Rakka/Wiki/Interpreter/Base/Image.hs

   1 module Rakka.Wiki.Interpreter.Base.Image
   2     ( imageInterp
   3     , imgFrameInterp
   4     )
   5     where
   6
   7 import           Control.Monad
   8 import           Data.Maybe
   9 import           Network.URI
  10 import           Rakka.Page
  11 import           Rakka.SystemConfig
  12 import           Rakka.Wiki.Interpreter
  13 import           Rakka.Wiki
  14
  15
  16 -- <a href="..." class="inlineImage ...">
  17 --   <img src="..." alt="..." />
  18 -- </a>
  19 imageInterp :: Interpreter
  20 imageInterp
  21     = InlineCommandInterpreter {
  22         iciName      = "img"
  23       , iciInterpret
  24           = \ ctx (InlineCommand _ attrs inside) ->
  25             do BaseURI baseURI <- getSysConf (ctxSysConf ctx) (BaseURI undefined)
  26
  27                let pageName = lookup "src" attrs
  28                when (pageName == Nothing)
  29                         $ fail "\"src\" attribute is missing"
  30
  31                let hrefAttr    = ("href", uriToString id (mkPageURI   baseURI (fromJust pageName)) "")
  32                    srcAttr     = ("src" , uriToString id (mkObjectURI baseURI (fromJust pageName)) "")
  33                    altAttr     = do alt <- lookup "alt" attrs
  34                                     return ("alt", alt)
  35                    classAttr   = case lookup "float" attrs of
  36                                    Nothing      -> ("class", "inlineImage")
  37                                    Just "left"  -> ("class", "inlineImage leftFloat")
  38                                    Just "right" -> ("class", "inlineImage rightFloat")
  39                                    Just others  -> error ("unknown \"float\" attribute: " ++ others)
  40                    anchorAttrs = [hrefAttr, classAttr]
  41                    imgAttrs    = catMaybes [Just srcAttr, altAttr]
  42
  43                return (Anchor anchorAttrs [Image imgAttrs])
  44       }
  45
  46
  47 -- <div class="imageFrame ...">
  48 --   <div class="imageData">
  49 --     <p>
  50 --       <a href="...">
  51 --         <img src="..." />
  52 --       </a>
  53 --     </p>
  54 --   </div>
  55 --   <div class="imageCaption">
  56 --     ...
  57 --   </div>
  58 -- </div>
  59 imgFrameInterp :: Interpreter
  60 imgFrameInterp
  61     = BlockCommandInterpreter {
  62         bciName      = "imgframe"
  63       , bciInterpret
  64           = \ ctx (BlockCommand _ attrs inside) ->
  65             do BaseURI baseURI <- getSysConf (ctxSysConf ctx) (BaseURI undefined)
  66
  67                let pageName = lookup "src" attrs
  68                when (pageName == Nothing)
  69                         $ fail "\"src\" attribute is missing"
  70
  71                let hrefAttr    = ("href", uriToString id (mkPageURI   baseURI (fromJust pageName)) "")
  72                    srcAttr     = ("src" , uriToString id (mkObjectURI baseURI (fromJust pageName)) "")
  73                    classAttr   = case lookup "float" attrs of
  74                                    Nothing      -> ("class", "imageFrame")
  75                                    Just "left"  -> ("class", "imageFrame leftFloat")
  76                                    Just "right" -> ("class", "imageFrame rightFloat")
  77                                    Just others  -> error ("unknown \"float\" attribute: " ++ others)
  78
  79                return (Div [classAttr]
  80                        [ Div [("class", "imageData")]
  81                          [ Paragraph [ Anchor [hrefAttr]
  82                                                   [ Image [srcAttr] ] ]
  83                          ]
  84                        , Div [("class", "imageCaption")] inside
  85                        ]
  86                       )
  87       }