src/LWN/XHTML.hs

   1 module LWN.XHTML (
   2   XHTML,
   3   XML,
   4   full_story_urls,
   5   image_srcs,
   6   full_story_link,
   7   full_story_paragraph,
   8   is_image,
   9   parse_lwn,
  10   preprocess,
  11   remove_byline,
  12   remove_title,
  13   to_xhtml,
  14   to_xml,
  15   xml_from_contents)
  16 where
  17
  18 import Text.HandsomeSoup (css)
  19 import Text.Regex.Posix ((=~))
  20 import Text.XML.HXT.Core (
  21   (>>>),
  22   (/>),
  23   ArrowXml,
  24   IOStateArrow,
  25   SysConfigList,
  26   XmlTree,
  27   changeAttrValue,
  28   deep,
  29   getAttrValue,
  30   hasAttrValue,
  31   hasName,
  32   hasText,
  33   ifA,
  34   isElem,
  35   mkName,
  36   no,
  37   none,
  38   processAttrl,
  39   processTopDown,
  40   readString,
  41   setElemName,
  42   this,
  43   when,
  44   withParseHTML,
  45   withValidate,
  46   withWarnings,
  47   yes)
  48
  49
  50 import LWN.URI (URL, try_make_absolute_url)
  51 import Misc (contains)
  52
  53
  54 class XHTML a where
  55   to_xhtml :: a -> String
  56
  57 class XML a where
  58   to_xml :: (ArrowXml b) => a -> (b XmlTree XmlTree)
  59
  60 -- | Options used when parsing HTML.
  61 my_read_opts :: SysConfigList
  62 my_read_opts = [ withValidate  no,
  63                  withParseHTML yes,
  64                  withWarnings no ]
  65
  66 -- | My version of HandsomeSoup's parseHTML.
  67 parse_lwn :: String -> IOStateArrow s b XmlTree
  68 parse_lwn = readString my_read_opts
  69
  70
  71 -- | Takes the result of get_article_contents and calls parse_lwn on
  72 --   the contained value.
  73 xml_from_contents :: (Maybe String) -> Maybe (IOStateArrow s b XmlTree)
  74 xml_from_contents =
  75   fmap parse_lwn
  76
  77
  78
  79 -- | Preprocessing common to both page types.
  80 preprocess :: (ArrowXml a) => a XmlTree XmlTree
  81 preprocess =
  82   make_image_srcs_absolute
  83   >>>
  84   remove_comment_links
  85   >>>
  86   replace_links_with_spans
  87
  88
  89 is_link :: (ArrowXml a) => a XmlTree XmlTree
  90 is_link =
  91   isElem >>> hasName "a"
  92
  93
  94 remove_comment_links  :: (ArrowXml a) => a XmlTree XmlTree
  95 remove_comment_links =
  96   processTopDown $ kill_comments `when` is_link
  97   where
  98     is_comment_link =
  99       hasAttrValue "href" (contains "#Comments")
 100
 101     kill_comments =
 102       none `when` is_comment_link
 103
 104 replace_links_with_spans :: (ArrowXml a) => a XmlTree XmlTree
 105 replace_links_with_spans =
 106   processTopDown $ (make_span >>> remove_attrs) `when` is_link
 107   where
 108     make_span    = setElemName $ mkName "span"
 109     remove_attrs = processAttrl none
 110
 111
 112 is_title :: (ArrowXml a) => a XmlTree XmlTree
 113 is_title =
 114   (hasName "h2")
 115   >>>
 116   (hasAttrValue "class" (== "SummaryHL"))
 117
 118
 119 is_byline :: (ArrowXml a) => a XmlTree XmlTree
 120 is_byline =
 121   (hasName "div")
 122   >>>
 123   (hasAttrValue "class" (== "FeatureByLine"))
 124
 125
 126 is_image :: (ArrowXml a) => a XmlTree XmlTree
 127 is_image = isElem >>> hasName "img"
 128
 129 remove_title :: (ArrowXml a) => a XmlTree XmlTree
 130 remove_title =
 131   processTopDown ((none) `when` is_title)
 132
 133
 134 remove_byline :: (ArrowXml a) => a XmlTree XmlTree
 135 remove_byline =
 136   processTopDown ((none) `when` is_byline)
 137
 138
 139 image_srcs :: (ArrowXml a) => a XmlTree URL
 140 image_srcs =
 141   css "img"
 142   >>>
 143   getAttrValue "src"
 144
 145
 146 full_story_paragraph :: (ArrowXml a) => a XmlTree XmlTree
 147 full_story_paragraph =
 148   isElem
 149   >>>
 150   hasName "p"
 151   >>>
 152   ifA
 153     (this /> full_story_link)
 154     this
 155     none
 156
 157
 158 -- Without regard to the parent paragraph.
 159 full_story_link :: (ArrowXml a) => a XmlTree XmlTree
 160 full_story_link =
 161   isElem
 162   >>>
 163   hasName "a"
 164   >>>
 165   ifA
 166     (this /> hasText (=~ "Full Story"))
 167     this
 168     none
 169
 170
 171 -- | Get the hrefs of all full story links.
 172 full_story_urls :: (ArrowXml a) => a XmlTree URL
 173 full_story_urls =
 174   deep $
 175   full_story_paragraph
 176   />
 177   full_story_link
 178   >>>
 179   getAttrValue "href"
 180
 181
 182
 183 make_image_srcs_absolute :: (ArrowXml a) => a XmlTree XmlTree
 184 make_image_srcs_absolute =
 185   processTopDown (make_srcs_absolute `when` is_image)
 186   where
 187     change_src :: (ArrowXml a) => a XmlTree XmlTree
 188     change_src =
 189       changeAttrValue try_make_absolute_url
 190
 191     make_srcs_absolute :: (ArrowXml a) => a XmlTree XmlTree
 192     make_srcs_absolute =
 193       processAttrl $ change_src `when` hasName "src"