language-puppet 0.1.4 → 0.1.5

raw patch · 4 files changed

+41/−19 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Puppet/Daemon.hs +10/−4
• Puppet/Interpreter/Catalog.hs +21/−13
• Puppet/Interpreter/Types.hs +7/−1
• language-puppet.cabal +3/−1

@@ -208,18 +208,24 @@         Just (_,_,x) -> return x         Nothing -> throwError ("Could not find correct top level statement for " ++ show qtype ++ " " ++ nodename) -    -+{- Given a base file name and an import statement, will load these imports.+This is not as obvious as it seems because you need to load imported's imports.+-} loadImport :: (TopLevelType -> String -> CacheEntry -> IO ParsedCacheResponse ) -> FilePath -> Statement -> ErrorT String IO [(TopLevelType, String, Statement)] loadImport updatepinfo fdir mimport = do     matched <- globImport fdir mimport-    -- globDir [compile importstring] fdir >>= return . concat . fst     fileinfos <- liftIO $ mapM getFileInfo matched     let fpathinfos = zip matched fileinfos         goodpathinfos = concatMap unjust fpathinfos         unjust (a, Just b) = [(a,b)]         unjust _ = []-    liftM (concatMap snd) (mapM (\(fname, finfo) -> loadUpdateFile fname finfo updatepinfo) goodpathinfos)+    ex <- (mapM (\(fname, finfo) -> liftM (\x -> (fname, x)) $ loadUpdateFile fname finfo updatepinfo) goodpathinfos)+    -- This is a complicated and very expensive way to load imports that were imported.+    -- The only way to make it faster would be to query the cache before reloading the files ..+    let reloaded = concatMap (snd . snd) ex+        limports = map (\(fname, (mimports, _)) -> (fname, mimports)) ex+    mapM_ (\(fname, mimports) -> mapM_ (\stmt -> loadImport updatepinfo fname stmt) mimports) limports+    return $ reloaded  loadRelated ::         ( TopLevelType -> String -> ErrorT String IO (Maybe CacheEntry) )

@@ -251,27 +251,24 @@ applyDefaults :: CResource -> CatalogMonad CResource applyDefaults res = liftM curDefaults get >>= foldM applyDefaults' res -applyDefaults' :: CResource -> Statement -> CatalogMonad CResource            -applyDefaults' r@(CResource i rname rtype rparams rvirtuality rpos) (ResourceDefault dtype defs dpos) = do+applyDefaults' :: CResource -> ResDefaults -> CatalogMonad CResource+applyDefaults' r@(CResource i rname rtype rparams rvirtuality rpos) (RDefaults dtype rdefs dpos) = do     srname <- resolveGeneralString rname-    rdefs <- mapM resolveParams defs     let (nparams, nrelations) = mergeParams rparams rdefs False      if dtype == rtype         then do             addUnresRel (nrelations, (rtype, Right srname), UDefault, dpos)             return $ CResource i rname rtype nparams rvirtuality rpos         else return r-applyDefaults' r@(CResource i rname rtype rparams rvirtuality rpos) (ResourceOverride dtype dname defs dpos) = do+applyDefaults' r@(CResource i rname rtype rparams rvirtuality rpos) (ROverride dtype dname rdefs dpos) = do     srname <- resolveGeneralString rname-    sdname <- resolveExpressionString dname-    rdefs <- mapM resolveParams defs+    sdname <- resolveGeneralString dname     let (nparams, nrelations) = mergeParams rparams rdefs True     if (dtype == rtype) && (srname == sdname)         then do             addUnresRel (nrelations, (rtype, Right srname), UDefault, dpos)             return $ CResource i rname rtype nparams rvirtuality rpos         else return r-applyDefaults' r d = throwError $ "Can't apply non default statement " ++ show d ++ " to resource " ++ show r  -- merge defaults and actual parameters depending on the override flag mergeParams :: [(GeneralString, GeneralValue)] -> [(GeneralString, GeneralValue)] -> Bool -> ([(GeneralString, GeneralValue)], [(LinkType, GeneralValue, GeneralValue)])@@ -367,11 +364,14 @@                 (Right (ResolvedArray arr)) -> fmap concat (mapM (addResource rtype parameters virtuality position . Right) arr)                 _ -> addResource rtype parameters virtuality position srname -evaluateStatements x@(ResourceDefault{}) = do-    pushDefaults x+evaluateStatements (ResourceDefault rdtype rdparams rdpos) = do+    rrdparams <- mapM resolveParams rdparams+    pushDefaults $ RDefaults rdtype rrdparams rdpos     return []-evaluateStatements x@(ResourceOverride{}) = do-    pushDefaults x+evaluateStatements (ResourceOverride rotype roname roparams ropos) = do+    rroname <- tryResolveExpressionString roname+    rroparams <- mapM resolveParams roparams+    pushDefaults $ ROverride rotype rroname rroparams ropos     return [] evaluateStatements (DependenceChain (srctype, srcname) (dsttype, dstname) position) = do     setPos position@@ -434,6 +434,12 @@     if isloaded         then return []         else do+        -- detection of spurious parameters+        let classparamset = Set.fromList $ map fst parameters+            inputparamset = Set.filter (\x -> getRelationParameterType (Right x) == Nothing) $ Map.keysSet inputparams+            overparams = Set.difference inputparamset classparamset+        unless (Set.null overparams) (throwError $ "Spurious parameters " ++ intercalate ", " (Set.toList overparams) ++ " at " ++ show position)+         resid <- getNextId  -- get this resource id, for the dummy class that will be used to handle relations         oldpos <- getPos    -- saves where we were at class declaration so that we known were the class was included         setPos position@@ -624,7 +630,7 @@     if null matching         then do             position <- getPos-            addWarning ("Could not resolveValue " ++ show varnames ++ " at " ++ show position)+            addWarning ("Could not resolveValue variables " ++ show varnames ++ " at " ++ show position)             return $ Left $ Value $ VariableReference (head varnames)         else return $ case head matching of             (x,_) -> x@@ -749,7 +755,7 @@     case r of         Right (ResolvedString v) -> return $ Right v         Right (ResolvedInt    i) -> return $ Right (show i)-        Right v                  -> throwError ("Can't resolve valuestring for " ++ show v)+        Right v                  -> throwPosError ("Can't resolve valuestring for " ++ show v)         Left  v                  -> return $ Left v  getRelationParameterType :: GeneralString -> Maybe LinkType@@ -834,6 +840,8 @@ tryResolveBoolean v = do     rv <- tryResolveGeneralValue v     case rv of+        Left BFalse                 -> return $ Right $ ResolvedBool False+        Left BTrue                  -> return $ Right $ ResolvedBool True         Right (ResolvedString "")   -> return $ Right $ ResolvedBool False         Right (ResolvedString _)    -> return $ Right $ ResolvedBool True         Right (ResolvedInt 0)       -> return $ Right $ ResolvedBool False

@@ -78,6 +78,12 @@ -- many fairly acceptable behaviours and the correct one is not documented. data RelUpdateType = UNormal | UOverride | UDefault | UPlus deriving (Show, Ord, Eq) +{-| A data type to hold defaults values+ -}+data ResDefaults = RDefaults String [(GeneralString, GeneralValue)] SourcePos+                 | ROverride String GeneralString [(GeneralString, GeneralValue)] SourcePos+                 deriving (Show, Ord, Eq)+ {-| The most important data structure for the interpreter. It stores its internal state. -}@@ -94,7 +100,7 @@     curClasses :: !(Map.Map String SourcePos),     -- ^ The list of classes that have already been included, along with the     -- place where this happened.-    curDefaults :: ![Statement],+    curDefaults :: ![ResDefaults],     -- ^ List of defaults to apply. All defaults are applied at the end of the     -- interpretation of each top level statement.     curResId :: !Int, -- ^ Stores the value of the current 'crid'.

@@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented.-Version:             0.1.4+Version:             0.1.5  -- A short (one-line) description of the package. Synopsis:            Tools to parse and evaluate the Puppet DSL.@@ -27,6 +27,8 @@ -- An email address to which users can send suggestions, bug reports, -- and patches. Maintainer:          bartavelle@gmail.com++Homepage:            http://lpuppet.banquise.net  -- A copyright notice. -- Copyright: