[Split project into some more modules Manuel M T Chakravarty **20060426192428] { addfile ./Date.hs addfile ./Error.hs addfile ./Feed.hs addfile ./Stanza.hs hunk ./Date.hs 1 +-- |A simple feed generator: Date utilities +-- +-- Copyright (c) 2006 Manuel M T Chakravarty +-- +-- License: +-- +--- Description --------------------------------------------------------------- +-- +-- Language: Haskell 98 +-- + +module Date ( + Date(..), parseDate, +) where + +-- hierachical libraries +-- + +import Control.Monad ( + liftM) + +import Data.Char ( + isDigit, digitToInt) + +import System.Locale ( + TimeLocale(..), defaultTimeLocale, rfc822DateFormat) +import System.Time ( + Month(..), ClockTime, CalendarTime(..), toUTCTime, toClockTime, + formatCalendarTime) + + +-- We convert all dates into an internal representation for storage and +-- comparison. All I/O uses the RFC822 format as required by the RSS 2.0 +-- specification. +-- +newtype Date = Date ClockTime + +instance Eq Date where + Date d1 == Date d2 = d1 == d2 + +instance Ord Date where + compare (Date d1) (Date d2) = compare d1 d2 + +instance Show Date where + show (Date d) = + formatCalendarTime defaultTimeLocale rfc822DateFormat (toUTCTime d) + +-- Parse an RFC822 date string (but allowing four digits for years and also +-- UTC, in addition to UT) +-- +-- * Cf +-- +parseDate :: String -> Maybe Date +parseDate = liftM Date . parseDay + where + parseDay (_:_:_:',':' ':noWDay) = parseDay noWDay -- drop weekday + parseDay (d1 :' ':monthEtc) -- 1 digit day + | isDigit d1 = parseMonth (convDay '0' d1 ) monthEtc + parseDay (d1:d2:' ':monthEtc) -- 2 digit day + | isDigit d1 && isDigit d2 = parseMonth (convDay d1 d2) monthEtc + parseDay _ = Nothing + -- + parseMonth day (m1:m2:m3:' ':yearEtc) = + parseYear day (parseMonth' (m1:m2:m3:[])) yearEtc + -- + parseMonth' "Jan" = Just January + parseMonth' "Feb" = Just February + parseMonth' "Mar" = Just March + parseMonth' "Apr" = Just April + parseMonth' "May" = Just May + parseMonth' "Jun" = Just June + parseMonth' "Jul" = Just July + parseMonth' "Aug" = Just August + parseMonth' "Sep" = Just September + parseMonth' "Oct" = Just October + parseMonth' "Nov" = Just November + parseMonth' "Dec" = Just December + parseMonth' _ = Nothing + -- + parseYear day mons (y1:y2 :' ':timeStr) -- 2 digit year + | isDigit y1 && isDigit y2 = + convert day mons (convYear Nothing y1 y2) (parseTime timeStr) + parseYear day mons (y1:y2:y3:y4:' ':timeStr) -- 4 digit year + | isDigit y1 && isDigit y2 && isDigit y3 && isDigit y4 = + convert day mons (convYear (Just (y1, y2)) y3 y4) (parseTime timeStr) + parseYear _ _ _ = Nothing + -- + parseTime (h1:h2:':':m1:m2:':':s1:s2:' ':zoneStr) -- w/ seconds + | isDigit h1 && isDigit h2 && isDigit m1 && isDigit m2 && + isDigit s1 && isDigit s2 = + do + hour <- convHour h1 h2 + mins <- convMins m1 m2 + secs <- convSecs s1 s2 + zone <- parseZone zoneStr + return $ (hour, mins, secs, zone) + parseTime (h1:h2:':':m1:m2 :' ':zoneStr) -- w/o seconds + | isDigit h1 && isDigit h2 && isDigit m1 && isDigit m2 = + do + hour <- convHour h1 h2 + mins <- convMins m1 m2 + let secs = 0 + zone <- parseZone zoneStr + return (hour, mins, secs, zone) + parseTime _ = Nothing + -- + convYear Nothing y1 y2 | 70 <= year = Just $ 1900 + year + | otherwise = Just $ 2000 + year + where year = digitToInt y1 * 10 + + digitToInt y2 + convYear (Just (y1, y2)) y3 y4 = Just $ digitToInt y1 * 1000 + + digitToInt y2 * 100 + + digitToInt y3 * 10 + + digitToInt y4 + convDay d1 d2 | 1 <= day && day <= 31 = Just day + | otherwise = Nothing + where day = digitToInt d1 * 10 + digitToInt d2 + convHour h1 h2 | 0 <= hour && hour <= 23 = Just hour + | otherwise = Nothing + where hour = digitToInt h1 * 10 + digitToInt h2 + convMins m1 m2 | 0 <= mins && mins <= 59 = Just mins + | otherwise = Nothing + where mins = digitToInt m1 * 10 + digitToInt m2 + convSecs s1 s2 | 0 <= secs && secs <= 59 = Just secs + | otherwise = Nothing + where secs = digitToInt s1 * 10 + digitToInt s2 + -- + parseZone :: String -> Maybe Int + parseZone "UT" = Just 0 + parseZone "UTC" = Just 0 + parseZone "GMT" = Just 0 + parseZone "EST" = Just (hourToSecs (-5)) + parseZone "EDT" = Just (hourToSecs (-4)) + parseZone "CST" = Just (hourToSecs (-6)) + parseZone "CDT" = Just (hourToSecs (-5)) + parseZone "MST" = Just (hourToSecs (-7)) + parseZone "MDT" = Just (hourToSecs (-6)) + parseZone "PST" = Just (hourToSecs (-8)) + parseZone "PDT" = Just (hourToSecs (-7)) + parseZone "Z" = Just 0 + parseZone "A" = Just (hourToSecs (-1)) + parseZone "B" = Just (hourToSecs (-2)) + parseZone "C" = Just (hourToSecs (-3)) + parseZone "D" = Just (hourToSecs (-4)) + parseZone "E" = Just (hourToSecs (-5)) + parseZone "F" = Just (hourToSecs (-6)) + parseZone "G" = Just (hourToSecs (-7)) + parseZone "H" = Just (hourToSecs (-8)) + parseZone "I" = Just (hourToSecs (-9)) + parseZone "K" = Just (hourToSecs (-10)) + parseZone "L" = Just (hourToSecs (-11)) + parseZone "M" = Just (hourToSecs (-12)) + parseZone "N" = Just (hourToSecs 1) + parseZone "O" = Just (hourToSecs 2) + parseZone "P" = Just (hourToSecs 3) + parseZone "Q" = Just (hourToSecs 4) + parseZone "R" = Just (hourToSecs 5) + parseZone "S" = Just (hourToSecs 6) + parseZone "T" = Just (hourToSecs 7) + parseZone "U" = Just (hourToSecs 8) + parseZone "V" = Just (hourToSecs 9) + parseZone "W" = Just (hourToSecs 10) + parseZone "X" = Just (hourToSecs 11) + parseZone "Y" = Just (hourToSecs 12) + parseZone ('+':hhmm) = parseDiff 1 hhmm + parseZone ('-':hhmm) = parseDiff (-1) hhmm + parseZone _ = Nothing + -- + parseDiff :: Int -> String -> Maybe Int + parseDiff sign (h1:h2:m1:m2:[]) = + do + hour <- convHour h1 h2 + mins <- convMins m1 m2 + return $ sign * (hour * 60 + mins) * 60 + -- + hourToSecs hour = hour * 60 * 60 + -- + convert day mons year time = + do + day' <- day + mons' <- mons + year' <- year + (hour, mins, secs, zone) <- time + return $ toClockTime $ CalendarTime { + ctYear = year', + ctMonth = mons', + ctDay = day' , + ctHour = hour , + ctMin = mins , + ctSec = secs , + ctPicosec = 0 , + ctTZ = zone + } hunk ./Error.hs 1 +-- |A simple feed generator: Error handling +-- +-- Copyright (c) 2006 Manuel M T Chakravarty +-- +-- License: +-- +--- Description --------------------------------------------------------------- +-- +-- Language: Haskell 98 +-- + +module Error ( + elementErrStr, abortWith +) where + +-- Produce an error message for a given source, line range, and custom error +-- message. +-- +elementErrStr :: String -> (Int, Int) -> String -> String +elementErrStr sname (start, end) err = + sname ++ ":" ++ show start ++ "-" ++ show end ++": " ++ err + +-- Terminate with a set of errors (in pure code). +-- +abortWith :: [String] -> a +abortWith = error . ("FATAL ERROR" ++) . concat . map ('\n':) + + hunk ./Feed.hs 1 +-- |A simple feed generator: Feed data structure +-- +-- Copyright (c) 2006 Manuel M T Chakravarty +-- +-- License: +-- +--- Description --------------------------------------------------------------- +-- +-- Language: Haskell 98 +-- + +module Feed ( + + -- * Internal representation of feeds + URL, Feed(..), Channel(..), Image(..), Category(..), Item(..), + Enclosure(..), GUID(..), Source(..), + + -- * Copying of non-parametric components of channels + copyChannelInfo, + + -- * Default values for all feed sub-structures + defaultChannel, defaultImage, defaultCategory, defaultItem, + defaultEnclosure, defaultGUID, defaultSource + +) where + +-- lambdaFeed +import Date ( + Date) + + +-- Feed data structure (following RSS 2.0.1 (rv 6)) +-- ------------------- + +-- URL data type +-- +type URL = String + +-- A feed consists of a set of channels. +-- +data Feed items = Feed [Channel items] + deriving Show + +-- Channel description +-- +data Channel items = + Channel { + titleChan :: String, + linkChan :: URL, + descriptionChan :: String, + languageChan :: Maybe String, + copyrightChan :: Maybe String, + managingEditorChan :: Maybe String, + webMasterChan :: Maybe String, + pubDateChan :: Maybe Date, + lastBuildDateChan :: Maybe Date, + categoryChan :: [Category], -- may be empty + generatorChan :: Maybe String, + docsChan :: Maybe URL, + cloudChan :: (), + ttlChan :: Maybe Int, -- in minutes + imageChan :: Maybe Image, + ratingChan :: (), + textInputChan :: (), + skipHoursChan :: (), + skipDaysChan :: (), + itemsChan :: items + } + deriving Show + +-- Inline image +-- +data Image = Image { + urlImage :: URL, + titleImage :: String, + linkImage :: URL, + widthImage :: Maybe Int, + heightImage :: Maybe Int, + descriptionImage :: Maybe String + } + deriving Show + +-- Generic categorisation information +-- +data Category = Category { + categoryCategory :: String, + domainCategory :: Maybe String + } + deriving Show + +-- Feed item +-- +-- * Either `titleItem' or `descriptionItem' must be present. +-- +data Item = Item { + titleItem :: Maybe String, + linkItem :: Maybe URL, + descriptionItem :: Maybe String, + authorItem :: Maybe String, -- email of author + categoryItem :: [Category], -- may be empty + commentsItem :: Maybe URL, + enclosureItem :: Maybe Enclosure, + guidItem :: Maybe GUID, + pubDateItem :: Maybe Date, + sourceItem :: Maybe Source + } + deriving Show + +-- Inline media content +-- +data Enclosure = Enclosure { + urlEnclosure :: URL, + lengthEnclosure :: Int, -- in bytes + typeEnclosure :: String + } + deriving Show + +-- Global identification +-- +data GUID = GUID { + guidGUID :: String, + isPermaLinkGUID :: Maybe Bool + } + deriving Show + +-- Item source +-- +data Source = Source { + sourceSource :: String, + urlSource :: URL + } + deriving Show + +-- Copies all components of a channel structure except `itemsChan'. +-- +copyChannelInfo :: Channel a -> Channel b +copyChannelInfo chan = + Channel { + titleChan = titleChan chan, + linkChan = linkChan chan, + descriptionChan = descriptionChan chan, + languageChan = languageChan chan, + copyrightChan = copyrightChan chan, + managingEditorChan = managingEditorChan chan, + webMasterChan = webMasterChan chan, + pubDateChan = pubDateChan chan, + lastBuildDateChan = lastBuildDateChan chan, + categoryChan = categoryChan chan, + generatorChan = generatorChan chan, + docsChan = docsChan chan, + cloudChan = cloudChan chan, + ttlChan = ttlChan chan, + imageChan = imageChan chan, + ratingChan = ratingChan chan, + textInputChan = textInputChan chan, + skipHoursChan = skipHoursChan chan, + skipDaysChan = skipDaysChan chan, + itemsChan = error "channel missing items (after copy)" + } + +-- Channel value with default components. +-- +defaultChannel :: Channel items +defaultChannel = Channel { + titleChan = error "channel missing title", + linkChan = error "channel missing link", + descriptionChan = error "channel missing description", + languageChan = Nothing, + copyrightChan = Nothing, + managingEditorChan = Nothing, + webMasterChan = Nothing, + pubDateChan = Nothing, + lastBuildDateChan = Nothing, + categoryChan = [], + generatorChan = Nothing, + docsChan = Nothing, + cloudChan = (), + ttlChan = Nothing, + imageChan = Nothing, + ratingChan = (), + textInputChan = (), + skipHoursChan = (), + skipDaysChan = (), + itemsChan = error "channel missing items" + } + +-- Image value with default components. +-- +defaultImage :: Image +defaultImage = Image { + urlImage = error "image missing url", + titleImage = error "image missing title", + linkImage = error "image missing link", + widthImage = Nothing, + heightImage = Nothing, + descriptionImage = Nothing + } + +-- Category value with default components.. +-- +defaultCategory :: Category +defaultCategory = Category { + categoryCategory = error "category missing category", + domainCategory = Nothing + } + +-- Items value with default components. +-- +defaultItem :: Item +defaultItem = Item { + titleItem = Nothing, + linkItem = Nothing, + descriptionItem = Nothing, + authorItem = Nothing, + categoryItem = [], + commentsItem = Nothing, + enclosureItem = Nothing, + guidItem = Nothing, + pubDateItem = Nothing, + sourceItem = Nothing + } + +-- Enclosure value with default components.. +-- +defaultEnclosure :: Enclosure +defaultEnclosure = Enclosure { + urlEnclosure = error "enclosure missing url", + lengthEnclosure = error "enclosure missing length", + typeEnclosure = error "enclosure missing type" + } + +-- GUID value with default components.. +-- +defaultGUID :: GUID +defaultGUID = GUID { + guidGUID = error "guid missing guid", + isPermaLinkGUID = Nothing + } + +-- GUID value with default components.. +-- +defaultSource :: Source +defaultSource = Source { + sourceSource = error "source missing source", + urlSource = error "source missing url" + } hunk ./LambdaFeed.hs 77 +-- hierachical libraries +-- + hunk ./LambdaFeed.hs 84 - isDigit, digitToInt, isSpace, toLower) -import Data.List ( - (\\)) + isDigit, toLower) hunk ./LambdaFeed.hs 98 -import System.Locale ( - TimeLocale(..), defaultTimeLocale, rfc822DateFormat) hunk ./LambdaFeed.hs 99 - Month(..), ClockTime, CalendarTime(..), getClockTime, toUTCTime, toClockTime, - formatCalendarTime) + ClockTime, getClockTime) + +-- lambdaFeed +import Date ( + Date(..), parseDate) +import Error ( + elementErrStr, abortWith) +import Feed ( + URL, Feed(..), Channel(..), Image(..), Category(..), Item(..), + Enclosure(..), GUID(..), Source(..), + copyChannelInfo, defaultChannel, defaultImage, defaultCategory, defaultItem, + defaultEnclosure, defaultGUID, defaultSource) +import Stanza ( + Stanza, StanzaAssoc, readStanzas, + StanzaProcessor, Proc(..), Action(..), parseStanzas) hunk ./LambdaFeed.hs 122 -date = "25 Apr 2006" +date = "26 Apr 2006" hunk ./LambdaFeed.hs 245 --- Date information --- ---------------- - --- We convert all dates into an internal representation for storage and --- comparison. All I/O uses the RFC822 format as required by the RSS 2.0 --- specification. --- -newtype Date = Date ClockTime - -instance Eq Date where - Date d1 == Date d2 = d1 == d2 - -instance Ord Date where - compare (Date d1) (Date d2) = compare d1 d2 - -instance Show Date where - show (Date d) = - formatCalendarTime defaultTimeLocale rfc822DateFormat (toUTCTime d) - --- Parse an RFC822 date string (but allowing four digits for years and also --- UTC, in addition to UT) --- --- * Cf --- -parseDate :: String -> Maybe Date -parseDate = liftM Date . parseDay - where - parseDay (_:_:_:',':' ':noWDay) = parseDay noWDay -- drop weekday - parseDay (d1 :' ':monthEtc) -- 1 digit day - | isDigit d1 = parseMonth (convDay '0' d1 ) monthEtc - parseDay (d1:d2:' ':monthEtc) -- 2 digit day - | isDigit d1 && isDigit d2 = parseMonth (convDay d1 d2) monthEtc - parseDay _ = Nothing - -- - parseMonth day (m1:m2:m3:' ':yearEtc) = - parseYear day (parseMonth' (m1:m2:m3:[])) yearEtc - -- - parseMonth' "Jan" = Just January - parseMonth' "Feb" = Just February - parseMonth' "Mar" = Just March - parseMonth' "Apr" = Just April - parseMonth' "May" = Just May - parseMonth' "Jun" = Just June - parseMonth' "Jul" = Just July - parseMonth' "Aug" = Just August - parseMonth' "Sep" = Just September - parseMonth' "Oct" = Just October - parseMonth' "Nov" = Just November - parseMonth' "Dec" = Just December - parseMonth' _ = Nothing - -- - parseYear day mons (y1:y2 :' ':timeStr) -- 2 digit year - | isDigit y1 && isDigit y2 = - convert day mons (convYear Nothing y1 y2) (parseTime timeStr) - parseYear day mons (y1:y2:y3:y4:' ':timeStr) -- 4 digit year - | isDigit y1 && isDigit y2 && isDigit y3 && isDigit y4 = - convert day mons (convYear (Just (y1, y2)) y3 y4) (parseTime timeStr) - parseYear _ _ _ = Nothing - -- - parseTime (h1:h2:':':m1:m2:':':s1:s2:' ':zoneStr) -- w/ seconds - | isDigit h1 && isDigit h2 && isDigit m1 && isDigit m2 && - isDigit s1 && isDigit s2 = - do - hour <- convHour h1 h2 - mins <- convMins m1 m2 - secs <- convSecs s1 s2 - zone <- parseZone zoneStr - return $ (hour, mins, secs, zone) - parseTime (h1:h2:':':m1:m2 :' ':zoneStr) -- w/o seconds - | isDigit h1 && isDigit h2 && isDigit m1 && isDigit m2 = - do - hour <- convHour h1 h2 - mins <- convMins m1 m2 - let secs = 0 - zone <- parseZone zoneStr - return (hour, mins, secs, zone) - parseTime _ = Nothing - -- - convYear Nothing y1 y2 | 70 <= year = Just $ 1900 + year - | otherwise = Just $ 2000 + year - where year = digitToInt y1 * 10 + - digitToInt y2 - convYear (Just (y1, y2)) y3 y4 = Just $ digitToInt y1 * 1000 + - digitToInt y2 * 100 + - digitToInt y3 * 10 + - digitToInt y4 - convDay d1 d2 | 1 <= day && day <= 31 = Just day - | otherwise = Nothing - where day = digitToInt d1 * 10 + digitToInt d2 - convHour h1 h2 | 0 <= hour && hour <= 23 = Just hour - | otherwise = Nothing - where hour = digitToInt h1 * 10 + digitToInt h2 - convMins m1 m2 | 0 <= mins && mins <= 59 = Just mins - | otherwise = Nothing - where mins = digitToInt m1 * 10 + digitToInt m2 - convSecs s1 s2 | 0 <= secs && secs <= 59 = Just secs - | otherwise = Nothing - where secs = digitToInt s1 * 10 + digitToInt s2 - -- - parseZone :: String -> Maybe Int - parseZone "UT" = Just 0 - parseZone "UTC" = Just 0 - parseZone "GMT" = Just 0 - parseZone "EST" = Just (hourToSecs (-5)) - parseZone "EDT" = Just (hourToSecs (-4)) - parseZone "CST" = Just (hourToSecs (-6)) - parseZone "CDT" = Just (hourToSecs (-5)) - parseZone "MST" = Just (hourToSecs (-7)) - parseZone "MDT" = Just (hourToSecs (-6)) - parseZone "PST" = Just (hourToSecs (-8)) - parseZone "PDT" = Just (hourToSecs (-7)) - parseZone "Z" = Just 0 - parseZone "A" = Just (hourToSecs (-1)) - parseZone "B" = Just (hourToSecs (-2)) - parseZone "C" = Just (hourToSecs (-3)) - parseZone "D" = Just (hourToSecs (-4)) - parseZone "E" = Just (hourToSecs (-5)) - parseZone "F" = Just (hourToSecs (-6)) - parseZone "G" = Just (hourToSecs (-7)) - parseZone "H" = Just (hourToSecs (-8)) - parseZone "I" = Just (hourToSecs (-9)) - parseZone "K" = Just (hourToSecs (-10)) - parseZone "L" = Just (hourToSecs (-11)) - parseZone "M" = Just (hourToSecs (-12)) - parseZone "N" = Just (hourToSecs 1) - parseZone "O" = Just (hourToSecs 2) - parseZone "P" = Just (hourToSecs 3) - parseZone "Q" = Just (hourToSecs 4) - parseZone "R" = Just (hourToSecs 5) - parseZone "S" = Just (hourToSecs 6) - parseZone "T" = Just (hourToSecs 7) - parseZone "U" = Just (hourToSecs 8) - parseZone "V" = Just (hourToSecs 9) - parseZone "W" = Just (hourToSecs 10) - parseZone "X" = Just (hourToSecs 11) - parseZone "Y" = Just (hourToSecs 12) - parseZone ('+':hhmm) = parseDiff 1 hhmm - parseZone ('-':hhmm) = parseDiff (-1) hhmm - parseZone _ = Nothing - -- - parseDiff :: Int -> String -> Maybe Int - parseDiff sign (h1:h2:m1:m2:[]) = - do - hour <- convHour h1 h2 - mins <- convMins m1 m2 - return $ sign * (hour * 60 + mins) * 60 - -- - hourToSecs hour = hour * 60 * 60 - -- - convert day mons year time = - do - day' <- day - mons' <- mons - year' <- year - (hour, mins, secs, zone) <- time - return $ toClockTime $ CalendarTime { - ctYear = year', - ctMonth = mons', - ctDay = day' , - ctHour = hour , - ctMin = mins , - ctSec = secs , - ctPicosec = 0 , - ctTZ = zone - } - - --- Feed data structure (following after RSS 2.0.1 (rv 6)) --- ------------------- - --- URL data type --- -type URL = String - --- A feed consists of a set of channels. --- -data Feed items = Feed [Channel items] - deriving Show - --- Channel description --- -data Channel items = - Channel { - titleChan :: String, - linkChan :: URL, - descriptionChan :: String, - languageChan :: Maybe String, - copyrightChan :: Maybe String, - managingEditorChan :: Maybe String, - webMasterChan :: Maybe String, - pubDateChan :: Maybe Date, - lastBuildDateChan :: Maybe Date, - categoryChan :: [Category], -- may be empty - generatorChan :: Maybe String, - docsChan :: Maybe URL, - cloudChan :: (), - ttlChan :: Maybe Int, -- in minutes - imageChan :: Maybe Image, - ratingChan :: (), - textInputChan :: (), - skipHoursChan :: (), - skipDaysChan :: (), - itemsChan :: items - } - deriving Show - --- Inline image --- -data Image = Image { - urlImage :: URL, - titleImage :: String, - linkImage :: URL, - widthImage :: Maybe Int, - heightImage :: Maybe Int, - descriptionImage :: Maybe String - } - deriving Show - --- Generic categorisation information --- -data Category = Category { - categoryCategory :: String, - domainCategory :: Maybe String - } - deriving Show - --- Feed item --- --- * Either `titleItem' or `descriptionItem' must be present. --- -data Item = Item { - titleItem :: Maybe String, - linkItem :: Maybe URL, - descriptionItem :: Maybe String, - authorItem :: Maybe String, -- email of author - categoryItem :: [Category], -- may be empty - commentsItem :: Maybe URL, - enclosureItem :: Maybe Enclosure, - guidItem :: Maybe GUID, - pubDateItem :: Maybe Date, - sourceItem :: Maybe Source - } - deriving Show - --- Inline media content --- -data Enclosure = Enclosure { - urlEnclosure :: URL, - lengthEnclosure :: Int, -- in bytes - typeEnclosure :: String - } - deriving Show - --- Global identification --- -data GUID = GUID { - guidGUID :: String, - isPermaLinkGUID :: Maybe Bool - } - deriving Show - --- Item source --- -data Source = Source { - sourceSource :: String, - urlSource :: URL - } - deriving Show - --- Copies all components of a channel structure except `itemsChan'. --- -copyChannelInfo :: Channel a -> Channel b -copyChannelInfo chan = - Channel { - titleChan = titleChan chan, - linkChan = linkChan chan, - descriptionChan = descriptionChan chan, - languageChan = languageChan chan, - copyrightChan = copyrightChan chan, - managingEditorChan = managingEditorChan chan, - webMasterChan = webMasterChan chan, - pubDateChan = pubDateChan chan, - lastBuildDateChan = lastBuildDateChan chan, - categoryChan = categoryChan chan, - generatorChan = generatorChan chan, - docsChan = docsChan chan, - cloudChan = cloudChan chan, - ttlChan = ttlChan chan, - imageChan = imageChan chan, - ratingChan = ratingChan chan, - textInputChan = textInputChan chan, - skipHoursChan = skipHoursChan chan, - skipDaysChan = skipDaysChan chan, - itemsChan = error "channel missing items (after copy)" - } - --- Channel value with default components. --- -defaultChannel :: Channel items -defaultChannel = Channel { - titleChan = error "channel missing title", - linkChan = error "channel missing link", - descriptionChan = error "channel missing description", - languageChan = Nothing, - copyrightChan = Nothing, - managingEditorChan = Nothing, - webMasterChan = Nothing, - pubDateChan = Nothing, - lastBuildDateChan = Nothing, - categoryChan = [], - generatorChan = Nothing, - docsChan = Nothing, - cloudChan = (), - ttlChan = Nothing, - imageChan = Nothing, - ratingChan = (), - textInputChan = (), - skipHoursChan = (), - skipDaysChan = (), - itemsChan = error "channel missing items" - } - --- Image value with default components. --- -defaultImage :: Image -defaultImage = Image { - urlImage = error "image missing url", - titleImage = error "image missing title", - linkImage = error "image missing link", - widthImage = Nothing, - heightImage = Nothing, - descriptionImage = Nothing - } - --- Category value with default components.. --- -defaultCategory :: Category -defaultCategory = Category { - categoryCategory = error "category missing category", - domainCategory = Nothing - } - --- Items value with default components. --- -defaultItem :: Item -defaultItem = Item { - titleItem = Nothing, - linkItem = Nothing, - descriptionItem = Nothing, - authorItem = Nothing, - categoryItem = [], - commentsItem = Nothing, - enclosureItem = Nothing, - guidItem = Nothing, - pubDateItem = Nothing, - sourceItem = Nothing - } - --- Enclosure value with default components.. --- -defaultEnclosure :: Enclosure -defaultEnclosure = Enclosure { - urlEnclosure = error "enclosure missing url", - lengthEnclosure = error "enclosure missing length", - typeEnclosure = error "enclosure missing type" - } - --- GUID value with default components.. --- -defaultGUID :: GUID -defaultGUID = GUID { - guidGUID = error "guid missing guid", - isPermaLinkGUID = Nothing - } - --- GUID value with default components.. --- -defaultSource :: Source -defaultSource = Source { - sourceSource = error "source missing source", - urlSource = error "source missing url" - } - - - hunk ./LambdaFeed.hs 671 --- Stanze file parsing --- ------------------- - --- A stanza is a list of associations, where each association comprises --- --- (1) a tag string (without the terminating colon of the textual --- representation), --- (2) a range of source file lines (containing the association in the textual --- representation), and --- (3) a value string. --- -type Stanza = [StanzaAssoc] -type StanzaAssoc = (String, (Int, Int), String) - --- Read a text file in stanza format (including line numbers for better error --- messages). --- --- * See top of file for details of the format. --- -readStanzas :: FilePath -> IO [Stanza] -readStanzas fname = - do - contents <- readFile fname - let numbered = zip [1..] (filter notComment . lines $ contents) - stanzas = splitIntoStanzas numbered - return $ map splitIntoAssocs stanzas - where - splitIntoStanzas [] = [] - splitIntoStanzas lines = - let - lines0 = dropWhile isEmptyLine lines - (stanza, lines') = break isEmptyLine lines0 - stanzas = splitIntoStanzas lines' - in - stanza:stanzas - -- - splitIntoAssocs [] = [] - splitIntoAssocs ((start, line):lines) = - let - (values, lines') = break isTagLine lines - assocs = splitIntoAssocs lines' - -- - (tag, value1) = break (== ':') line - allValues = stripColonNClean value1 : map (clean . snd) values - -- - end | null values = start - | otherwise = (fst . last) values - in - case extractTag tag of - Just rawTag -> - (rawTag, (start, end), unwords' allValues):assocs - Nothing -> malformedTagErr fname start tag - -- - extractTag "" = Nothing - extractTag tag | isSpace (head tag) = Nothing - | any isSpace cleanedTag = Nothing - | otherwise = Just cleanedTag - where cleanedTag = cleanTrailing tag - -- - notComment ('-':'-':_) = False - notComment _ = True - -- - stripColonNClean (':':str) = clean str -- strip leading colon & clean w/s - stripColonNClean str = clean str - -- - isEmptyLine = all isSpace . snd - isTagLine = not . isSpace . (!!0) . snd - -- - unwords' = dropWhile isSpace . unwords - --- Complain about a malformed tag and abort --- -malformedTagErr :: FilePath -> Int -> String -> a -malformedTagErr fname line tag = - error $ fname ++ ":" ++ show line ++ ": `" ++ cleanTrailing tag ++ - "' is not a valid tag" - --- Lose leading and trailing whitespace --- -clean :: String -> String -clean = reverse . dropWhile isSpace . reverse . dropWhile isSpace - --- Lose trailing whitespace --- -cleanTrailing :: String -> String -cleanTrailing = reverse . dropWhile isSpace . reverse - - --- Stanza processing --- ----------------- - --- Association of tag names with functions that add the associated value to --- some structure `a' (and may also return a list of error messages). --- --- * We ignore case when comparing tag names. --- -type StanzaProcessor a = [(String, Proc a)] - --- Determines whether the associated tag is required. --- -data Proc a = Proc Bool (Action a) - --- The actual processing functions come in two flavours: --- --- * Simple processors consume one stanza association. --- --- * Compound processors consume an entire stanza, where the first entry of --- the stanza is the one that triggered the processor and the others are --- attributes to that element. If they occur within a stanza, they get --- passed a singelton stanza with the one association. --- -data Action a = Simple (StanzaAssoc -> (a -> (a, [String]))) - | Compound (Stanza -> (a -> (a, [String]))) - --- Apply a stanza processor to a stanza list. --- --- * The second argument indicates the source of the stanza list and is used --- in error messages. --- --- * If required tags are missing, we inject an the error message into the --- errors produced by the transformer. As this error is fatal in some --- context, we indicate the error also by producing a transformer that --- returns constant `Nothing' in its first component. --- -parseStanzas :: StanzaProcessor a -- stanza processor for parsing - -> String -- name of stanza source - -> [Stanza] -- stanzas to parse - -> (a -> (Maybe a, [String])) --- --- The following is a two step process: --- --- (1) The stanza processor computes from the input stanza a *function* that --- when applied to a value of type `a' (usually a record) adds the --- information from the stanza to that value. --- (2) We apply the function from Step (1) to a value of type `a' (usually a --- record with default values in all components) to get the final result --- of parsing. --- -parseStanzas stanzaProc sname stanzas = \rec -> - let - (transformer, req) = processStanzas required stanzas - (results, errs) = transformer rec - in - if null req - then -- a required tags were found - (Just results, errs) - else -- some required tags were missing => no result - (Nothing, [sname ++ ": required tags missing: " ++ show req, - sname ++ ": invalidates the whole element" ] ++ errs) - where - required = [tag | (tag, Proc reqd _) <- stanzaProc, reqd] - -- - --processStanzas :: [String] -> [Stanza] -> (a -> (a, [String]), [String]) - processStanzas reqd [] = (idNil, reqd) - processStanzas reqd ([] :stanzas) = - processStanzas reqd stanzas - processStanzas reqd (stanza@((tag, range, _):_):stanzas) = - let - (trans1, reqd1) = - case lookup (map toLower tag) stanzaProc of - Just (Proc _ (Simple _ )) -> processAssocs reqd stanza - Just (Proc _ (Compound act)) -> (act stanza, reqd \| tag) - Nothing -> (addError (unknownTag range tag), - reqd) - (trans2, reqd2) = processStanzas reqd1 stanzas - in - (trans2 .++ trans1, reqd2) - -- - --processAssocs :: [String] -> Stanza -> (a -> (a, [String]), [String]) - processAssocs reqd [] = (idNil, reqd) - processAssocs reqd (assoc@(tag, range, _):assocs) = - let - (trans1, reqd1) = - case lookup (map toLower tag) stanzaProc of - Just (Proc _ (Simple act)) -> (act assoc , reqd \| tag) - Just (Proc _ (Compound act)) -> (act [assoc], reqd \| tag) - Nothing -> (addError (unknownTag range tag), - reqd) - (trans2, reqd2) = processAssocs reqd1 assocs - in - (trans2 .++ trans1, reqd2) - -- - idNil = \a -> (a, []) - f1 .++ f2 = \a -> - let (a1, e1) = f1 a; (a2, e2) = f2 a1 in (a2, e1 ++ e2) - -- - l \| tag = l \\ [map toLower tag] - -- - addError err = \a -> (a, [err]) - -- - unknownTag range tag = elementErrStr sname range $ - "unknown tag `" ++ tag ++ "' (ignoring)" - --- Raise an error for a given source, line range, and custom error message. --- -elementErrStr :: String -> (Int, Int) -> String -> String -elementErrStr sname (start, end) err = - sname ++ ":" ++ show start ++ "-" ++ show end ++": " ++ err - - hunk ./LambdaFeed.hs 716 - --- Error handling --- -------------- - --- Terminate with a set of errors (in pure code). --- -abortWith :: [String] -> a -abortWith = error . ("FATAL ERROR" ++) . concat . map ('\n':) - hunk ./Stanza.hs 1 +-- |A simple feed generator: Stanza reading and parsing +-- +-- Copyright (c) 2006 Manuel M T Chakravarty +-- +-- License: +-- +--- Description --------------------------------------------------------------- +-- +-- Language: Haskell 98 +-- + +module Stanza ( + + -- * Stanza structure + Stanza, StanzaAssoc, + + -- * Stanza reading + readStanzas, + + -- * Stanza processors + StanzaProcessor, Proc(..), Action(..), + + -- * Stanza parsing + parseStanzas + +) where + +-- hierachical libraries +-- +import Data.Char ( + isDigit, isSpace, toLower) +import Data.List ( + (\\)) + +-- lambdaFeed +import Error ( + elementErrStr) + + +-- Stanze file parsing +-- ------------------- + +-- A stanza is a list of associations, where each association comprises +-- +-- (1) a tag string (without the terminating colon of the textual +-- representation), +-- (2) a range of source file lines (containing the association in the textual +-- representation), and +-- (3) a value string. +-- +type Stanza = [StanzaAssoc] +type StanzaAssoc = (String, (Int, Int), String) + +-- Read a text file in stanza format (including line numbers for better error +-- messages). +-- +-- * See top of file for details of the format. +-- +readStanzas :: FilePath -> IO [Stanza] +readStanzas fname = + do + contents <- readFile fname + let numbered = zip [1..] (filter notComment . lines $ contents) + stanzas = splitIntoStanzas numbered + return $ map splitIntoAssocs stanzas + where + splitIntoStanzas [] = [] + splitIntoStanzas lines = + let + lines0 = dropWhile isEmptyLine lines + (stanza, lines') = break isEmptyLine lines0 + stanzas = splitIntoStanzas lines' + in + stanza:stanzas + -- + splitIntoAssocs [] = [] + splitIntoAssocs ((start, line):lines) = + let + (values, lines') = break isTagLine lines + assocs = splitIntoAssocs lines' + -- + (tag, value1) = break (== ':') line + allValues = stripColonNClean value1 : map (clean . snd) values + -- + end | null values = start + | otherwise = (fst . last) values + in + case extractTag tag of + Just rawTag -> + (rawTag, (start, end), unwords' allValues):assocs + Nothing -> malformedTagErr fname start tag + -- + extractTag "" = Nothing + extractTag tag | isSpace (head tag) = Nothing + | any isSpace cleanedTag = Nothing + | otherwise = Just cleanedTag + where cleanedTag = cleanTrailing tag + -- + notComment ('-':'-':_) = False + notComment _ = True + -- + stripColonNClean (':':str) = clean str -- strip leading colon & clean w/s + stripColonNClean str = clean str + -- + isEmptyLine = all isSpace . snd + isTagLine = not . isSpace . (!!0) . snd + -- + unwords' = dropWhile isSpace . unwords + +-- Complain about a malformed tag and abort +-- +malformedTagErr :: FilePath -> Int -> String -> a +malformedTagErr fname line tag = + error $ fname ++ ":" ++ show line ++ ": `" ++ cleanTrailing tag ++ + "' is not a valid tag" + +-- Lose leading and trailing whitespace +-- +clean :: String -> String +clean = reverse . dropWhile isSpace . reverse . dropWhile isSpace + +-- Lose trailing whitespace +-- +cleanTrailing :: String -> String +cleanTrailing = reverse . dropWhile isSpace . reverse + + +-- Stanza processing +-- ----------------- + +-- Association of tag names with functions that add the associated value to +-- some structure `a' (and may also return a list of error messages). +-- +-- * We ignore case when comparing tag names. +-- +type StanzaProcessor a = [(String, Proc a)] + +-- Determines whether the associated tag is required. +-- +data Proc a = Proc Bool (Action a) + +-- The actual processing functions come in two flavours: +-- +-- * Simple processors consume one stanza association. +-- +-- * Compound processors consume an entire stanza, where the first entry of +-- the stanza is the one that triggered the processor and the others are +-- attributes to that element. If they occur within a stanza, they get +-- passed a singelton stanza with the one association. +-- +data Action a = Simple (StanzaAssoc -> (a -> (a, [String]))) + | Compound (Stanza -> (a -> (a, [String]))) + +-- Apply a stanza processor to a stanza list. +-- +-- * The second argument indicates the source of the stanza list and is used +-- in error messages. +-- +-- * If required tags are missing, we inject an the error message into the +-- errors produced by the transformer. As this error is fatal in some +-- context, we indicate the error also by producing a transformer that +-- returns constant `Nothing' in its first component. +-- +parseStanzas :: StanzaProcessor a -- stanza processor for parsing + -> String -- name of stanza source + -> [Stanza] -- stanzas to parse + -> (a -> (Maybe a, [String])) +-- +-- The following is a two step process: +-- +-- (1) The stanza processor computes from the input stanza a *function* that +-- when applied to a value of type `a' (usually a record) adds the +-- information from the stanza to that value. +-- (2) We apply the function from Step (1) to a value of type `a' (usually a +-- record with default values in all components) to get the final result +-- of parsing. +-- +parseStanzas stanzaProc sname stanzas = \rec -> + let + (transformer, req) = processStanzas required stanzas + (results, errs) = transformer rec + in + if null req + then -- a required tags were found + (Just results, errs) + else -- some required tags were missing => no result + (Nothing, [sname ++ ": required tags missing: " ++ show req, + sname ++ ": invalidates the whole element" ] ++ errs) + where + required = [tag | (tag, Proc reqd _) <- stanzaProc, reqd] + -- + --processStanzas :: [String] -> [Stanza] -> (a -> (a, [String]), [String]) + processStanzas reqd [] = (idNil, reqd) + processStanzas reqd ([] :stanzas) = + processStanzas reqd stanzas + processStanzas reqd (stanza@((tag, range, _):_):stanzas) = + let + (trans1, reqd1) = + case lookup (map toLower tag) stanzaProc of + Just (Proc _ (Simple _ )) -> processAssocs reqd stanza + Just (Proc _ (Compound act)) -> (act stanza, reqd \| tag) + Nothing -> (addError (unknownTag range tag), + reqd) + (trans2, reqd2) = processStanzas reqd1 stanzas + in + (trans2 .++ trans1, reqd2) + -- + --processAssocs :: [String] -> Stanza -> (a -> (a, [String]), [String]) + processAssocs reqd [] = (idNil, reqd) + processAssocs reqd (assoc@(tag, range, _):assocs) = + let + (trans1, reqd1) = + case lookup (map toLower tag) stanzaProc of + Just (Proc _ (Simple act)) -> (act assoc , reqd \| tag) + Just (Proc _ (Compound act)) -> (act [assoc], reqd \| tag) + Nothing -> (addError (unknownTag range tag), + reqd) + (trans2, reqd2) = processAssocs reqd1 assocs + in + (trans2 .++ trans1, reqd2) + -- + idNil = \a -> (a, []) + f1 .++ f2 = \a -> + let (a1, e1) = f1 a; (a2, e2) = f2 a1 in (a2, e1 ++ e2) + -- + l \| tag = l \\ [map toLower tag] + -- + addError err = \a -> (a, [err]) + -- + unknownTag range tag = elementErrStr sname range $ + "unknown tag `" ++ tag ++ "' (ignoring)" }