-- |A simple feed generator: Stanza reading and parsing
--
-- Copyright (c) 2006 Manuel M T Chakravarty
--
-- License: <http://www.gnu.org/licenses/gpl.html>
--
--- 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)"