X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FWiki%2FInterpreter%2FImage.hs;h=886fdf512732228f1f746b7481d81bf0987b4c07;hb=42f51754dea02201aececaacbf194d714cd58aaf;hp=7f64de00af6c655167def262fb45be3cd61f8912;hpb=8f77b5949ccd5f2272a02c852d51bfa2ecfa84c8;p=Rakka.git diff --git a/Rakka/Wiki/Interpreter/Image.hs b/Rakka/Wiki/Interpreter/Image.hs index 7f64de0..886fdf5 100644 --- a/Rakka/Wiki/Interpreter/Image.hs +++ b/Rakka/Wiki/Interpreter/Image.hs @@ -1,92 +1,110 @@ +{-# LANGUAGE + OverloadedStrings + , RecordWildCards + , UnicodeSyntax + , ViewPatterns + #-} module Rakka.Wiki.Interpreter.Image ( interpreters ) where +import Data.Monoid.Unicode +import Data.Text (Text) +import qualified Data.Text as T +import Network.URI +import Prelude.Unicode +import Rakka.Page +import Rakka.SystemConfig +import Rakka.Wiki.Interpreter +import Rakka.Wiki -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 â· [Interpreter] interpreters = [ imageInterp , imgFrameInterp ] +-- -- 空æååã®å ´åã¯ãªã³ã¯ç¡ã -- -- -- -imageInterp :: Interpreter +imageInterp â· Interpreter imageInterp = InlineCommandInterpreter { - iciName = "img" + 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) + = \(InterpreterContext {..}) (InlineCommand _ attrs _) â + do BaseURI baseURI â getSysConf ctxSysConf + let name = case lookup "src" attrs of + Just x â x + Nothing â error "\"src\" attribute is missing" + link = case lookup "link" attrs of + Just x + | T.null x â Nothing + | isURI' x â Just x + | otherwise â Just â T.pack $ uriToString id (mkPageURI baseURI x ) "" + Nothing â Just â T.pack $ 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") - Just others -> error ("unknown \"float\" attribute: " ++ others) - anchorAttrs = [hrefAttr, classAttr] - imgAttrs = catMaybes [Just srcAttr, altAttr] - - return (Anchor anchorAttrs [Image imgAttrs]) + Nothing â "inlineImage" + Just "left" â "inlineImage leftFloat" + Just "right" â "inlineImage rightFloat" + Just others â error ("unknown \"float\" attribute: " â T.unpack others) + 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 } --
-imgFrameInterp :: Interpreter +imgFrameInterp â· Interpreter imgFrameInterp = BlockCommandInterpreter { - bciName = "imgframe" + 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)) "") + = \(InterpreterContext {..}) (BlockCommand _ attrs inside) â + do BaseURI baseURI â getSysConf ctxSysConf + let name = case lookup "src" attrs of + Just x â x + Nothing â error "\"src\" attribute is missing" + link = case lookup "link" attrs of + Just x + | T.null x â Nothing + | isURI' x â Just x + | otherwise â Just â T.pack $ uriToString id (mkPageURI baseURI x ) "" + Nothing â Just â T.pack $ 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) + Nothing â ("class", "imageFrame") + Just "left" â ("class", "imageFrame leftFloat") + Just "right" â ("class", "imageFrame rightFloat") + Just others â error ("unknown \"float\" attribute: " â T.unpack 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 ]) ] ) } + +isURI' â· Text â Bool +isURI' = isURI â T.unpack \ No newline at end of file