Commits

yihuang  committed f3de615

better string interpolation support scoping.

  • Participants
  • Parent commits e7e644e

Comments (0)

Files changed (4)

File Data/Configurator.hs

     , getMap
     ) where
 
-import Control.Applicative ((<$>))
+import Control.Applicative ((<$>), (<|>))
 import Control.Concurrent (ThreadId, forkIO, threadDelay)
 import Control.Exception (SomeException, catch, evaluate, handle, throwIO, try)
 import Control.Monad (foldM, forM, forM_, join, when)
    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
+  lookupInterp name =
+          H.lookup name env
+      <|> H.lookup (pfx `T.append` name) env
+
   interpret (Literal x)   = return (fromText x)
   interpret (Interpolate name) =
-      case H.lookup name env of
+      case lookupInterp name of
         Just (String x) -> return (fromText x)
         Just (Number r)
             | denominator r == 1 -> return (decimal $ numerator r)

File tests/Test.hs

 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"
+    exec    <- lookup cfg "myprogram.exec"
+    stdout' <- lookup cfg "myprogram.stdout"
+    assertEqual "myprogram.exec" exec (Just $ home++"/services/myprogram/myprogram")
+    assertEqual "myprogram.stdout" stdout' (Just $ home++"/services/myprogram/stdout")
+
 importTest :: Assertion
 importTest = withLoad [Required "resources/import.cfg"] $ \ cfg -> do
     aa  <- lookup cfg "x.aa" :: IO (Maybe Int)
     assertEqual "notify happened" r1 (Just ())
     r2 <- takeMVarTimeout 2000 wongly
     assertEqual "notify not happened" r2 Nothing
-

File tests/configurator-tests.cabal

                      directory,
                      HUnit,
                      text,
-                     attoparsec-text,
+                     attoparsec,
                      unordered-containers,
                      unix-compat,
                      hashable,

File tests/resources/interp.cfg

+services = "$(HOME)/services"
+myprogram {
+        name = "myprogram"
+        root = "$(services)/$(name)"
+        exec = "$(root)/$(name)"
+        stdout = "$(root)/stdout"
+        stderr = "$(root)/stderr"
+        delay = 1
+}