[Stanza parser
Manuel M T Chakravarty <chak@cse.unsw.edu.au>**20060424051015] {
hunk ./LambdaFeed.hs 50
+--  Elements that have attributes need to be in a stanza of their own.  The
+--  element tag must be the tag of the first line of the stanze.  All other
+--  lines must be attribute tags of that element.
+--
+--  Moreover, we have an extra tag in channel descriptors:
+--
+--  `location'	   : required element giving the filename of a directory with
+--		     the channel's items
+--
hunk ./LambdaFeed.hs 80
+import Data.List (
+  (\\))
+
hunk ./LambdaFeed.hs 552
--- File operations
--- ---------------
+-- Stanze file parsing
+-- -------------------
hunk ./LambdaFeed.hs 563
-type Stanza = [(String, (Int, Int), String)]
+type Stanza      = [StanzaAssoc]
+type StanzaAssoc = (String, (Int, Int), String)
hunk ./LambdaFeed.hs 639
+
+-- Stanza processing
+-- -----------------
+
+-- Association of tag names with functions that add the associated value to
+-- some structure `a'.
+--
+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))
+	      | Compound (Stanza      -> (a -> a))
+
+-- Apply a stanza processor to a stanza list.
+--
+-- * The string indicates the source of the stanza list and is used in error
+--   messages.
+--
+parseStanzas :: String -> StanzaProcessor a -> [Stanza] -> (a -> a)
+parseStanzas sname stanzaProc stanzas = 
+  case processStanzas required stanzas of
+    (transformer, [] ) -> transformer
+    (_          , req) -> 
+      error $ sname ++ ": required tags missing: " ++ show req
+  where
+    required = [tag | (tag, Proc reqd _) <- stanzaProc, reqd]
+    --
+    processStanzas reqd []                                   = (id, reqd)
+    processStanzas reqd (stanza@((tag, range, _):_):stanzas) =
+      let
+        (trans1, reqd1) = 
+	  case lookup tag stanzaProc of
+	    Just (Proc _ (Simple   _  )) -> processAssocs reqd stanza
+	    Just (Proc _ (Compound act)) -> (act stanza, reqd \\ [tag])
+	    Nothing                      -> unknownTag range tag
+        (trans2, reqd2) = processStanzas reqd1 stanzas
+      in
+      (trans2 . trans1, reqd2)
+    -- 
+    processAssocs reqd []                             = (id, reqd)
+    processAssocs reqd (assoc@(tag, range, _):assocs) =
+      let
+        (trans1, reqd1) =
+	  case lookup tag stanzaProc of
+	    Just (Proc _ (Simple   act)) -> (act assoc  , reqd \\ [tag])
+	    Just (Proc _ (Compound act)) -> (act [assoc], reqd \\ [tag])
+	    Nothing                      -> unknownTag range tag
+        (trans2, reqd2) = processAssocs reqd1 assocs
+      in
+      (trans2 . trans1, reqd2)
+    --
+    unknownTag range tag = elementErr sname range $ 
+			     "unknown tag `" ++ tag ++ "'"
+
+-- Raise an error for a given source, line range, and custom error message.
+--
+elementErr :: String -> (Int, Int) -> String -> a
+elementErr sname (start, end) err =
+  error $ sname ++ ":" ++ show start ++ "-" ++ show end ++": " ++ err
+
}