[Pkg-haskell-commits] [SCM] haskell-testpack branch, master, updated. debian/1.0.2-1-4-gb0d6b36

[John Goerzen]

The following commit has been merged in the master branch:
commit cfd3726e45263f690c1d222d407a3f1999e24ce7
Author: John Goerzen <jgoerzen at complete.org>
Date:   Wed Dec 1 23:43:10 2004 +0100

    Checkpointing basic interpolation
    
    Keywords:
    
    
    (jgoerzen at complete.org--projects/missingh--head--0.5--patch-137)

diff --git a/ChangeLog b/ChangeLog
index 8672878..666ee99 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -2,6 +2,20 @@
 # arch-tag: automatic-ChangeLog--jgoerzen at complete.org--projects/missingh--head--0.5
 #
 
+2004-12-01 16:43:10 GMT	John Goerzen <jgoerzen at complete.org>	patch-137
+
+    Summary:
+      Checkpointing basic interpolation
+    Revision:
+      missingh--head--0.5--patch-137
+
+
+    modified files:
+     ChangeLog libsrc/MissingH/ConfigParser.hs
+     libsrc/MissingH/ConfigParser/Parser.hs
+     libsrc/MissingH/ConfigParser/Types.hs
+
+
 2004-12-01 16:09:58 GMT	John Goerzen <jgoerzen at complete.org>	patch-136
 
     Summary:
diff --git a/libsrc/MissingH/ConfigParser.hs b/libsrc/MissingH/ConfigParser.hs
index 79622e6..7594b62 100644
--- a/libsrc/MissingH/ConfigParser.hs
+++ b/libsrc/MissingH/ConfigParser.hs
@@ -67,9 +67,6 @@ module MissingH.ConfigParser
      -- ** Combined Error\/IO Monad Usage
      -- $usageerroriomonad
 
-     -- ** Configuring the ConfigParser
-     -- $configuringcp
-
      -- * Types
      SectionSpec, OptionSpec, ConfigParser(..),
      CPErrorData(..), CPError, CPResult,
@@ -77,6 +74,12 @@ module MissingH.ConfigParser
      -- $initialization
      emptyCP,
 
+     -- * Configuring the ConfigParser
+     -- $configuringcp
+     
+     -- ** Access Functions
+     simpleAccess, interpolatingAccess,
+
      -- * Reading
      -- $reading
      readfile, readhandle, readstring,
@@ -108,6 +111,11 @@ import System.IO(Handle)
 import Data.Char
 import Control.Monad.Error
 
+-- For interpolatingAccess
+import Text.ParserCombinators.Parsec.Error(ParseError, messageString,
+    errorMessages)
+import Text.ParserCombinators.Parsec(parse)
+
 ----------------------------------------------------------------------
 -- Basic types / default values
 ----------------------------------------------------------------------
@@ -119,13 +127,15 @@ The content contains only an empty mandatory @DEFAULT@ section.
 'optionxform' is set to @map toLower at .
 
 'usedefault' is set to @True at .
+
+'accessfunc' is set to 'simpleAccess'.
 -}
 emptyCP :: ConfigParser
 emptyCP = ConfigParser { content = fromAL [("DEFAULT", [])],
                        defaulthandler = defdefaulthandler,
                        optionxform = map toLower,
                        usedefault = True,
-                       accessfunc = defaccessfunc}
+                       accessfunc = simpleAccess}
 
 {- | Low-level tool to convert a parsed object into a 'CPData'
 representation.  Performs no option conversions or special handling
@@ -137,9 +147,31 @@ fromAL origal =
         in
         foldl conv emptyFM origal
 
--- internal function: default access function
-defaccessfunc :: ConfigParser -> SectionSpec -> OptionSpec -> CPResult String
-defaccessfunc cp s o = defdefaulthandler cp s (optionxform cp $ o)
+{- | Default (non-interpolating) access function -}
+simpleAccess :: ConfigParser -> SectionSpec -> OptionSpec -> CPResult String
+simpleAccess cp s o = defdefaulthandler cp s (optionxform cp $ o)
+
+{- | Interpolating access function -}
+interpolatingAccess :: Int ->           -- ^ Maximum interpolation depth
+                       ConfigParser -> SectionSpec -> OptionSpec
+                       -> CPResult String
+interpolatingAccess maxdepth cp s o =
+    let lookupfunc :: (String -> CPResult String)
+        lookupfunc = interpolatingAccess (maxdepth - 1) cp s
+        error2str :: ParseError -> String
+        error2str = messageString . head . errorMessages
+        in
+        if maxdepth < 1 
+           then throwError $ 
+                    (InterpolationError "maximum interpolation depth exceeded",
+                     "interpolatingAccess")
+           else do
+                x <- simpleAccess cp s o
+                case parse (interpmain lookupfunc) "(string)" s of
+                     Left x -> throwError $ 
+                               (InterpolationError ("Unresolvable interpolation reference to \"" ++ error2str x ++ "\""),
+                                "interpolatingAccess")
+                     Right x -> return x
 
 -- internal function: default handler
 defdefaulthandler :: ConfigParser -> SectionSpec -> OptionSpec -> CPResult String
diff --git a/libsrc/MissingH/ConfigParser/Parser.hs b/libsrc/MissingH/ConfigParser/Parser.hs
index 63396d3..92cb752 100644
--- a/libsrc/MissingH/ConfigParser/Parser.hs
+++ b/libsrc/MissingH/ConfigParser/Parser.hs
@@ -33,7 +33,7 @@ Copyright (c) 2004 John Goerzen, jgoerzen\@complete.org
 -}
 module MissingH.ConfigParser.Parser
 (
- parse_string, parse_file, parse_handle, ParseOutput
+ parse_string, parse_file, parse_handle, interpmain, ParseOutput
        --satisfyG,
        --main
 ) where
@@ -126,3 +126,37 @@ valmerge :: [String] -> String
 valmerge vallist =
     let vl2 = map strip vallist
         in join "\n" vl2
+
+----------------------------------------------------------------------
+-- Interpolation
+----------------------------------------------------------------------
+
+interpval :: (String -> CPResult String) -> Parser String
+interpval lookupfunc = do
+            string "%("
+            s <- (many1 $ noneOf ")") <?> "interpolation name"
+            string ")s"               <?> "end of interpolation name"
+            return $ case lookupfunc s of
+                       Left x -> fail s
+                       Right x -> x
+
+percentval :: Parser String
+percentval = do
+             string "%%"
+             return "%"
+
+interpother :: Parser String
+interpother = do
+              c <- anyChar
+              return [c]
+
+interptok :: (String -> CPResult String) -> Parser String
+interptok lookupfunc = (try percentval) <|>
+                       (try (interpval lookupfunc))
+                       <|> interpother
+
+interpmain :: (String -> CPResult String) -> Parser String
+interpmain lookupfunc =
+    do r <- many $ interptok lookupfunc
+       eof
+       return $ concat r
diff --git a/libsrc/MissingH/ConfigParser/Types.hs b/libsrc/MissingH/ConfigParser/Types.hs
index 0e5fbde..0bde483 100644
--- a/libsrc/MissingH/ConfigParser/Types.hs
+++ b/libsrc/MissingH/ConfigParser/Types.hs
@@ -73,6 +73,7 @@ data CPErrorData = ParseError String        -- ^ Parse error
                  | NoSection SectionSpec    -- ^ The section does not exist
                  | NoOption OptionSpec      -- ^ The option does not exist
                  | OtherProblem String      -- ^ Miscellaneous error
+                 | InterpolationError String -- ^ Raised by 'MissingH.ConfigParser.interpolatingAccess' if a request was made for a non-existant option
                    deriving (Eq, Ord, Show)
 
 {- | Indicates an error occurred.  The String is an explanation of the location
@@ -103,7 +104,7 @@ data ConfigParser = ConfigParser
       usedefault :: Bool,
       -- | Function that is used to perform lookups, do optional
       -- interpolation, etc.  It is assumed that accessfunc
-      -- will internally call defaulthandler to do the actual work.
+      -- will internally call defaulthandler to do the underlying lookup.
       -- The option value is not assumed to be transformed.
       accessfunc :: (ConfigParser -> SectionSpec -> OptionSpec -> CPResult String)
     }

-- 
haskell-testpack