Resurrection from bitrot

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

diff --git a/Rakka/Wiki/Interpreter/Image.hs b/Rakka/Wiki/Interpreter/Image.hs
index 00a55de056191ae9fb53b6713907bd2b75bc1b23..886fdf512732228f1f746b7481d81bf0987b4c07 100644 (file)
--- a/Rakka/Wiki/Interpreter/Image.hs
+++ b/Rakka/Wiki/Interpreter/Image.hs
@@ -1,21 +1,28 @@
+{-# 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           Network.URI
-import           Rakka.Page
-import           Rakka.SystemConfig
-import           Rakka.Wiki.Interpreter
-import           Rakka.Wiki
-
-
-interpreters :: [Interpreter]
+interpreters ∷ [Interpreter]
 interpreters = [ imageInterp
                , imgFrameInterp
                ]
 
-
 -- <img src="[PageName]"
 --      alt="[Alternative]"   -- 省略可能
 --      link="[PageName]"     -- 省略可能、省略時は画像そのものへのリンク
@@ -25,34 +32,32 @@ interpreters = [ imageInterp
 -- <a href="..." class="inlineImage ...">
 --   <img src="..." alt="..." />
 -- </a>
-imageInterp :: Interpreter
+imageInterp ∷ Interpreter
 imageInterp
     = InlineCommandInterpreter {
-        iciName      = "img"
+        iciName = "img"
       , iciInterpret
-          = \ ctx (InlineCommand _ attrs _) ->
-            do BaseURI baseURI <- getSysConf (ctxSysConf ctx)
-
+          = \(InterpreterContext {..}) (InlineCommand _ attrs _) →
+            do BaseURI baseURI ← getSysConf ctxSysConf
                let name        = case lookup "src" attrs of
-                                   Just x  -> x
-                                   Nothing -> error "\"src\" attribute is missing"
+                                   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) "")
+                                   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      -> "inlineImage"
-                                   Just "left"  -> "inlineImage leftFloat"
-                                   Just "right" -> "inlineImage rightFloat"
-                                   Just others  -> error ("unknown \"float\" attribute: " ++ others)
+                                   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]
+                                   Nothing → Span [("class", classAttr)] [Image (Right name) alt]
+                                   Just x  → Anchor [ ("class", classAttr)
+                                                    , ("href" , x        ) ] [Image (Right name) alt]
                return result
       }
 
@@ -67,38 +72,39 @@ imageInterp
 --     ...
 --   </div>
 -- </div>
-imgFrameInterp :: Interpreter
+imgFrameInterp ∷ Interpreter
 imgFrameInterp
     = BlockCommandInterpreter {
-        bciName      = "imgframe"
+        bciName = "imgframe"
       , bciInterpret
-          = \ ctx (BlockCommand _ attrs inside) ->
-            do BaseURI baseURI <- getSysConf (ctxSysConf ctx)
-
+          = \(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"
+                                   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) "")
+                                   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]
+                                   Nothing → Image (Right name) Nothing
+                                   Just x  → Anchor [("href" , x)] [Image (Right name) Nothing]
                
                return (Div [classAttr]
                        [ Block (Div [("class", "imageData")]
                                         [ Inline image ])
                        , Block (Div [("class", "imageCaption")]
-                                        [ Block x | x <- inside ])
+                                        [ Block x | x ← inside ])
                        ]
                       )
       }
+
+isURI' ∷ Text → Bool
+isURI' = isURI ∘ T.unpack
\ No newline at end of file