1. Bryan O'Sullivan
  2. configurator

Commits

Bryan O'Sullivan  committed b4a1676 Merge

Merge

  • Participants
  • Parent commits a4c735a, 14fa9f9
  • Branches default

Comments (0)

Files changed (3)

File Data/Configurator.hs

View file
 import Control.Applicative ((<$>))
 import Control.Concurrent (ThreadId, forkIO, threadDelay)
 import Control.Exception (SomeException, evaluate, handle, throwIO, try)
-import Control.Monad (foldM, forM, forM_, join, when)
+import Control.Monad (foldM, forM, forM_, join, when, msum)
 import Data.Configurator.Instances ()
 import Data.Configurator.Parser (interp, topLevel)
 import Data.Configurator.Types.Internal
 import Data.IORef (atomicModifyIORef, newIORef, readIORef)
+import Data.List (tails)
 import Data.Maybe (fromMaybe, isJust)
 import Data.Monoid (mconcat)
 import Data.Ratio (denominator, numerator)
    go seen path = do
      let rewrap n = const n <$> path
          wpath = worth path
-     path' <- rewrap <$> interpolate wpath H.empty
+     path' <- rewrap <$> interpolate "" wpath H.empty
      ds    <- loadOne (T.unpack <$> path')
      let !seen'    = H.insert path ds seen
          notSeen n = not . isJust . H.lookup n $ seen
         Just ds -> foldM (directive pfx (worth f)) m ds
 
   directive pfx _ m (Bind name (String value)) = do
-      v <- interpolate value m
+      v <- interpolate pfx value m
       return $! H.insert (T.append pfx name) (String v) m
   directive pfx _ m (Bind name value) =
       return $! H.insert (T.append pfx name) value m
             Just ds -> foldM (directive pfx f') m ds
             _       -> return m
 
-interpolate :: T.Text -> H.HashMap Name Value -> IO T.Text
-interpolate s env
+interpolate :: T.Text -> T.Text -> H.HashMap Name Value -> IO T.Text
+interpolate pfx s env
     | "$" `T.isInfixOf` s =
       case T.parseOnly interp s of
         Left err   -> throwIO $ ParseError "" err
         Right xs -> (L.toStrict . toLazyText . mconcat) <$> mapM interpret xs
     | otherwise = return s
  where
+  lookupEnv name = msum $ map (flip H.lookup env) fullnames
+    where fullnames = map (T.intercalate ".")     -- ["a.b.c.x","a.b.x","a.x","x"]
+                    . map (reverse . (name:)) -- [["a","b","c","x"],["a","b","x"],["a","x"],["x"]]
+                    . tails                   -- [["c","b","a"],["b","a"],["a"],[]]
+                    . reverse                 -- ["c","b","a"]
+                    . filter (not . T.null)   -- ["a","b","c"]
+                    . T.split (=='.')         -- ["a","b","c",""]
+                    $ pfx                     -- "a.b.c."
+
   interpret (Literal x)   = return (fromText x)
   interpret (Interpolate name) =
-      case H.lookup name env of
+      case lookupEnv name of
         Just (String x) -> return (fromText x)
         Just (Number r)
             | denominator r == 1 -> return (decimal $ numerator r)

File tests/Test.hs

View file
 main = runTestTT tests >> return ()
 
 tests :: Test
-tests = TestList [
-    "load"   ~: loadTest,
-    "types"  ~: typesTest,
-    "interp" ~: interpTest,
-    "import" ~: importTest,
-    "reload" ~: reloadTest
+tests = TestList
+    [ "load"   ~: loadTest
+    , "types"  ~: typesTest
+    , "interp" ~: interpTest
+    , "scoped-interp"  ~: scopedInterpTest
+    , "import" ~: importTest
+    , "reload" ~: reloadTest
     ]
 
 withLoad :: [Worth FilePath] -> (Config -> IO ()) -> IO ()
     cfgHome <- lookup cfg "ba"
     assertEqual "home interp" (Just home) cfgHome
 
+scopedInterpTest :: Assertion
+scopedInterpTest = withLoad [Required "resources/interp.cfg"] $ \ cfg -> do
+    home    <- getEnv "HOME"
+
+    lookup cfg "myprogram.exec"
+        >>= assertEqual "myprogram.exec" (Just $ home++"/services/myprogram/myprogram")
+
+    lookup cfg "myprogram.stdout"
+        >>= assertEqual "myprogram.stdout" (Just $ home++"/services/myprogram/stdout")
+
+    lookup cfg "top.layer1.layer2.dir"
+        >>= assertEqual "nested scope" (Just $ home++"/top/layer1/layer2")
+
 importTest :: Assertion
 importTest = do
   fp <- getDataFileName "tests/resources/import.cfg"

File tests/resources/interp.cfg

View file
+services = "$(HOME)/services"
+root = "can be overwritten by inner block."
+myprogram {
+        name = "myprogram"
+        root = "$(services)/$(name)"
+        exec = "$(root)/$(name)"
+        stdout = "$(root)/stdout"
+        stderr = "$(root)/stderr"
+        delay = 1
+}
+dir = "$(HOME)"
+top {
+    dir = "$(dir)/top"
+    layer1 {
+        dir = "$(dir)/layer1"
+        layer2 {
+            dir = "$(dir)/layer2"
+        }
+    }
+}