X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FWiki%2FInterpreter%2FImage.hs;fp=Rakka%2FWiki%2FInterpreter%2FImage.hs;h=7f64de00af6c655167def262fb45be3cd61f8912;hb=8f77b5949ccd5f2272a02c852d51bfa2ecfa84c8;hp=0000000000000000000000000000000000000000;hpb=4e8a07033b0b0ea0961bffb3bab0b6fc9c21afba;p=Rakka.git

diff --git a/Rakka/Wiki/Interpreter/Image.hs b/Rakka/Wiki/Interpreter/Image.hs
new file mode 100644
index 0000000..7f64de0
--- /dev/null
+++ b/Rakka/Wiki/Interpreter/Image.hs
@@ -0,0 +1,92 @@
+module Rakka.Wiki.Interpreter.Image
+    ( interpreters
+    )
+    where
+
+import           Control.Monad
+import           Data.Maybe
+import           Network.URI
+import           Rakka.Page
+import           Rakka.SystemConfig
+import           Rakka.Wiki.Interpreter
+import           Rakka.Wiki
+
+
+interpreters :: [Interpreter]
+interpreters = [ imageInterp
+               , imgFrameInterp
+               ]
+
+
+-- <a href="..." class="inlineImage ...">
+--   <img src="..." alt="..." />
+-- </a>
+imageInterp :: Interpreter
+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"
+
+               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)
+                   classAttr   = case lookup "float" attrs of
+                                   Nothing      -> ("class", "inlineImage")
+                                   Just "left"  -> ("class", "inlineImage leftFloat")
+                                   Just "right" -> ("class", "inlineImage rightFloat")
+                                   Just others  -> error ("unknown \"float\" attribute: " ++ others)
+                   anchorAttrs = [hrefAttr, classAttr]
+                   imgAttrs    = catMaybes [Just srcAttr, altAttr]
+
+               return (Anchor anchorAttrs [Image imgAttrs])
+      }
+
+
+-- <div class="imageFrame ...">
+--   <div class="imageData">
+--     <p>
+--       <a href="...">
+--         <img src="..." />
+--       </a>
+--     </p>
+--   </div>
+--   <div class="imageCaption">
+--     ...
+--   </div>
+-- </div>
+imgFrameInterp :: Interpreter
+imgFrameInterp
+    = BlockCommandInterpreter {
+        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"
+
+               let hrefAttr    = ("href", uriToString id (mkPageURI   baseURI (fromJust pageName)) "")
+                   srcAttr     = ("src" , uriToString id (mkObjectURI baseURI (fromJust pageName)) "")
+                   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)
+               
+               return (Div [classAttr]
+                       [ Div [("class", "imageData")]
+                         [ Paragraph [ Anchor [hrefAttr]
+                                                  [ Image [srcAttr] ] ]
+                         ]
+                       , Div [("class", "imageCaption")] inside
+                       ]
+                      )
+      }