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 -- <a href="..." class="inlineImage ...">
  22 --   <img src="..." alt="..." />
  23 -- </a>
  24 imageInterp :: Interpreter
  25 imageInterp
  26     = InlineCommandInterpreter {
  27         iciName      = "img"
  28       , iciInterpret
  29           = \ ctx (InlineCommand _ attrs inside) ->
  30             do BaseURI baseURI <- getSysConf (ctxSysConf ctx) (BaseURI undefined)
  31
  32                let pageName = lookup "src" attrs
  33                when (pageName == Nothing)
  34                         $ fail "\"src\" attribute is missing"
  35
  36                let hrefAttr    = ("href", uriToString id (mkPageURI   baseURI (fromJust pageName)) "")
  37                    srcAttr     = ("src" , uriToString id (mkObjectURI baseURI (fromJust pageName)) "")
  38                    altAttr     = do alt <- lookup "alt" attrs
  39                                     return ("alt", alt)
  40                    classAttr   = case lookup "float" attrs of
  41                                    Nothing      -> ("class", "inlineImage")
  42                                    Just "left"  -> ("class", "inlineImage leftFloat")
  43                                    Just "right" -> ("class", "inlineImage rightFloat")
  44                                    Just others  -> error ("unknown \"float\" attribute: " ++ others)
  45                    anchorAttrs = [hrefAttr, classAttr]
  46                    imgAttrs    = catMaybes [Just srcAttr, altAttr]
  47
  48                return (Anchor anchorAttrs [Image imgAttrs])
  49       }
  50
  51
  52 -- <div class="imageFrame ...">
  53 --   <div class="imageData">
  54 --     <p>
  55 --       <a href="...">
  56 --         <img src="..." />
  57 --       </a>
  58 --     </p>
  59 --   </div>
  60 --   <div class="imageCaption">
  61 --     ...
  62 --   </div>
  63 -- </div>
  64 imgFrameInterp :: Interpreter
  65 imgFrameInterp
  66     = BlockCommandInterpreter {
  67         bciName      = "imgframe"
  68       , bciInterpret
  69           = \ ctx (BlockCommand _ attrs inside) ->
  70             do BaseURI baseURI <- getSysConf (ctxSysConf ctx) (BaseURI undefined)
  71
  72                let pageName = lookup "src" attrs
  73                when (pageName == Nothing)
  74                         $ fail "\"src\" attribute is missing"
  75
  76                let hrefAttr    = ("href", uriToString id (mkPageURI   baseURI (fromJust pageName)) "")
  77                    srcAttr     = ("src" , uriToString id (mkObjectURI baseURI (fromJust pageName)) "")
  78                    classAttr   = case lookup "float" attrs of
  79                                    Nothing      -> ("class", "imageFrame")
  80                                    Just "left"  -> ("class", "imageFrame leftFloat")
  81                                    Just "right" -> ("class", "imageFrame rightFloat")
  82                                    Just others  -> error ("unknown \"float\" attribute: " ++ others)
  83
  84                return (Div [classAttr]
  85                        [ Div [("class", "imageData")]
  86                          [ Paragraph [ Anchor [hrefAttr]
  87                                                   [ Image [srcAttr] ] ]
  88                          ]
  89                        , Div [("class", "imageCaption")] inside
  90                        ]
  91                       )
  92       }