Commits

Bryan O'Sullivan  committed 2caf212

Many useful changes.

* De-confuse the config grammar.

* Handle string interpolation.

  • Participants
  • Parent commits 9f5ae9a

Comments (0)

Files changed (4)

File Data/Configurator.hs

+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
+
 module Data.Configurator
     (
+      load
     ) where
 
 import Data.List
+import Control.Exception
 import Control.Applicative
+import Data.Monoid
 import Control.Monad
 import qualified Data.Text.Lazy as L
 import qualified Data.Text.Lazy.IO as L
-import Data.Attoparsec.Text.Lazy
+import Data.Text.Lazy.Builder.Int (decimal)
+import Data.Text.Lazy.Builder (fromString, fromText, toLazyText)
+import qualified Data.Attoparsec.Text.Lazy as L
+import qualified Data.Attoparsec.Text as T
+import System.Environment (getEnv)
 import Data.Configurator.Parser
 import Data.Configurator.Types.Internal
 import System.IO
 import qualified Data.HashMap.Lazy as H
 import Data.Maybe
+import Prelude hiding (catch)
 import qualified Data.Text as T
 
 loadFiles :: [Path] -> IO (H.HashMap Path [Directive])
    go seen path = do
      ds <- loadOne (T.unpack path)
      let seen' = H.insert path ds seen
-         notKnown n = not . isJust . H.lookup n $ seen
-     foldM go seen' . filter notKnown . importsOf $ ds
+         notSeen n = not . isJust . H.lookup n $ seen
+     foldM go seen' . filter notSeen . importsOf $ ds
   
-gorb paths = do
+load :: [Path] -> IO (H.HashMap Name Value)
+load paths = do
   ds <- loadFiles paths
   return (flatten paths ds)
 
 flatten roots files = foldl' (directive "") H.empty .
                       concat . catMaybes . map (`H.lookup` files) $ roots
  where
-  directive prefix m (Bind name value) =
-      case value of
-        Group xs -> foldl' (directive prefix') m xs
-        v        -> H.insert (T.append prefix name) v m
-    where prefix' | T.null prefix = name `T.snoc` '.'
-                  | otherwise = T.concat [prefix, name, "."]
+  directive prefix m (Bind name value) = H.insert (T.append prefix name) value m
+  directive prefix m (Group name xs) = foldl' (directive prefix') m xs
+    where prefix' = T.concat [prefix, name, "."]
   directive prefix m (Import path) =
       case H.lookup path files of
-        Just ds -> foldl' (flob prefix) m ds
+        Just ds -> foldl' (directive prefix) m ds
         _       -> m
 
+interpolate :: T.Text -> H.HashMap Name Value -> IO T.Text
+interpolate s env
+    | "$(" `T.isInfixOf` s =
+      case T.parseOnly interp s of
+        Left _   -> undefined
+        Right xs -> (L.toStrict . toLazyText . mconcat) <$> mapM interpret xs
+    | otherwise = return s
+ where
+  interpret (Literal x)   = return (fromText x)
+  interpret (Interp name) =
+      case H.lookup name env of
+        Just (String x) -> return (fromText x)
+        Just (Number n) -> return (decimal n)
+        Just _          -> error "type error"
+        _ -> do
+          e <- try . getEnv . T.unpack $ name
+          case e of
+            Left (_::SomeException) -> error "no such variable"
+            Right x -> return (fromString x)
+
 importsOf :: [Directive] -> [Path]
-importsOf (Import path : xs)       = path : importsOf xs
-importsOf (Bind _ (Group ys) : xs) = importsOf ys ++ importsOf xs
-importsOf (_ : xs)                 = importsOf xs
-importsOf _                        = []
+importsOf (Import path : xs) = path : importsOf xs
+importsOf (Group _ ys : xs)  = importsOf ys ++ importsOf xs
+importsOf (_ : xs)           = importsOf xs
+importsOf _                  = []
 
 loadOne :: FilePath -> IO [Directive]
 loadOne path = do
   s <- L.readFile path
-  case eitherResult $ parse topLevel s of
-    Left err -> hPutStrLn stderr err >> return []
+  p <- evaluate (L.eitherResult $ L.parse topLevel s)
+       `catch` \(e::ConfigError) ->
+       throwIO $ case e of
+                   ParseError _ err -> ParseError path err
+  case p of
+    Left err -> throwIO (ParseError path err)
     Right ds -> return ds

File Data/Configurator/Parser.hs

 module Data.Configurator.Parser
     (
       topLevel
+    , interp
     ) where
 
 import Control.Applicative
+import Control.Exception (throw)
 import Control.Monad (when)
 import Data.Attoparsec.Text as A
 import Data.Bits (shiftL)
 topLevel = seriesOf directive <* endOfInput
   
 directive :: Parser Directive
-directive = string "import" *> skipSpace *> (Import <$> string_)
-        <|> Bind <$> (ident <* skipSpace) <*>
-                     ((char '=' *> skipSpace *> atom <* skipHSpace) <|>
-                      (brackets '{' '}' (Group <$> seriesOf directive)))
+directive =
+  mconcat [
+    string "import" *> skipSpace *> (Import <$> string_)
+  , Bind <$> try (ident <* skipSpace <* char '=' <* skipSpace)
+         <*> value <* skipHSpace
+  , Group <$> try (ident <* skipSpace <* char '{' <* skipSpace)
+          <*> seriesOf directive <* skipSpace <* char '}' <* skipHSpace
+  ]
 
 seriesOf :: Parser a -> Parser [a]
 seriesOf p =
 skipHSpace :: Parser ()
 skipHSpace = skipWhile $ \c -> c == ' ' || c == '\t'
 
-ident :: Parser Text
+ident :: Parser Name
 ident = do
   n <- T.cons <$> satisfy isAlpha <*> A.takeWhile isCont
   when (n == "import") $
-    fail $ "reserved word (" ++ show n ++ ") used as identifier"
+    throw (ParseError "" $ "reserved word (" ++ show n ++ ") used as identifier")
   return n
  where
   isCont c = isAlphaNum c || c == '_' || c == '-'
 
-atom :: Parser Value
-atom = mconcat [
+value :: Parser Value
+value = mconcat [
           string "on" *> pure (Bool True)
         , string "off" *> pure (Bool False)
         , string "true" *> pure (Bool True)
         , string "false" *> pure (Bool False)
         , String <$> string_
-        , list
         , Number <$> decimal
+        , List <$> brackets '[' ']'
+                   ((value <* skipSpace) `sepBy` (char ',' <* skipSpace))
         ]
 
 string_ :: Parser Text
 brackets :: Char -> Char -> Parser a -> Parser a
 brackets open close p = char open *> skipSpace *> p <* skipSpace <* char close
 
-list :: Parser Value
-list = List <$> brackets '[' ']'
-       ((atom <* skipSpace) `sepBy` (char ',' <* skipSpace))
-
 embed :: Parser a -> Text -> Parser a
 embed p s = case parseOnly p s of
               Left err -> fail err
             '"'  -> cont '"'
             '\\' -> cont '\\'
             _    -> cont =<< hexQuad
-    done <- A.atEnd
+    done <- atEnd
     if done
       then return (acc `mappend` fromText h)
       else rest
       if a <= 0xdbff && b >= 0xdc00 && b <= 0xdfff
         then return $! chr (((a - 0xd800) `shiftL` 10) + (b - 0xdc00) + 0x10000)
         else fail "invalid UTF-16 surrogates"
-
+                   
+interp :: Parser [Interp]
+interp = p []
+ where
+  p acc = do
+    h <- Literal <$> A.takeWhile (/='$')
+    let rest = do
+          let cont x = p (x : h : acc)
+          c <- char '$' *> satisfy (\c -> c == '$' || c == '(')
+          case c of
+            '$' -> cont (Literal (T.singleton '$'))
+            _   -> (cont . Interp) =<< A.takeWhile1 (/=')') <* char ')'
+    done <- atEnd
+    if done
+      then return (h : acc)
+      else rest

File Data/Configurator/Types/Internal.hs

+{-# LANGUAGE DeriveDataTypeable #-}
+
 module Data.Configurator.Types.Internal
     (
       Name
+    , Value(..)
+    , Binding
     , Path
     , Directive(..)
-    , Value(..)
+    , ConfigError(..)
+    , Interp(..)
     ) where
 
+import Control.Exception
+import Data.Data (Data)
 import Data.Text (Text)
+import Data.Typeable (Typeable)
+
+data ConfigError = ParseError FilePath String
+                   deriving (Show, Typeable)
+
+instance Exception ConfigError
 
 type Name = Text
 type Path = Text
 
+type Binding = (Name,Value)
+
 data Directive = Import Path
-               | Bind Text Value
-                 deriving (Eq, Show)
+               | Bind Name Value
+               | Group Name [Directive]
+                 deriving (Eq, Show, Typeable, Data)
 
 data Value = Bool Bool
            | String Text
            | Number Int
            | List [Value]
-           | Group [Directive]
-             deriving (Eq, Show)
+             deriving (Eq, Show, Typeable, Data)
+
+data Interp = Literal Text
+            | Interp Text
+              deriving (Eq, Show)

File configurator.cabal

   build-depends:
     attoparsec-text >= 0.8.5.0,
     base == 4.*,
-    text >= 0.11.0.2,
+    text >= 0.11.1.0,
     unordered-containers	
 
   if flag(developer)