- -> let uri = case (page, fragment) of
- (Just x, Just y) -> mkPageFragmentURI baseURI (fix x) y
- (Just x, Nothing) -> mkPageURI baseURI (fix x)
- (Nothing, Just y) -> nullURI { uriFragment = ('#':y) }
- fix = (\ (x:xs) -> toUpper x : xs) . map (\ c -> if c == ' ' then '_' else c)
- href = uriToString id uri ""
- dLabel = fromMaybe "" page ++ fromMaybe "" (fmap ('#':) fragment)
- label = fromMaybe dLabel text
- in
- ( eelem "a"
- += attr "href" (arr fst >>> mkText)
- += (arr snd >>> mkText)
- ) -< (href, label)
+ → let uri = case (page, fragment) of
+ (Just x, Just y) → mkPageFragmentURI baseURI x y
+ (Just x, Nothing) → mkPageURI baseURI x
+ (Nothing, Just y) → mkFragmentURI y
+ _ → (⊥)
+ dLabel = fromMaybe (∅) page ⊕ maybe (∅) (T.cons '#') fragment
+ label = fromMaybe dLabel text
+ in
+ mkAnchor ⤙ (uri, label)
+
+formatImage ∷ ArrowXml (⇝) ⇒ (URI, InlineElement) ⇝ XmlTree
+formatImage = proc (baseURI, Image src alt)
+ → let uri = case src of
+ Left u → u
+ Right name → mkObjectURI baseURI name
+ href = uriToString id uri ""
+ in
+ ( eelem "img"
+ += sattr "src" href
+ += ( case alt of
+ Just x → sattr "alt" (T.unpack x)
+ Nothing → none
+ )
+ ) ⤛ ()
+
+
+formatExternalLink ∷ ArrowXml (⇝) ⇒ InlineElement ⇝ XmlTree
+formatExternalLink
+ = proc (ExternalLink uri text)
+ → let href = uriToString id uri ""
+ label = fromMaybe (T.pack href) text
+ in
+ mkAnchor -< (uri, label)
+
+mkAnchor ∷ ArrowXml (⇝) ⇒ (URI, Text) ⇝ XmlTree
+mkAnchor = eelem "a"
+ += attr "href" (arr (flip (uriToString id) "" ∘ fst) ⋙ mkText)
+ += (arr (T.unpack ∘ snd) ⋙ mkText)
+
+attachXHtmlNS ∷ ArrowXml (⇝) ⇒ XmlTree ⇝ XmlTree
+attachXHtmlNS = processTopDown (changeQName attach `when` isElem)
+ where
+ attach ∷ QName → QName
+ attach = setNamespaceUri' (newXName "http://www.w3.org/1999/xhtml")