Resurrection from slight bitrot.

[Rakka.git] / Rakka / Wiki / Interpreter / Image.hs

diff --git a/Rakka/Wiki/Interpreter/Image.hs b/Rakka/Wiki/Interpreter/Image.hs
index 7f64de00af6c655167def262fb45be3cd61f8912..00a55de056191ae9fb53b6713907bd2b75bc1b23 100644 (file)
--- a/Rakka/Wiki/Interpreter/Image.hs
+++ b/Rakka/Wiki/Interpreter/Image.hs
@@ -3,8 +3,6 @@ module Rakka.Wiki.Interpreter.Image
     )
     where
 
-import           Control.Monad
-import           Data.Maybe
 import           Network.URI
 import           Rakka.Page
 import           Rakka.SystemConfig
@@ -18,6 +16,12 @@ interpreters = [ imageInterp
                ]
 
 
+-- <img src="[PageName]"
+--      alt="[Alternative]"   -- 省略可能
+--      link="[PageName]"     -- 省略可能、省略時は画像そのものへのリンク
+--      link="[Absolute URI]" -- 絶對 URI の場合はその URI へのリンク
+--      link="" />            -- 空文字列の場合はリンク無し
+
 -- <a href="..." class="inlineImage ...">
 --   <img src="..." alt="..." />
 -- </a>
@@ -26,36 +30,38 @@ imageInterp
     = InlineCommandInterpreter {
         iciName      = "img"
       , iciInterpret
-          = \ ctx (InlineCommand _ attrs inside) ->
-            do BaseURI baseURI <- getSysConf (ctxSysConf ctx) (BaseURI undefined)
-
-               let pageName = lookup "src" attrs
-               when (pageName == Nothing)
-                        $ fail "\"src\" attribute is missing"
+          = \ ctx (InlineCommand _ attrs _) ->
+            do BaseURI baseURI <- getSysConf (ctxSysConf ctx)
 
-               let hrefAttr    = ("href", uriToString id (mkPageURI   baseURI (fromJust pageName)) "")
-                   srcAttr     = ("src" , uriToString id (mkObjectURI baseURI (fromJust pageName)) "")
-                   altAttr     = do alt <- lookup "alt" attrs
-                                    return ("alt", alt)
+               let name        = case lookup "src" attrs of
+                                   Just x  -> x
+                                   Nothing -> error "\"src\" attribute is missing"
+                   link        = case lookup "link" attrs of
+                                   Just "" -> Nothing
+                                   Just x  -> if isURI x then
+                                                  Just x
+                                              else
+                                                  Just (uriToString id (mkPageURI baseURI x) "")
+                                   Nothing -> Just (uriToString id (mkPageURI baseURI name) "")
+                   alt         = lookup "alt" attrs
                    classAttr   = case lookup "float" attrs of
-                                   Nothing      -> ("class", "inlineImage")
-                                   Just "left"  -> ("class", "inlineImage leftFloat")
-                                   Just "right" -> ("class", "inlineImage rightFloat")
+                                   Nothing      -> "inlineImage"
+                                   Just "left"  -> "inlineImage leftFloat"
+                                   Just "right" -> "inlineImage rightFloat"
                                    Just others  -> error ("unknown \"float\" attribute: " ++ others)
-                   anchorAttrs = [hrefAttr, classAttr]
-                   imgAttrs    = catMaybes [Just srcAttr, altAttr]
-
-               return (Anchor anchorAttrs [Image imgAttrs])
+                   result      = case link of
+                                   Nothing -> Span [("class", classAttr)] [Image (Right name) alt]
+                                   Just x  -> Anchor [ ("class", classAttr)
+                                                     , ("href" , x        ) ] [Image (Right name) alt]
+               return result
       }
 
 
 -- <div class="imageFrame ...">
 --   <div class="imageData">
---     <p>
---       <a href="...">
---         <img src="..." />
---       </a>
---     </p>
+--     <a href="...">
+--       <img src="..." />
+--     </a>
 --   </div>
 --   <div class="imageCaption">
 --     ...
@@ -67,26 +73,32 @@ imgFrameInterp
         bciName      = "imgframe"
       , bciInterpret
           = \ ctx (BlockCommand _ attrs inside) ->
-            do BaseURI baseURI <- getSysConf (ctxSysConf ctx) (BaseURI undefined)
-
-               let pageName = lookup "src" attrs
-               when (pageName == Nothing)
-                        $ fail "\"src\" attribute is missing"
+            do BaseURI baseURI <- getSysConf (ctxSysConf ctx)
 
-               let hrefAttr    = ("href", uriToString id (mkPageURI   baseURI (fromJust pageName)) "")
-                   srcAttr     = ("src" , uriToString id (mkObjectURI baseURI (fromJust pageName)) "")
+               let name        = case lookup "src" attrs of
+                                   Just x  -> x
+                                   Nothing -> error "\"src\" attribute is missing"
+                   link        = case lookup "link" attrs of
+                                   Just "" -> Nothing
+                                   Just x  -> if isURI x then
+                                                  Just x
+                                              else
+                                                  Just (uriToString id (mkPageURI baseURI x) "")
+                                   Nothing -> Just (uriToString id (mkPageURI baseURI name) "")
                    classAttr   = case lookup "float" attrs of
                                    Nothing      -> ("class", "imageFrame")
                                    Just "left"  -> ("class", "imageFrame leftFloat")
                                    Just "right" -> ("class", "imageFrame rightFloat")
                                    Just others  -> error ("unknown \"float\" attribute: " ++ others)
+                   image       = case link of
+                                   Nothing -> Image (Right name) Nothing
+                                   Just x  -> Anchor [("href" , x)] [Image (Right name) Nothing]
                
                return (Div [classAttr]
-                       [ Div [("class", "imageData")]
-                         [ Paragraph [ Anchor [hrefAttr]
-                                                  [ Image [srcAttr] ] ]
-                         ]
-                       , Div [("class", "imageCaption")] inside
+                       [ Block (Div [("class", "imageData")]
+                                        [ Inline image ])
+                       , Block (Div [("class", "imageCaption")]
+                                        [ Block x | x <- inside ])
                        ]
                       )
       }