Rakka/Wiki/Interpreter/Image.hs

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