Implemented inline images and framed images

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

diff --git a/Rakka/Wiki/Interpreter/Base/Image.hs b/Rakka/Wiki/Interpreter/Base/Image.hs
new file mode 100644 (file)
index 0000000..d23ec78
--- /dev/null
+++ b/Rakka/Wiki/Interpreter/Base/Image.hs
@@ -0,0 +1,87 @@
+module Rakka.Wiki.Interpreter.Base.Image
+    ( imageInterp
+    , imgFrameInterp
+    )
+    where
+
+import           Control.Monad
+import           Data.Maybe
+import           Network.URI
+import           Rakka.Page
+import           Rakka.SystemConfig
+import           Rakka.Wiki.Interpreter
+import           Rakka.Wiki
+
+
+-- <a href="..." class="inlineImage ...">
+--   <img src="..." alt="..." />
+-- </a>
+imageInterp :: Interpreter
+imageInterp
+    = InlineCommandInterpreter {
+        iciName      = "img"
+      , iciInterpret
+          = \ (InlineCommand _ attrs inside) _ _ sysConf ->
+            do BaseURI baseURI <- getSysConf sysConf (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
+          = \ (BlockCommand _ attrs inside) _ _ sysConf ->
+            do BaseURI baseURI <- getSysConf sysConf (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
+                       ]
+                      )
+      }