diff --git a/ConfigFile.cabal b/ConfigFile.cabal --- a/ConfigFile.cabal +++ b/ConfigFile.cabal @@ -1,5 +1,5 @@ Name: ConfigFile -Version: 1.0.4 +Version: 1.0.5 License: LGPL Maintainer: John Goerzen Author: John Goerzen @@ -23,21 +23,34 @@ It's possible to make a config file parsable by this module, the Unix shell, and make. Stability: Stable -Hs-Source-Dirs: src -Exposed-Modules: Data.ConfigFile, +Build-Type: Simple +Cabal-Version: >=1.2.3 + +Flag buildtests + description: Build the executable to run unit tests + default: False + +Library + Hs-Source-Dirs: src + Exposed-Modules: Data.ConfigFile, Data.ConfigFile.Types, Data.ConfigFile.Parser -Other-Modules: Data.ConfigFile.Lexer -Extensions: ExistentialQuantification, OverlappingInstances, + Other-Modules: Data.ConfigFile.Lexer + Extensions: ExistentialQuantification, OverlappingInstances, UndecidableInstances, TypeSynonymInstances, FlexibleContexts, FlexibleInstances -Build-Depends: parsec, base, - haskell98, mtl, MissingH>=1.0.0, containers -GHC-Options: -O2 + Build-Depends: parsec, base, + haskell98, mtl, MissingH>=1.0.0, containers + GHC-Options: -O2 -Wall -Executable: runtests -Buildable: False -Main-Is: runtests.hs -HS-Source-Dirs: testsrc, . -Extensions: ExistentialQuantification, OverlappingInstances, - UndecidableInstances, CPP +Executable runtests + if flag(buildtests) + Buildable: True + Build-depends: HUnit, testpack + else + Buildable: False + Main-Is: runtests.hs + HS-Source-Dirs: testsrc, src, . + Extensions: ExistentialQuantification, OverlappingInstances, + UndecidableInstances, CPP, TypeSynonymInstances, FlexibleContexts, + FlexibleInstances diff --git a/src/Data/ConfigFile.hs b/src/Data/ConfigFile.hs --- a/src/Data/ConfigFile.hs +++ b/src/Data/ConfigFile.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE UndecidableInstances, OverlappingInstances #-} {- Copyright (C) 2004-2008 John Goerzen @@ -21,7 +22,7 @@ Copyright : Copyright (C) 2004-2008 John Goerzen License : GNU LGPL, version 2.1 or above - Maintainer : John Goerzen + Maintainer : John Goerzen Stability : provisional Portability: portable @@ -79,7 +80,7 @@ -- * Configuring the ConfigParser -- $configuringcp - + -- ** Access Functions simpleAccess, interpolatingAccess, @@ -101,11 +102,10 @@ -- * Output Data to_string + ) where -) where import Data.ConfigFile.Types import Data.ConfigFile.Parser -import Data.Map.Utils import Data.Either.Utils import Data.String.Utils import qualified Data.Map as Map @@ -115,9 +115,8 @@ import Control.Monad.Error -- For interpolatingAccess -import Text.ParserCombinators.Parsec.Error(ParseError, messageString, - errorMessages, Message(..)) -import Text.ParserCombinators.Parsec(parse) +import Text.ParserCombinators.Parsec.Error (errorMessages, Message(..)) +import Text.ParserCombinators.Parsec (parse) ---------------------------------------------------------------------- -- Basic types / default values @@ -218,22 +217,22 @@ defdefaulthandler :: MonadError CPError m => ConfigParser -> SectionSpec -> OptionSpec -> m String -defdefaulthandler cp sectn opt = +defdefaulthandler cp sectn opt = let fm = content cp - lookup s o = do sect <- maybeToEither (NoSection s, - "get " ++ formatSO sectn opt) $ + lookUp s o = do sect <- maybeToEither (NoSection s, + "get " ++ formatSO sectn opt) $ Map.lookup s fm - maybeToEither (NoOption o, - "get " ++ formatSO sectn opt) $ + maybeToEither (NoOption o, + "get " ++ formatSO sectn opt) $ Map.lookup o sect trydefault e = if (usedefault cp) - then - lookup "DEFAULT" opt + then + lookUp "DEFAULT" opt -- Use original error if it's not in DEFAULT either `catchError` (\_ -> throwError e) else throwError e - in - lookup sectn opt `catchError` trydefault + in + lookUp sectn opt `catchError` trydefault {- | Combines two 'ConfigParser's into one. @@ -244,14 +243,14 @@ The 'ConfigParser' options in the resulting object will be set as they are in the second one passed to this function. -} merge :: ConfigParser -> ConfigParser -> ConfigParser -merge src dest = +merge src dest = let conv :: String -> String conv = optionxform dest convFM :: CPOptions -> CPOptions convFM = Map.fromList . map (\x -> (conv (fst x), snd x)) . Map.toList mergesects a b = Map.union a b in - dest { content = Map.unionWith mergesects + dest { content = Map.unionWith mergesects (content dest) (Map.map convFM (content src)) } {- | Utility to do a special case merge. -} @@ -313,7 +312,7 @@ {- | Adds the specified section name. Returns a 'SectionAlreadyExists' error if the -section was already present. Otherwise, returns the new +section was already present. Otherwise, returns the new 'ConfigParser' object.-} add_section :: MonadError CPError m => ConfigParser -> SectionSpec -> m ConfigParser @@ -332,7 +331,7 @@ remove_section :: MonadError CPError m => ConfigParser -> SectionSpec -> m ConfigParser remove_section _ "DEFAULT" = throwError $ (NoSection "DEFAULT", "remove_section") -remove_section cp s = +remove_section cp s = if has_section cp s then return $ cp {content = Map.delete s (content cp)} else throwError $ (NoSection s, "remove_section") @@ -344,15 +343,15 @@ remove_option :: MonadError CPError m => ConfigParser -> SectionSpec -> OptionSpec -> m ConfigParser remove_option cp s passedo = - do sectmap <- maybeToEither (NoSection s, - "remove_option " ++ formatSO s passedo) $ + do sectmap <- maybeToEither (NoSection s, + "remove_option " ++ formatSO s passedo) $ Map.lookup s (content cp) let o = (optionxform cp) passedo let newsect = Map.delete o sectmap let newmap = Map.insert s newsect (content cp) if Map.member o sectmap then return $ cp {content = newmap} - else throwError $ (NoOption o, + else throwError $ (NoOption o, "remove_option " ++ formatSO s passedo) {- | Returns a list of the names of all the options present in the @@ -362,7 +361,7 @@ -} options :: MonadError CPError m => ConfigParser -> SectionSpec -> m [OptionSpec] -options cp x = maybeToEither (NoSection x, "options") $ +options cp x = maybeToEither (NoSection x, "options") $ do o <- Map.lookup x (content cp) return $ Map.keys o @@ -373,7 +372,7 @@ exception could be raised or error returned. -} has_option :: ConfigParser -> SectionSpec -> OptionSpec -> Bool -has_option cp s o = +has_option cp s o = let c = content cp v = do secthash <- Map.lookup s c return $ Map.member (optionxform cp $ o) secthash @@ -381,7 +380,7 @@ {- | The class representing the data types that can be returned by "get". -} -class Get_C a where +class Get_C a where {- | Retrieves a string from the configuration file. When used in a context where a String is expected, returns that string verbatim. @@ -421,7 +420,7 @@ * false -} get :: MonadError CPError m => ConfigParser -> SectionSpec -> OptionSpec -> m a - + instance Get_C String where get cp s o = eitherToMonadError $ (accessfunc cp) cp s o @@ -431,11 +430,12 @@ instance (Num t, Read t) => Get_C t where get = genericget +genericget :: (Read b, MonadError CPError m) => ConfigParser -> SectionSpec -> OptionSpec -> m b genericget cp s o = get cp s o >>= return . read getbool :: MonadError CPError m => ConfigParser -> SectionSpec -> OptionSpec -> m Bool -getbool cp s o = +getbool cp s o = do val <- get cp s o case map toLower . strip $ val of "1" -> return True @@ -451,6 +451,7 @@ _ -> throwError (ParseError $ "couldn't parse bool " ++ val ++ " from " ++ formatSO s o, "getbool") +formatSO :: [Char] -> [Char] -> [Char] formatSO s o = "(" ++ s ++ "/" ++ o ++ ")" @@ -459,7 +460,7 @@ of the given section. Returns an error the section is invalid. -} items :: MonadError CPError m => ConfigParser -> SectionSpec -> m [(OptionSpec, String)] -items cp s = do fm <- maybeToEither (NoSection s, "items") $ +items cp s = do fm <- maybeToEither (NoSection s, "items") $ Map.lookup s (content cp) return $ Map.toList fm @@ -468,8 +469,8 @@ Returns an error if the section does not exist. -} set :: MonadError CPError m => ConfigParser -> SectionSpec -> OptionSpec -> String -> m ConfigParser -set cp s passedo val = - do sectmap <- maybeToEither (NoSection s, "set " ++ formatSO s passedo) $ +set cp s passedo val = + do sectmap <- maybeToEither (NoSection s, "set " ++ formatSO s passedo) $ Map.lookup s (content cp) let o = (optionxform cp) passedo let newsect = Map.insert o val sectmap @@ -481,7 +482,7 @@ This can be used with bool values, as well as numeric ones. Returns an error if the section does not exist. -} -setshow :: (Show a, MonadError CPError m) => +setshow :: (Show a, MonadError CPError m) => ConfigParser -> SectionSpec -> OptionSpec -> a -> m ConfigParser setshow cp s o val = set cp s o (show val) @@ -497,8 +498,8 @@ The result is, however, guaranteed to parse the same as the original input. -} to_string :: ConfigParser -> String -to_string cp = - let gen_option (key, value) = +to_string cp = + let gen_option (key, value) = key ++ ": " ++ (replace "\n" "\n " value) ++ "\n" gen_section (sect, valfm) = -- gen a section, but omit DEFAULT if empty if (sect /= "DEFAULT") || (Map.size valfm > 0) @@ -594,7 +595,7 @@ >inputfile = /etc/passwd >names = Peter, Paul, Mary, George, Abrahaham, John, Bill, Gerald, Richard, > Franklin, Woodrow ->color = red +>color = red This defines a file without any explicit section, so all items will occur within the default section @DEFAULT@. The @debug@ option can be read @@ -603,21 +604,21 @@ whitespace, and containing something other than whitespace or comments, is taken as a continuation of the previous line. -Here's another example: +Here's another example: ># Default options >[DEFAULT] ->hostname: localhost +>hostname: localhost ># Options for the first file >[file1] >location: /usr/local >user: Fred >uid: 1000 ->optionaltext: Hello, this entire string is included +>optionaltext: Hello, this entire string is included >[file2] >location: /opt >user: Fred ->uid: 1001 +>uid: 1001 This file defines three sections. The @DEFAULT@ section specifies an entry @hostname@. If you attempt to read the hostname option in any @@ -634,7 +635,7 @@ before\/after the colon or equal sign if they like, and it will be automatically stripped. -Blank lines or lines consisting solely of whitespace are ignored. +Blank lines or lines consisting solely of whitespace are ignored. A line giving an option or a section name may not begin with white space. This requirement is necessary so there is no ambiguity between such lines @@ -649,7 +650,7 @@ of the line. Comments /may not/ occur within the definitions of options; that is, you -may not place a comment in the middle of a line such as @user: Fred@. +may not place a comment in the middle of a line such as @user: Fred@. That is because the parser considers the comment characters part of the string; otherwise, you'd be unable to use those characters in your strings. You can, however, \"comment out\" options by putting the @@ -673,8 +674,8 @@ >arch = i386 >project = test >filename = test_%(arch)s.c ->dir = /usr/src/%(filename)s ->percent = 5%% +>dir = /usr/src/%(filename)s +>percent = 5%% With interpolation, you would get these results: @@ -691,7 +692,7 @@ The basic theory of working with ConfigParser is this: 1. Parse or build a 'ConfigParser' object - + 2. Work with it in one of several ways 3. To make changes, you discard the original object and use a new one. @@ -706,7 +707,7 @@ -} {- $usagenomonad -You'll notice that many functions in this module return a +You'll notice that many functions in this module return a @MonadError 'CPError'@ over some type. Although its definition is not this simple, you can consider this to be the same as returning @Either CPError a@. @@ -717,7 +718,7 @@ more detail. Some people find it annoying to have to deal with errors manually. -You can transform errors into exceptions in your code by using +You can transform errors into exceptions in your code by using 'Data.Either.Utils.forceEither'. Here's an example of this style of programming: > import Data.Either.Utils @@ -785,7 +786,7 @@ {- $usageerroriomonad You've seen a nice way to use this module in the Error monad and get an Either -value out. But that's the Error monad, so IO is not permitted. +value out. But that's the Error monad, so IO is not permitted. Using Haskell's monad transformers, you can run it in the combined Error\/IO monad. That is, you will get an IO result back. Here is a full standalone example of doing that: diff --git a/src/Data/ConfigFile/Lexer.hs b/src/Data/ConfigFile/Lexer.hs --- a/src/Data/ConfigFile/Lexer.hs +++ b/src/Data/ConfigFile/Lexer.hs @@ -1,5 +1,5 @@ {- arch-tag: ConfigParser lexer support -Copyright (C) 2004 John Goerzen +Copyright (C) 2004, 2008 John Goerzen This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -21,7 +21,7 @@ Copyright : Copyright (C) 2004 John Goerzen License : GNU LGPL, version 2.1 or above - Maintainer : John Goerzen + Maintainer : John Goerzen Stability : provisional Portability: portable @@ -30,7 +30,7 @@ Copyright (c) 2004 John Goerzen, jgoerzen\@complete.org -} -module Data.ConfigFile.Lexer +module Data.ConfigFile.Lexer ( -- -- * Temporary for testing --comment_chars, eol, optionsep, whitespace_chars, comment_line, @@ -50,36 +50,51 @@ | NEWOPTION (String, String) deriving (Eq, Show, Ord) +comment_chars :: CharParser st Char comment_chars = oneOf "#;" +eol :: GenParser Char st String eol = string "\n" <|> string "\r\n" <|> string "\r" "End of line" +eoleof :: GenParser Char st () eoleof = eof <|> do {eol; return ()} +optionsep :: GenParser Char st Char optionsep = oneOf ":=" "option separator" +whitespace_chars :: GenParser Char st Char whitespace_chars = oneOf " \t" "whitespace" +comment_line :: GenParser Char st () comment_line = do skipMany whitespace_chars comment_chars "start of comment" (many $ noneOf "\r\n") "content of comment" eoleof +eolstuff :: GenParser Char st () eolstuff = (try comment_line) <|> (try empty_line) +empty_line :: GenParser Char st () empty_line = do many whitespace_chars eoleof "empty line" +sectheader_chars :: CharParser st Char sectheader_chars = noneOf "]\r\n" +sectheader :: GenParser Char st String sectheader = do char '[' sname <- many1 $ sectheader_chars char ']' eolstuff return sname "start of section" +oname_chars :: CharParser st Char oname_chars = noneOf ":=\r\n" +value_chars :: CharParser st Char value_chars = noneOf "\r\n" +extension_line :: GenParser Char st String extension_line = do many1 whitespace_chars c1 <- noneOf "\r\n#;" remainder <- many value_chars eolstuff return (c1 : remainder) +optionkey, optionvalue :: GenParser Char st String optionkey = many1 oname_chars optionvalue = many value_chars +optionpair :: GenParser Char st (String, String) optionpair = do key <- optionkey optionsep value <- optionvalue @@ -92,13 +107,13 @@ -- Ignore these things try (do {comment_line; togtok $ IGNOREDATA}) <|> try (do {empty_line; togtok $ IGNOREDATA}) - + -- Real stuff <|> (do {sname <- sectheader; togtok $ NEWSECTION sname}) <|> try (do {extension <- extension_line; togtok $ EXTENSIONLINE extension}) <|> try (do {pair <- optionpair; togtok $ NEWOPTION pair}) -- "Invalid syntax in configuration file" - + loken :: Parser [GeneralizedToken CPTok] loken = do x <- manyTill iloken eof return $ filter (\y -> snd y /= IGNOREDATA) x diff --git a/src/Data/ConfigFile/Parser.hs b/src/Data/ConfigFile/Parser.hs --- a/src/Data/ConfigFile/Parser.hs +++ b/src/Data/ConfigFile/Parser.hs @@ -1,4 +1,4 @@ -{- +{- Copyright (C) 2004-2008 John Goerzen This program is free software; you can redistribute it and/or modify @@ -21,7 +21,7 @@ Copyright : Copyright (C) 2004-2008 John Goerzen License : GNU LGPL, version 2.1 or above - Maintainer : John Goerzen + Maintainer : John Goerzen Stability : provisional Portability: portable @@ -50,7 +50,7 @@ parse_string :: MonadError CPError m => String -> m ParseOutput -parse_string s = +parse_string s = detokenize "(string)" $ parse loken "(string)" s --parse_file :: FilePath -> IO (CPResult ParseOutput) @@ -69,26 +69,29 @@ ---------------------------------------------------------------------- -- Private funcs ---------------------------------------------------------------------- +detokenize :: (Show t, MonadError (CPErrorData, [Char]) m) => SourceName + -> Either t [GeneralizedToken CPTok] + -> m ParseOutput detokenize fp l = let conv msg (Left err) = throwError $ (ParseError (show err), msg) - conv msg (Right val) = return val + conv _ (Right val) = return val in do r <- conv "lexer" l conv "parser" $ runParser main () fp r main :: GeneralizedTokenParser CPTok () ParseOutput main = do {s <- sectionlist; return s} - <|> try (do + <|> try (do o <- optionlist s <- sectionlist return $ ("DEFAULT", o) : s ) <|> do {o <- optionlist; return $ [("DEFAULT", o)] } "Error parsing config file tokens" - + sectionlist :: GeneralizedTokenParser CPTok () ParseOutput sectionlist = do {eof; return []} - <|> try (do + <|> try (do s <- sectionhead eof return [(s, [])] @@ -102,7 +105,7 @@ section = do {sh <- sectionhead; ol <- optionlist; return (sh, ol)} sectionhead :: GeneralizedTokenParser CPTok () String -sectionhead = +sectionhead = let wf (NEWSECTION x) = Just x wf _ = Nothing in diff --git a/src/Data/ConfigFile/Types.hs b/src/Data/ConfigFile/Types.hs --- a/src/Data/ConfigFile/Types.hs +++ b/src/Data/ConfigFile/Types.hs @@ -21,7 +21,7 @@ Copyright : Copyright (C) 2004-2008 John Goerzen License : GNU LGPL, version 2.1 or above - Maintainer : John Goerzen + Maintainer : John Goerzen Stability : provisional Portability: portable @@ -32,7 +32,7 @@ -} module Data.ConfigFile.Types ( - CPOptions, CPData, + CPOptions, CPData, CPErrorData(..), CPError, {-CPResult,-} ConfigParser(..), SectionSpec, @@ -91,7 +91,7 @@ {- | This is the main record that is used by 'Data.ConfigFile'. -} -data ConfigParser = ConfigParser +data ConfigParser = ConfigParser { -- | The data itself content :: CPData, -- | How to transform an option into a standard representation @@ -109,5 +109,3 @@ -- The option value is not assumed to be transformed. accessfunc :: (ConfigParser -> SectionSpec -> OptionSpec -> Either CPError String) } - - diff --git a/testsrc/runtests.hs b/testsrc/runtests.hs new file mode 100644 --- /dev/null +++ b/testsrc/runtests.hs @@ -0,0 +1,25 @@ +{- arch-tag: Test runner +Copyright (C) 2004 John Goerzen + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Main where + +import Test.HUnit +import Tests + +main = runTestTT tests +