language-puppet 0.1.3 → 0.1.4

raw patch · 12 files changed

+358/−210 lines, 12 filesdep +base16-bytestringPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: base16-bytestring

API changes (from Hackage documentation)

Files

• Erb/Compute.hs +10/−0
• Erb/Evaluate.hs +60/−0
• Puppet/DSL/Parser.hs +1/−1
• Puppet/Daemon.hs +29/−31
• Puppet/Interpreter/Catalog.hs +204/−135
• Puppet/Interpreter/Functions.hs +26/−18
• Puppet/Interpreter/Types.hs +15/−12
• Puppet/NativeTypes.hs +2/−2
• Puppet/NativeTypes/File.hs +1/−1
• Puppet/NativeTypes/Helpers.hs +5/−5
• Puppet/Printers.hs +2/−2
• language-puppet.cabal +3/−3

@@ -10,6 +10,9 @@ import Control.Concurrent import System.Posix.Files import Paths_language_puppet (getDataFileName)+import Erb.Parser+import Erb.Evaluate+import qualified Data.Map as Map  type TemplateQuery = (Chan TemplateAnswer, String, String, [(String, GeneralValue)]) type TemplateAnswer = Either String String@@ -40,6 +43,13 @@  computeTemplate :: String -> String -> [(String, GeneralValue)] -> IO TemplateAnswer computeTemplate filename curcontext variables = do+    parsed <- parseErbFile filename+    case parsed of+        Left _    -> computeTemplateWRuby filename curcontext variables+        Right ast -> return $ rubyEvaluate (Map.fromList variables) curcontext ast++computeTemplateWRuby :: String -> String -> [(String, GeneralValue)] -> IO TemplateAnswer+computeTemplateWRuby filename curcontext variables = do     let rubyvars = "{\n" ++ intercalate ",\n" (concatMap toRuby variables ) ++ "\n}\n"         input = curcontext ++ "\n" ++ filename ++ "\n" ++ rubyvars     rubyscriptpath <- getDataFileName "ruby/calcerb.rb"

@@ -0,0 +1,60 @@+module Erb.Evaluate (rubyEvaluate) where++import qualified Data.Map as Map+import Puppet.Interpreter.Types+import Erb.Ruby+import Data.Maybe (catMaybes)+import Data.Either (rights)+import Control.Monad.Error+import Data.Char++rubyEvaluate :: Map.Map String GeneralValue -> String -> [RubyStatement] -> Either String String+rubyEvaluate vars ctx = foldl (evalruby vars ctx) (Right "")++evalruby :: Map.Map String GeneralValue -> String -> Either String String -> RubyStatement -> Either String String+evalruby _  _   (Left err)     _        = Left err+evalruby mp ctx (Right curstr) (Puts e) = case evalExpression mp ctx e of+    Left err -> Left err+    Right ex -> Right (curstr ++ ex)++evalExpression :: Map.Map String GeneralValue -> String -> Expression -> Either String String+evalExpression mp ctx (LookupOperation varname varindex) = do+    rvname <- evalExpression mp ctx varname+    rvindx <- evalExpression mp ctx varindex+    varvalue <- getVariable mp ctx rvname+    case varvalue of+        ResolvedArray arr -> do+            case (a2i rvindx) of+                Nothing -> throwError $ "Can't convert index to integer when resolving " ++ rvname ++ "[" ++ rvindx ++ "]"+                Just  i -> if length arr <= i+                    then throwError $ "Array out of bound " ++ rvname ++ "[" ++ rvindx ++ "]"+                    else return $ arr !! i+            return "x"+        ResolvedHash hs   -> case (filter (\(a,_) -> a == rvindx) hs) of+            []      -> throwError $ "No index " ++ rvindx ++ " for variable " ++ show varname+            (_,x):_ -> evalValue $ Right x+        x                 -> throwError $ "Can't index variable " ++ show varname ++ ", it is " ++ show x+evalExpression _  _   (Value (Literal x))          = Right x+evalExpression mp ctx (Object (Value (Literal x))) = getVariable mp ctx x >>= evalValue . Right+evalExpression _  _   x = Left $ "Can't evaluate " ++ show x++getVariable :: Map.Map String GeneralValue -> String -> String -> Either String ResolvedValue+getVariable mp ctx rvname =+    let vars = map (\x -> Map.lookup x mp) [rvname, ctx ++ "::" ++ rvname, "::" ++ rvname]+        jsts = catMaybes vars+        rghts = rights jsts+    in do+        when (null jsts) (throwError $ "Can't resolve variable " ++ rvname)+        when (null rghts) (throwError $ "Variable " ++ rvname ++ " value is not resolved")+        return (head rghts)+        ++evalValue :: GeneralValue -> Either String String+evalValue (Left _) = Left $ "Can't evaluate a value"+evalValue (Right (ResolvedString x)) = Right x+evalValue (Right (ResolvedInt x))    = Right $ show x+evalValue (Right x) = Right $ show x++a2i :: String -> Maybe Int+a2i x | all isDigit x = read x+      | otherwise = Nothing

@@ -238,7 +238,7 @@ puppetRegexpExpr = puppetRegexp >>= return . Value . PuppetRegexp  singleQuotedString = do { char '\''-    ; v <- many ( do { char '\\' ; x <- anyChar; return [x] } <|> many1 (noneOf "'\\") )+    ; v <- many ( do { char '\\' ; x <- anyChar; if x=='\'' then return "'" else return ['\\',x] } <|> many1 (noneOf "'\\") )     ; char '\''     ; whiteSpace     ; return $ concat v

@@ -87,7 +87,7 @@         QCatalog (nodename, facts, respchan) -> do             logDebug ("Received query for node " ++ nodename)             (stmts, warnings) <- getCatalog getstmts gettemplate nodename facts-            mapM logWarning warnings+            mapM_ logWarning warnings             case stmts of                 Left x -> writeChan respchan (RCatalog $ Left x)                 Right x -> writeChan respchan (RCatalog $ Right x)@@ -115,7 +115,7 @@     logDebug "initParserDaemon"     controlChan <- newChan     getparsed <- initParsedDaemon prefs-    forkIO (pmaster prefs controlChan (getparsed))+    forkIO (pmaster prefs controlChan getparsed)     return (getStatements controlChan)  -- extracts data from a filestatus@@ -151,20 +151,20 @@ compilefilelist prefs _ name = moduleInfo     where         moduleInfo | length nameparts == 1 = [modules prefs ++ "/" ++ name ++ "/manifests/init.pp"]-                   | otherwise = [modules prefs ++ "/" ++ (head nameparts) ++ "/manifests/" ++ (DLU.join "/" (tail nameparts)) ++ ".pp"]+                   | otherwise = [modules prefs ++ "/" ++ head nameparts ++ "/manifests/" ++ DLU.join "/" (tail nameparts) ++ ".pp"]         nameparts = DLU.split "::" name  findFile :: Prefs -> TopLevelType -> String -> ErrorT String IO (FilePath, FileStatus) findFile prefs qtype resname = do     let filelist = compilefilelist prefs qtype resname-    fileinfo <- liftIO $ foldlM (getFirstFileInfo) Nothing filelist+    fileinfo <- liftIO $ foldlM getFirstFileInfo Nothing filelist     case fileinfo of         Just x -> return x-        Nothing -> throwError ("Could not find file for " ++ show qtype ++ " " ++ resname ++ " when looking in " ++ (show filelist))+        Nothing -> throwError ("Could not find file for " ++ show qtype ++ " " ++ resname ++ " when looking in " ++ show filelist)  globImport :: FilePath -> Statement -> ErrorT String IO [FilePath] globImport origfile (Import importname ipos) = do-    importedfiles <- liftIO $ globDir [compile importname] (takeDirectory origfile) >>= return . concat . fst+    importedfiles <- liftM (concat . fst) (liftIO $ globDir [compile importname] (takeDirectory origfile))     if null importedfiles         then throwError $ "Could not import " ++ importname ++ " at " ++ show ipos         else return importedfiles@@ -175,7 +175,7 @@   it must also parse all required files and store everything about them before returning  -}-loadUpdateFile :: FilePath -> FileStatus -> (TopLevelType -> String -> CacheEntry -> IO ( ParsedCacheResponse ) ) -> ErrorT String IO ([Statement], [(TopLevelType, String, Statement)])+loadUpdateFile :: FilePath -> FileStatus -> (TopLevelType -> String -> CacheEntry -> IO ParsedCacheResponse ) -> ErrorT String IO ([Statement], [(TopLevelType, String, Statement)]) loadUpdateFile fname fstatus updatepinfo = do     liftIO $ logDebug ("Loading file " ++ fname)     parsed <- parseFile fname@@ -185,34 +185,32 @@         (imports, spurioustoplevels) = partition isImport othertoplevels         isImport (Import _ _) = True         isImport _ = False-    relatedtops <- mapM (globImport fname) imports >>= return . concat+    relatedtops <- liftM concat (mapM (globImport fname) imports)         -- save this spurious top levels-    if null spurioustoplevels-        then return ()-        else do-            liftIO ( updatepinfo TopSpurious fname (ClassDeclaration "::" Nothing [] spurioustoplevels (initialPos fname), fname, fstatus, relatedtops) >> return () )+    unless (null spurioustoplevels) $ do+            liftIO $ void ( updatepinfo TopSpurious fname (ClassDeclaration "::" Nothing [] spurioustoplevels (initialPos fname), fname, fstatus, relatedtops) )             liftIO $ logWarning ("Spurious top level statement in file " ++ fname ++ ", expect bugs in case you modify them" )     -- saves all good top levels     liftIO $ mapM (\(rtype, resname, resstatement) -> updatepinfo rtype resname (resstatement, fname, fstatus, relatedtops)) oktoplevels     return (imports, oktoplevels) -reparseStatements :: Prefs -> (TopLevelType -> String -> CacheEntry -> IO ( ParsedCacheResponse ) ) -> TopLevelType -> String -> ErrorT String IO Statement+reparseStatements :: Prefs -> (TopLevelType -> String -> CacheEntry -> IO ParsedCacheResponse ) -> TopLevelType -> String -> ErrorT String IO Statement reparseStatements prefs updatepinfo qtype nodename = do     (fname, fstatus) <- findFile prefs qtype nodename     reparseFile fname fstatus updatepinfo qtype nodename -reparseFile :: FilePath -> FileStatus -> (TopLevelType -> String -> CacheEntry -> IO ( ParsedCacheResponse ) ) -> TopLevelType -> String -> ErrorT String IO Statement+reparseFile :: FilePath -> FileStatus -> (TopLevelType -> String -> CacheEntry -> IO ParsedCacheResponse ) -> TopLevelType -> String -> ErrorT String IO Statement reparseFile fname fstatus updatepinfo qtype nodename = do     (imports, oktoplevels) <- loadUpdateFile fname fstatus updatepinfo-    imported <- mapM (loadImport updatepinfo fname) imports >>= return . concat+    imported <- liftM concat (mapM (loadImport updatepinfo fname) imports)     let searchstatement = find (\(qt,nm,_) -> (qt == qtype) && (nm == nodename)) (oktoplevels ++ imported)     case searchstatement of         Just (_,_,x) -> return x-        Nothing -> throwError ("Could not find correct top level statement for " ++ (show qtype) ++ " " ++ nodename)+        Nothing -> throwError ("Could not find correct top level statement for " ++ show qtype ++ " " ++ nodename)       -loadImport :: (TopLevelType -> String -> CacheEntry -> IO ( ParsedCacheResponse ) ) -> FilePath -> Statement -> ErrorT String IO [(TopLevelType, String, Statement)]+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@@ -221,7 +219,7 @@         goodpathinfos = concatMap unjust fpathinfos         unjust (a, Just b) = [(a,b)]         unjust _ = []-    mapM (\(fname, finfo) -> loadUpdateFile fname finfo updatepinfo) goodpathinfos >>= return . concatMap snd+    liftM (concatMap snd) (mapM (\(fname, finfo) -> loadUpdateFile fname finfo updatepinfo) goodpathinfos)  loadRelated ::         ( TopLevelType -> String -> ErrorT String IO (Maybe CacheEntry) )@@ -232,13 +230,13 @@     case res of         Nothing -> return []         Just (stmts, _, _, related) -> do-            relstatements <- mapM (loadRelated getpinfo) related >>= return . concat+            relstatements <- liftM concat (mapM (loadRelated getpinfo) related)             return $ (filename,stmts):relstatements  handlePRequest :: Prefs ->     ( TopLevelType -> String -> ErrorT String IO (Maybe CacheEntry)-    , TopLevelType -> String -> CacheEntry -> IO ( ParsedCacheResponse )-    , String -> IO ( ParsedCacheResponse )+    , TopLevelType -> String -> CacheEntry -> IO ParsedCacheResponse+    , String -> IO ParsedCacheResponse     ) -> TopLevelType -> String -> ErrorT String IO Statement handlePRequest prefs (getpinfo, updatepinfo, invalidateinfo) qtype nodename = do     res <- getpinfo qtype nodename@@ -246,7 +244,7 @@         Just (stmts, fpath, fstatus, related) -> do             -- for this to work, everything must be cached             -- this is buggy as the required stuff will not be invalidated properly-            relstatements <- mapM (loadRelated getpinfo) (fpath:related) >>= return . concat+            relstatements <- liftM concat (mapM (loadRelated getpinfo) (fpath:related))             isfileinfoaccurate <- checkFileInfo fpath fstatus             statements <- if isfileinfoaccurate                             then return stmts@@ -263,8 +261,8 @@  pmaster :: Prefs -> Chan ParserMessage ->     ( TopLevelType -> String -> ErrorT String IO (Maybe CacheEntry)-    , TopLevelType -> String -> CacheEntry -> IO ( ParsedCacheResponse )-    , String -> IO ( ParsedCacheResponse )+    , TopLevelType -> String -> CacheEntry -> IO ParsedCacheResponse+    , String -> IO ParsedCacheResponse     ) -> IO () pmaster prefs chan cachefuncs = do     pmessage <- readChan chan@@ -303,8 +301,8 @@ -- this one is singleton, and is used to cache de parsed values, along with the file names they depend on initParsedDaemon :: Prefs -> IO     ( TopLevelType -> String -> ErrorT String IO (Maybe CacheEntry)-    , TopLevelType -> String -> CacheEntry -> IO ( ParsedCacheResponse )-    , String -> IO ( ParsedCacheResponse )+    , TopLevelType -> String -> CacheEntry -> IO ParsedCacheResponse+    , String -> IO ParsedCacheResponse     ) initParsedDaemon prefs = do     logDebug "initParsedDaemon"@@ -323,13 +321,13 @@         CacheError x  -> throwError x         _             -> throwError "Unknown cache response type" -updateParsedInformation :: Chan ParsedCacheQuery -> TopLevelType -> String -> CacheEntry -> IO (ParsedCacheResponse)+updateParsedInformation :: Chan ParsedCacheQuery -> TopLevelType -> String -> CacheEntry -> IO ParsedCacheResponse updateParsedInformation pchannel qtype name centry = do     respchan <- newChan     writeChan pchannel $ UpdateParsedData qtype name centry respchan     readChan respchan -invalidateCachedFile :: Chan ParsedCacheQuery -> String -> IO (ParsedCacheResponse)+invalidateCachedFile :: Chan ParsedCacheQuery -> String -> IO ParsedCacheResponse invalidateCachedFile pchannel name = do     respchan <- newChan     writeChan pchannel $ InvalidateCacheFile name respchan@@ -350,7 +348,7 @@         GetParsedData qtype name respchan -> do             (curmap, _, _) <- get             modify (\(mp, fm, rq) -> (mp, fm, rq + 1))-            case (Map.lookup (qtype, name) curmap) of+            case Map.lookup (qtype, name) curmap of                 Just x  -> liftIO $ writeChan respchan (RCacheEntry x)                 Nothing -> liftIO $ writeChan respchan NoCacheEntry         UpdateParsedData qtype name val@(_, filepath, filestatus, _) respchan -> do@@ -374,8 +372,8 @@             (mp, fm, rq) <- get             let                 nfm = Map.delete fname fm-                nmp = case (Map.lookup fname fm) of-                    Just (_, remlist) -> foldl' (\mp' el -> Map.delete el mp') mp remlist+                nmp = case Map.lookup fname fm of+                    Just (_, remlist) -> foldl' (flip Map.delete) mp remlist                     Nothing           -> mp             put (nmp, nfm, rq)             liftIO $ writeChan respchan CacheUpdated

@@ -22,9 +22,10 @@ import Puppet.Interpreter.Types  import Data.List-import Data.Char (isDigit)+import Data.Char (isDigit,toLower,toUpper) import Data.Maybe (isJust, fromJust, catMaybes) import Data.Either (lefts, rights, partitionEithers)+import Data.Ord (comparing) import Text.Parsec.Pos import Control.Monad.State import Control.Monad.Error@@ -32,9 +33,7 @@ import qualified Data.Set as Set  qualified []  = False-qualified str = case isPrefixOf "::" str of-    False -> qualified (tail str)-    True  -> True+qualified str = isPrefixOf "::" str || qualified (tail str)  throwPosError msg = do     p <- getPos@@ -42,9 +41,9 @@  -- Int handling stuff isInt :: String -> Bool-isInt = and . map isDigit+isInt = all isDigit readint :: String -> CatalogMonad Integer-readint x = if (isInt x)+readint x = if isInt x     then return (read x)     else throwPosError $ "Expected an integer instead of '" ++ x @@ -52,12 +51,12 @@ modifyVariables f sc = sc { curVariables   = f $ curVariables sc } modifyClasses   f sc = sc { curClasses     = f $ curClasses sc } modifyDefaults  f sc = sc { curDefaults    = f $ curDefaults sc }-incrementResId    sc = sc { curResId       = (curResId sc) + 1 }+incrementResId    sc = sc { curResId       = curResId sc + 1 } setStatePos  npos sc = sc { curPos         = npos } emptyDefaults     sc = sc { curDefaults    = [] }-pushWarning     t sc = sc { getWarnings    = (getWarnings sc) ++ [t] }-pushCollect   r   sc = sc { curCollect     = r : (curCollect sc) }-pushUnresRel  r   sc = sc { unresolvedRels = r : (unresolvedRels sc) }+pushWarning     t sc = sc { getWarnings    = getWarnings sc ++ [t] }+pushCollect   r   sc = sc { curCollect     = r : curCollect sc }+pushUnresRel  r   sc = sc { unresolvedRels = r : unresolvedRels sc }  getCatalog :: (TopLevelType -> String -> IO (Either String Statement))     -- ^ The \"get statements\" function. Given a top level type and its name it@@ -72,7 +71,7 @@     let convertedfacts = Map.map             (\fval -> (Right fval, initialPos "FACTS"))             facts-    (output, finalstate) <- runStateT ( runErrorT ( computeCatalog getstatements nodename ) ) (ScopeState ["::"] convertedfacts Map.empty [] 1 (initialPos "dummy") Map.empty getstatements [] [] [] gettemplate)+    (output, finalstate) <- runStateT ( runErrorT ( computeCatalog getstatements nodename ) ) (ScopeState [["::"]] convertedfacts Map.empty [] 1 (initialPos "dummy") Map.empty getstatements [] [] [] gettemplate)     case output of         Left x -> return (Left x, getWarnings finalstate)         Right _ -> return (output, getWarnings finalstate)@@ -94,27 +93,25 @@     rparams <- mapM (\(a,b) -> do { ra <- resolveGeneralString a; rb <- resolveGeneralValue b; return (ra,rb); }) cparams     -- add collected relations     -- TODO-    if Map.member ctype nativeTypes == False-        then throwPosError $ "Can't find native type " ++ ctype-        else return ()+    unless (Map.member ctype nativeTypes) $ throwPosError $ "Can't find native type " ++ ctype     let mrrelations = []         prefinalresource = RResource cid rname ctype (Map.fromList rparams) mrrelations cpos         validatefunction = puppetvalidate (nativeTypes Map.! ctype)         validated = validatefunction prefinalresource     case validated of         Left err -> throwError (err ++ " for resource " ++ ctype ++ "[" ++ rname ++ "] at " ++ show cpos)-        Right finalresource -> return $ ((ctype, rname), finalresource)+        Right finalresource -> return ((ctype, rname), finalresource)  -- This checks if a resource is to be collected. -- This returns a list as it can either return the original -- resource, the resource with a "normal" virtuality, or both, -- for exported resources (so that they can still be found as collected) collectionChecks :: CResource -> CatalogMonad [CResource]-collectionChecks res = do-    if (crvirtuality res == Normal)+collectionChecks res =+    if crvirtuality res == Normal         then return [res]         else do-            isCollected <- get >>= return . curCollect >>= mapM (\x -> x res)+            isCollected <- liftM curCollect get >>= mapM (\x -> x res)             case (or isCollected, crvirtuality res) of                 (True, Exported)    -> return [res { crvirtuality = Normal }, res]                 (True,  _)          -> return [res { crvirtuality = Normal }     ]@@ -129,9 +126,8 @@     --export stuff     --liftIO $ putStrLn "EXPORTED:"     --liftIO $ mapM print exported-    resolved <- mapM finalizeResource real >>= createResourceMap     --get >>= return . unresolvedRels >>= liftIO . (mapM print)-    return resolved+    mapM finalizeResource real >>= createResourceMap  createResourceMap :: [(ResIdentifier, RResource)] -> CatalogMonad FinalCatalog createResourceMap = foldM insertres Map.empty@@ -142,8 +138,8 @@             in case (rrtype res, oldres) of                 ("class", _) -> return newmap                 (_, Just r ) -> throwError $ "Resource already defined:"-                    ++ "\n\t" ++ (rrtype r)   ++ "[" ++ (rrname r)   ++ "] at " ++ show (rrpos r)-                    ++ "\n\t" ++ (rrtype res) ++ "[" ++ (rrname res) ++ "] at " ++ show (rrpos res)+                    ++ "\n\t" ++ rrtype r   ++ "[" ++ rrname r   ++ "] at " ++ show (rrpos r)+                    ++ "\n\t" ++ rrtype res ++ "[" ++ rrname res ++ "] at " ++ show (rrpos res)                 (_, Nothing) -> return newmap  getstatement :: TopLevelType -> String -> CatalogMonad Statement@@ -156,49 +152,51 @@         Right y -> return y  -- State alteration functions-pushScope name  = modify (modifyScope (\x -> [name] ++ x))-pushDefaults name  = modify (modifyDefaults (\x -> [name] ++ x))+pushScope = modify . modifyScope . (:)+pushDefaults = modify . modifyDefaults . (:) popScope        = modify (modifyScope tail) getScope        = do-    scope <- get >>= return . curScope-    if (null scope)+    scope <- liftM curScope get+    if null scope         then throwError "empty scope, shouldn't happen"         else return $ head scope-addLoaded name position = modify (modifyClasses (Map.insert name position))+addLoaded name = modify . modifyClasses . Map.insert name getNextId = do     curscope <- get     put $ incrementResId curscope     return (curResId curscope)-setPos p = modify (setStatePos p)-getPos = get >>= return . curPos-putVariable k v = do-    curscope <- getScope-    let qual = qualified k-        kk  | qual || (curscope == "::") = k-            | otherwise = "::" ++ k-    modify (modifyVariables (Map.insert (curscope ++ kk) v))-getVariable vname = get >>= return . Map.lookup vname . curVariables+setPos = modify . setStatePos+getPos = liftM curPos get++-- qualifies a variable k depending on the context cs+qualify k cs | qualified k || (cs == "::") = cs ++ k+             | otherwise = cs ++ "::" ++ k++-- This is a bit convoluted and misses a critical feature.+-- It adds the variable to all the scopes that are currently active.+-- BUG TODO : check that a variable is not already defined.+putVariable k v = getScope >>= mapM_ (\x -> modify (modifyVariables (Map.insert (qualify k x) v)))++getVariable vname = liftM (Map.lookup vname . curVariables) get++-- BUG TODO : top levels are qualified only with the head of the scopes addNestedTopLevel rtype rname rstatement = do     curstate <- get     let ctop = nestedtoplevels curstate-        curscope = head (curScope curstate)-        nname | curscope == "::" = rname-              | otherwise = curscope ++ "::" ++ rname+        curscope = head $ head (curScope curstate)+        nname = qualify rname curscope         nstatement = case rstatement of             DefineDeclaration _ prms stms cpos -> DefineDeclaration nname prms stms cpos             x -> x         ntop = Map.insert (rtype, nname) nstatement ctop         nstate = curstate { nestedtoplevels = ntop }     put nstate-addWarning nwrn   = modify (pushWarning nwrn)-addCollect ncol   = modify (pushCollect ncol)+addWarning = modify . pushWarning+addCollect = modify . pushCollect -- this pushes the relations only if they exist -- the parameter is of the form -- ( [dstrelations], srcresource, type, pos )-addUnresRel ncol@(rels, _, _, _)  = do-    if null rels-        then return ()-        else modify (pushUnresRel ncol)+addUnresRel ncol@(rels, _, _, _)  = unless (null rels) (modify (pushUnresRel ncol))  -- finds out if a resource name refers to a define checkDefine :: String -> CatalogMonad (Maybe Statement)@@ -238,22 +236,27 @@ -- TODO check whether parameters changed checkLoaded name = do     curscope <- get-    case (Map.lookup name (curClasses curscope)) of+    case Map.lookup name (curClasses curscope) of         Nothing -> return False         Just _  -> return True +-- function that takes a pair of Expressions and try to resolve the first as a string, the second as a generalvalue+resolveParams :: (Expression, Expression) -> CatalogMonad (GeneralString, GeneralValue)+resolveParams (a,b) = do+    ra <- tryResolveExpressionString a+    rb <- tryResolveExpression b+    return (ra, rb)+ -- apply default values to a resource applyDefaults :: CResource -> CatalogMonad CResource-applyDefaults res = do-    defs <- get >>= return . curDefaults -    foldM applyDefaults' res defs+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     srname <- resolveGeneralString rname-    rdefs <- mapM (\(a,b) -> do { ra <- tryResolveExpressionString a; rb <- tryResolveExpression b; return (ra, rb); }) defs+    rdefs <- mapM resolveParams defs     let (nparams, nrelations) = mergeParams rparams rdefs False -    if (dtype == rtype)+    if dtype == rtype         then do             addUnresRel (nrelations, (rtype, Right srname), UDefault, dpos)             return $ CResource i rname rtype nparams rvirtuality rpos@@ -261,9 +264,9 @@ applyDefaults' r@(CResource i rname rtype rparams rvirtuality rpos) (ResourceOverride dtype dname defs dpos) = do     srname <- resolveGeneralString rname     sdname <- resolveExpressionString dname-    rdefs <- mapM (\(a,b) -> do { ra <- tryResolveExpressionString a; rb <- tryResolveExpression b; return (ra, rb); }) defs+    rdefs <- mapM resolveParams defs     let (nparams, nrelations) = mergeParams rparams rdefs True-    if ((dtype == rtype) && (srname == sdname))+    if (dtype == rtype) && (srname == sdname)         then do             addUnresRel (nrelations, (rtype, Right srname), UDefault, dpos)             return $ CResource i rname rtype nparams rvirtuality rpos@@ -285,22 +288,23 @@  evaluateDefine :: CResource -> CatalogMonad [CResource] evaluateDefine r@(CResource _ rname rtype rparams rvirtuality rpos) = do+    setPos rpos     isdef <- checkDefine rtype     case (rvirtuality, isdef) of         (Normal, Just (DefineDeclaration dtype args dstmts dpos)) -> do             --oldpos <- getPos             setPos dpos-            pushScope $ "#DEFINE#" ++ dtype+            pushScope ["#DEFINE#" ++ dtype]             -- add variables             mrrparams <- mapM (\(gs, gv) -> do { rgs <- resolveGeneralString gs; rgv <- tryResolveGeneralValue gv; return (rgs, (rgv, dpos)); }) rparams             let expr = gs2gv rname                 mparams = Map.fromList mrrparams             putVariable "title" (expr, rpos)             putVariable "name" (expr, rpos)-            mapM (loadClassVariable rpos mparams) args+            mapM_ (loadClassVariable rpos mparams) args               -- parse statements-            res <- mapM (evaluateStatements) dstmts+            res <- mapM evaluateStatements dstmts             nres <- handleDelayedActions (concat res)             popScope             return nres@@ -310,21 +314,33 @@ -- handling delayed actions (such as defaults) handleDelayedActions :: Catalog -> CatalogMonad Catalog handleDelayedActions res = do-    dres <- mapM applyDefaults res >>= mapM evaluateDefine >>= return . concat+    dres <- liftM concat (mapM applyDefaults res >>= mapM evaluateDefine)     modify emptyDefaults     return dres +addResource :: String -> [(Expression, Expression)] -> Virtuality -> SourcePos -> GeneralValue -> CatalogMonad [CResource]+addResource rtype parameters virtuality position grname = do+    resid <- getNextId+    rparameters <- mapM resolveParams parameters+    -- il faut transformer grname qui est une generalvalue en generalstring+    srname <- case grname of+        Right e -> liftM Right (rstring e)+        Left  e -> return $ Left e+    let (realparams, relations) = partitionParamsRelations rparameters+    -- push all the relations+    addUnresRel (relations, (rtype, srname), UNormal, position)+    return [CResource resid srname rtype realparams virtuality position]+ -- node evaluateStatements :: Statement -> CatalogMonad Catalog evaluateStatements (Node _ stmts position) = do     setPos position-    res <- mapM (evaluateStatements) stmts-    nres <- handleDelayedActions (concat res)-    return nres+    res <- mapM evaluateStatements stmts+    handleDelayedActions (concat res)  -- include evaluateStatements (Include includename position) = setPos position >> getstatement TopClass includename >>= evaluateStatements-evaluateStatements x@(ClassDeclaration _ _ _ _ _) = evaluateClass x Map.empty Nothing+evaluateStatements x@(ClassDeclaration{}) = evaluateClass x Map.empty Nothing evaluateStatements n@(DefineDeclaration dtype _ _ _) = do     addNestedTopLevel TopDefine dtype n     return []@@ -332,7 +348,7 @@     setPos position     trues <- filterM (\(expr, _) -> resolveBoolean (Left expr)) exprs     case trues of-        ((_,stmts):_) -> mapM evaluateStatements stmts >>= return . concat+        ((_,stmts):_) -> liftM concat (mapM evaluateStatements stmts)         _ -> return []  evaluateStatements (Resource rtype rname parameters virtuality position) = do@@ -346,18 +362,15 @@             let classparameters = Map.fromList $ map (\(pname, pvalue) -> (pname, (pvalue, position))) rparameters             evaluateClass topstatement classparameters Nothing         _ -> do-            resid <- getNextId-            rparameters <- mapM (\(a,b) -> do { pa <- tryResolveExpressionString a; pb <- tryResolveExpression b; return (pa, pb) } ) parameters-            srname <- tryResolveExpressionString rname-            let (realparams, relations) = partitionParamsRelations rparameters-            -- push all the relations-            addUnresRel (relations, (rtype, srname), UNormal, position)-            return [CResource resid srname rtype realparams virtuality position]+            srname <- tryResolveExpression rname+            case srname of+                (Right (ResolvedArray arr)) -> fmap concat (mapM (addResource rtype parameters virtuality position . Right) arr)+                _ -> addResource rtype parameters virtuality position srname -evaluateStatements x@(ResourceDefault _ _ _ ) = do+evaluateStatements x@(ResourceDefault{}) = do     pushDefaults x     return []-evaluateStatements x@(ResourceOverride _ _ _ _) = do+evaluateStatements x@(ResourceOverride{}) = do     pushDefaults x     return [] evaluateStatements (DependenceChain (srctype, srcname) (dsttype, dstname) position) = do@@ -369,18 +382,14 @@ -- <<| |>> evaluateStatements (ResourceCollection rtype expr overrides position) = do     setPos position-    if null overrides-        then return ()-        else throwPosError "Collection overrides not handled"+    unless (null overrides) (throwPosError "Collection overrides not handled")     func <- collectionFunction Exported rtype expr     addCollect func     return [] -- <| |> evaluateStatements (VirtualResourceCollection rtype expr overrides position) = do     setPos position-    if null overrides-        then return ()-        else throwPosError "Collection overrides not handled"+    unless (null overrides) (throwPosError "Collection overrides not handled")     func <- collectionFunction Virtual rtype expr     addCollect func     return []@@ -397,10 +406,10 @@     executeFunction fname rargs  evaluateStatements (TopContainer toplevels curstatement) = do-    mapM (\(fname, stmt) -> evaluateClass stmt Map.empty (Just fname)) toplevels+    mapM_ (\(fname, stmt) -> evaluateClass stmt Map.empty (Just fname)) toplevels     evaluateStatements curstatement -evaluateStatements x = throwError ("Can't evaluate " ++ (show x))+evaluateStatements x = throwError ("Can't evaluate " ++ show x)  -- function used to load defines / class variables into the global context loadClassVariable :: SourcePos -> Map.Map String (GeneralValue, SourcePos) -> (String, Maybe Expression) -> CatalogMonad ()@@ -409,7 +418,7 @@     (v, vpos) <- case (inputvalue, defvalue) of         (Just x , _      ) -> return x         (Nothing, Just y ) -> return (Left y, position)-        (Nothing, Nothing) -> throwError $ "Must define parameter " ++ paramname ++ " at " ++ (show position)+        (Nothing, Nothing) -> throwError $ "Must define parameter " ++ paramname ++ " at " ++ show position     rv <- tryResolveGeneralValue v     putVariable paramname (rv, vpos)     return ()@@ -427,9 +436,11 @@         else do         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    -        pushScope classname -- sets the scope-        mapM (loadClassVariable position inputparams) parameters -- add variables for parametrized classes+        setPos position+        case actualname of+            Nothing -> pushScope [classname] -- sets the scope+            Just ac -> pushScope [classname, ac]+        mapM_ (loadClassVariable position inputparams) parameters -- add variables for parametrized classes                  -- load inherited classes         inherited <- case inherits of@@ -444,9 +455,9 @@             Just x  -> addLoaded x oldpos          -- parse statements-        res <- mapM (evaluateStatements) statements+        res <- mapM evaluateStatements statements         nres <- handleDelayedActions (concat res)-        mapM (addClassDependency classname) nres    -- this adds a dummy dependency to this class+        mapM_ (addClassDependency classname) nres   -- this adds a dummy dependency to this class                                                     -- for all resources that do not already depend on a class                                                     -- this is probably not puppet perfect with resources that                                                     -- depend explicitely on a class@@ -457,7 +468,7 @@             ++ nres  evaluateClass (TopContainer topstmts myclass) inputparams actualname = do-    mapM (\(n,x) -> evaluateClass x Map.empty (Just n)) topstmts+    mapM_ (\(n,x) -> evaluateClass x Map.empty (Just n)) topstmts     evaluateClass myclass inputparams actualname  evaluateClass x _ _ = throwError ("Someone managed to run evaluateClass against " ++ show x)@@ -469,7 +480,7 @@     , UPlus, position)  tryResolveExpression :: Expression -> CatalogMonad GeneralValue-tryResolveExpression e = tryResolveGeneralValue (Left e)+tryResolveExpression = tryResolveGeneralValue . Left  tryResolveGeneralValue :: GeneralValue -> CatalogMonad GeneralValue tryResolveGeneralValue n@(Right _) = return n@@ -481,7 +492,7 @@ tryResolveGeneralValue   (Left (ConditionalValue checkedvalue (Value (PuppetHash (Parameters hash))))) = do     rcheck <- resolveExpression checkedvalue     rhash <- mapM (\(vn, vv) -> do { rvn <- resolveExpression vn; return (rvn, vv) }) hash-    case (filter (\(a,_) -> (a == ResolvedString "default") || (compareRValues a rcheck)) rhash) of+    case filter (\(a,_) -> (a == ResolvedString "default") || compareRValues a rcheck) rhash of         [] -> throwPosError ("No value could be selected when comparing to " ++ show rcheck)         ((_,x):_) -> tryResolveExpression x tryResolveGeneralValue n@(Left (EqualOperation      a b))   = compareGeneralValue n a b [EQ]@@ -490,7 +501,6 @@ tryResolveGeneralValue n@(Left (UnderEqualOperation a b))   = compareGeneralValue n a b [LT,EQ] tryResolveGeneralValue n@(Left (UnderOperation      a b))   = compareGeneralValue n a b [LT] tryResolveGeneralValue n@(Left (DifferentOperation  a b))   = compareGeneralValue n a b [LT,GT]- tryResolveGeneralValue n@(Left (OrOperation a b)) = do     ra <- tryResolveBoolean $ Left a     rb <- tryResolveBoolean $ Left b@@ -506,7 +516,7 @@ tryResolveGeneralValue   (Left (NotOperation x)) = do     rx <- tryResolveBoolean $ Left x     case rx of-        Right (ResolvedBool b) -> return $ Right $ ResolvedBool $ (not b)+        Right (ResolvedBool b) -> return $ Right $ ResolvedBool $ not b         _ -> return rx tryResolveGeneralValue (Left (LookupOperation a b)) = do     ra <- tryResolveExpression a@@ -515,14 +525,14 @@         (Right (ResolvedArray ar), Right num) -> do             bnum <- readint num             let nnum = fromIntegral bnum-            if(length ar >= nnum)-                then throwPosError ("Invalid array index " ++ num)+            if length ar <= nnum+                then throwPosError ("Invalid array index " ++ num ++ " " ++ show ar)                 else return $ Right (ar !! nnum)         (Right (ResolvedHash ar), Right idx) -> do             let filtered = filter (\(x,_) -> x == idx) ar             case filtered of                 [] -> throwError "TODO empty filtered"-                [(_,x)] -> return $ Right $ x+                [(_,x)] -> return $ Right x                 x  -> throwPosError ("Hum, WTF tryResolveGeneralValue " ++ show x)         (_, Left y) -> throwPosError ("Could not resolve index " ++ show y)         (Left x, _) -> throwPosError ("Could not resolve lookup " ++ show x)@@ -537,6 +547,11 @@                 then return $ Right $ ResolvedBool False                 else return $ Right $ ResolvedBool True         _ -> return o+-- horrible hack, because I do not know how to supply a single operator for Int and Float+tryResolveGeneralValue o@(Left (PlusOperation a b)) = arithmeticOperation a b (+) (+) o+tryResolveGeneralValue o@(Left (MinusOperation a b)) = arithmeticOperation a b (-) (-) o+tryResolveGeneralValue o@(Left (DivOperation a b)) = arithmeticOperation a b div (/) o+tryResolveGeneralValue o@(Left (MultiplyOperation a b)) = arithmeticOperation a b (*) (*) o              tryResolveGeneralValue e = throwPosError ("tryResolveGeneralValue not implemented for " ++ show e) @@ -551,7 +566,7 @@ tryResolveExpressionString s = do     resolved <- tryResolveExpression s     case resolved of-        Right e -> rstring e >>= return . Right+        Right e -> liftM Right (rstring e)         Left  e -> return $ Left e  rstring :: ResolvedValue -> CatalogMonad String@@ -590,56 +605,62 @@     case rvals of         Right resolved -> return $ Right $ ResolvedRReference rtype resolved         _              -> return $ Left $ Value n-+-- special variables first+tryResolveValue   (VariableReference "module_name") = liftM (\x ->+    case (takeWhile (/= ':') . head) x of+        '#':'D':'E':'F':'I':'N':'E':'#':xs -> Right $ ResolvedString xs+        r                                  -> Right $ ResolvedString r+    ) getScope tryResolveValue   (VariableReference vname) = do     -- TODO check scopes !!!     curscp <- getScope-    let varnames | qualified vname          = [vname] ++ remtopscope vname              -- scope is explicit-                 | curscp == "::"           = ["::" ++ vname]                           -- we are toplevel-                 | otherwise                = [curscp ++ "::" ++ vname, "::" ++ vname]  -- check for local scope, then global+    let gvarnm sc | qualified vname = vname : remtopscope vname                 -- scope is explicit+                  | sc == "::"      = ["::" ++ vname]                           -- we are toplevel+                  | otherwise       = [sc ++ "::" ++ vname, "::" ++ vname]  -- check for local scope, then global+        varnames = concatMap gvarnm curscp         remtopscope (':':':':xs) = [xs]         remtopscope _            = []-    matching <- mapM getVariable varnames >>= return . catMaybes+    matching <- liftM catMaybes (mapM getVariable varnames)     if null matching         then do             position <- getPos             addWarning ("Could not resolveValue " ++ show varnames ++ " at " ++ show position)             return $ Left $ Value $ VariableReference (head varnames)-        else return $ case (head matching) of+        else return $ case head matching of             (x,_) -> x  tryResolveValue n@(Interpolable x) = do     resolved <- mapM tryResolveValueString x-    if (null $ lefts resolved)+    if null $ lefts resolved         then return $ Right $ ResolvedString $ concat $ rights resolved         else return $ Left $ Value n  tryResolveValue n@(PuppetHash (Parameters x)) = do     resolvedKeys <- mapM (tryResolveExpressionString . fst) x     resolvedValues <- mapM (tryResolveExpression . snd) x-    if ((null $ lefts resolvedKeys) && (null $ lefts resolvedValues))+    if null (lefts resolvedKeys) && null (lefts resolvedValues)         then return $ Right $ ResolvedHash $ zip (rights resolvedKeys) (rights resolvedValues)         else return $ Left $ Value n  tryResolveValue n@(PuppetArray expressions) = do     resolvedExpressions <- mapM tryResolveExpression expressions-    if (null $ lefts resolvedExpressions)+    if null $ lefts resolvedExpressions         then return $ Right $ ResolvedArray $ rights resolvedExpressions         else return $ Left $ Value n  -- TODO-tryResolveValue   (FunctionCall "fqdn_rand" args) = if (null args)+tryResolveValue   (FunctionCall "fqdn_rand" args) = if null args     then throwPosError "Empty argument list in fqdn_rand call"     else do         nargs  <- mapM resolveExpressionString args         curmax <- readint (head nargs)-        fqdn_rand curmax (tail nargs) >>= return . Right . ResolvedInt-tryResolveValue   (FunctionCall "mysql_password" args) = if (length args /= 1)+        liftM (Right . ResolvedInt) (fqdn_rand curmax (tail nargs))+tryResolveValue   (FunctionCall "mysql_password" args) = if length args /= 1     then throwPosError "mysql_password takes a single argument"     else do         es <- tryResolveExpressionString (head args)         case es of-            Right s -> mysql_password s >>= return . Right . ResolvedString+            Right s -> liftM (Right . ResolvedString) (mysql_password s)             Left  u -> return $ Left u tryResolveValue   (FunctionCall "jbossmem" _) = return $ Right $ ResolvedString "512" tryResolveValue   (FunctionCall "template" [name]) = do@@ -648,24 +669,55 @@         Left x -> throwPosError $ "Can't resolve template path " ++ show x         Right filename -> do             vars <- get >>= mapM (\(varname, (varval, _)) -> do { rvarval <- tryResolveGeneralValue varval; return (varname, rvarval) }) . Map.toList . curVariables-            scp <- getScope-            templatefunc <- get >>= return . computeTemplateFunction+            scp <- liftM head getScope -- TODO check if that sucks+            templatefunc <- liftM computeTemplateFunction get             out <- liftIO (templatefunc filename scp vars)             case out of                 Right x -> return $ Right $ ResolvedString x                 Left err -> throwPosError err tryResolveValue   (FunctionCall "inline_template" _) = return $ Right $ ResolvedString "TODO"-tryResolveValue   (FunctionCall "regsubst" [str, src, dst, flags]) = do+tryResolveValue   (FunctionCall "defined" [v]) = do+    rv <- tryResolveExpression v+    case rv of+        Left n -> return $ Left n+        -- TODO BUG+        Right (ResolvedString typeorclass) ->+            -- is it a loaded class or a define ?+            if Map.member typeorclass nativeTypes+                then return $ Right $ ResolvedBool True+                else do+                    isdefine <- checkDefine typeorclass+                    case isdefine of+                        Just _  -> return $ Right $ ResolvedBool True+                        Nothing -> liftM (Right . ResolvedBool . Map.member typeorclass . curClasses) get+        Right (ResolvedRReference _ (ResolvedString _)) -> do+            position <- getPos+            addWarning $ "The defined() function is not implemented for resource references. Returning true at " ++ show position+            return $ Right $ ResolvedBool True+        Right x -> throwPosError $ "Can't know if this could be defined : " ++ show x+tryResolveValue n@(FunctionCall "regsubst" [str, src, dst, flags]) = do     rstr   <- tryResolveExpressionString str     rsrc   <- tryResolveExpressionString src     rdst   <- tryResolveExpressionString dst     rflags <- tryResolveExpressionString flags     case (rstr, rsrc, rdst, rflags) of-        (Right sstr, Right ssrc, Right sdst, Right sflags) -> regsubst sstr ssrc sdst sflags >>= return . Right . ResolvedString-        x                                                  -> throwPosError ("Could not run regsubst because something here could not be resolved: " ++ show x)+        (Right sstr, Right ssrc, Right sdst, Right sflags) -> liftM (Right . ResolvedString) (regsubst sstr ssrc sdst sflags)+        _                                                  -> return $ Left $ Value n tryResolveValue   (FunctionCall "regsubst" [str, src, dst]) = tryResolveValue (FunctionCall "regsubst" [str, src, dst, Value $ Literal ""]) tryResolveValue   (FunctionCall "regsubst" args) = throwPosError ("Bad argument count for regsubst " ++ show args)-       ++tryResolveValue n@(FunctionCall "split" [str, reg]) = do+    rstr   <- tryResolveExpressionString str+    rreg   <- tryResolveExpressionString reg+    case (rstr, rreg) of+        (Right sstr, Right sreg) -> return $ Right $ ResolvedArray $ map ResolvedString $ puppetSplit sstr sreg+        _                        -> return $ Left $ Value n+tryResolveValue   (FunctionCall "split" _) = throwPosError "Bad argument count for function split"+tryResolveValue n@(FunctionCall "upcase"  args) = stringTransform args n (map toUpper)+tryResolveValue n@(FunctionCall "lowcase" args) = stringTransform args n (map toLower)+tryResolveValue n@(FunctionCall "sha1"    args) = stringTransform args n puppetSHA1+tryResolveValue n@(FunctionCall "md5"     args) = stringTransform args n puppetMD5+ tryResolveValue n@(FunctionCall "versioncmp" [a,b]) = do     ra <- tryResolveExpressionString a     rb <- tryResolveExpressionString b@@ -680,16 +732,13 @@         then do             content <- liftIO $ file rf             case content of-                Nothing -> do-                    position <- getPos-                    addWarning $ "Files " ++ show rf ++ " could not be found at " ++ show position-                    return $ Right $ ResolvedString ""+                Nothing -> throwPosError $ "Files " ++ show rf ++ " could not be found"                 Just x  -> return $ Right $ ResolvedString x         else return $ Left $ Value n-    + tryResolveValue   (FunctionCall fname _) = throwPosError ("FunctionCall " ++ fname ++ " not implemented") -tryResolveValue Undefined = return $ Right $ ResolvedUndefined+tryResolveValue Undefined = return $ Right ResolvedUndefined tryResolveValue (PuppetRegexp x) = return $ Right $ ResolvedRegexp x  tryResolveValue x = throwPosError ("tryResolveValue not implemented for " ++ show x)@@ -714,10 +763,9 @@ pushRealize :: ResolvedValue -> CatalogMonad () pushRealize (ResolvedRReference rtype (ResolvedString rname)) = do     let myfunction :: CResource -> CatalogMonad Bool-        myfunction = (\(CResource _ mcrname mcrtype _ _ _) -> do+        myfunction (CResource _ mcrname mcrtype _ _ _) = do             srname <- resolveGeneralString mcrname             return ((srname == rname) && (mcrtype == rtype))-            )     addCollect myfunction     return () pushRealize (ResolvedRReference _ x) = throwPosError (show x ++ " was not resolved to a string")@@ -726,7 +774,7 @@ executeFunction :: String -> [ResolvedValue] -> CatalogMonad Catalog executeFunction "fail" [ResolvedString errmsg] = throwPosError ("Error: " ++ errmsg) executeFunction "fail" args = throwPosError ("Error: " ++ show args)-executeFunction "realize" rlist = mapM pushRealize rlist >> return []+executeFunction "realize" rlist = mapM_ pushRealize rlist >> return [] executeFunction "create_resources" [mrtype, rdefs] = do     mrrtype <- case mrtype of         ResolvedString x -> return x@@ -742,7 +790,7 @@                 _                    -> throwPosError "This should not happen, create_resources argument is not a hash"             return $ Resource mrrtype resname realargs Normal position         ) prestatements-    mapM evaluateStatements resources >>= return . concat+    liftM concat (mapM evaluateStatements resources) executeFunction "create_resources" x = throwPosError ("Bad arguments to create_resources: " ++ show x) executeFunction a b = do     position <- getPos@@ -769,16 +817,17 @@     cmp <- compareExpression a b     case cmp of         Nothing -> return n-        Just x  -> return $ Right $ ResolvedBool (elem x acceptable)+        Just x  -> return $ Right $ ResolvedBool (x `elem` acceptable) compareValues :: ResolvedValue -> ResolvedValue -> Ordering compareValues a@(ResolvedString _) b@(ResolvedInt _) = compareValues b a compareValues   (ResolvedInt a)      (ResolvedString b) | isInt b = compare a (read b)                                                         | otherwise = LT-compareValues (ResolvedString a) (ResolvedRegexp b) = if (regmatch a b) then EQ else LT+compareValues (ResolvedString a) (ResolvedRegexp b) = if regmatch a b then EQ else LT+compareValues (ResolvedString a) (ResolvedString b) = comparing (map toLower) a b compareValues x y = compare x y  compareRValues :: ResolvedValue -> ResolvedValue -> Bool-compareRValues a b = (compareValues a b) == EQ+compareRValues a b = compareValues a b == EQ  -- used to handle the special cases when we know it is a boolean context tryResolveBoolean :: GeneralValue -> CatalogMonad GeneralValue@@ -789,7 +838,7 @@         Right (ResolvedString _)    -> return $ Right $ ResolvedBool True         Right (ResolvedInt 0)       -> return $ Right $ ResolvedBool False         Right (ResolvedInt _)       -> return $ Right $ ResolvedBool True-        Right (ResolvedUndefined)   -> return $ Right $ ResolvedBool False+        Right  ResolvedUndefined    -> return $ Right $ ResolvedBool False         Left (Value (VariableReference _)) -> return $ Right $ ResolvedBool False         Left (EqualOperation (Value (VariableReference _)) (Value (Literal ""))) -> return $ Right $ ResolvedBool True -- case where a variable was not resolved and compared to the empty string         Left (EqualOperation (Value (VariableReference _)) (Value (Literal "true"))) -> return $ Right $ ResolvedBool False -- case where a variable was not resolved and compared to the string "true"@@ -820,20 +869,19 @@             rb <- resolveExpression b             paramname <- case ra of                 ResolvedString pname -> return pname-                _ -> throwPosError $ "We only support collection of the form 'parameter == value'" +                _ -> throwPosError "We only support collection of the form 'parameter == value'"              defstatement <- checkDefine mrtype             paramset <- case defstatement of-                Nothing -> case (Map.lookup mrtype nativeTypes) of+                Nothing -> case Map.lookup mrtype nativeTypes of                     Just (PuppetTypeMethods _ ps) -> return ps                     Nothing -> throwPosError $ "Unknown type " ++ mrtype ++ " when trying to collect"                 Just (DefineDeclaration _ params _ _) -> return $ Set.fromList $ map fst params                 Just x -> throwPosError $ "Expected a DefineDeclaration here instead of " ++ show x-            if (Set.notMember paramname paramset) && (paramname /= "tag")-                then throwPosError $ "Parameter " ++ paramname ++ " is not a valid parameter. It should be in : " ++ show (Set.toList paramset)-                else return ()+            when (Set.notMember paramname paramset && (paramname /= "tag")) $+                throwPosError $ "Parameter " ++ paramname ++ " is not a valid parameter. It should be in : " ++ show (Set.toList paramset)             return (\r -> do                 let param = filter (\x -> fst x == Right paramname) (crparams r)-                if length param == 0+                if null param                     then return False                     else do                         cmp <- resolveGeneralValue $ snd (head param)@@ -841,7 +889,7 @@                 )         x -> throwPosError $ "TODO : implement collection function for " ++ show x     return (\res ->-        if ((crtype res == mrtype) && (crvirtuality res == virt))+        if (crtype res == mrtype) && (crvirtuality res == virt)             then finalfunc res             else return False             )@@ -855,5 +903,26 @@ resolved2expression (ResolvedRReference mrtype name) = Value $ ResourceReference mrtype (resolved2expression name) resolved2expression (ResolvedArray vals) = Value $ PuppetArray $ map resolved2expression vals resolved2expression (ResolvedHash hash) = Value $ PuppetHash $ Parameters $ map (\(s,v) -> (Value $ Literal s, resolved2expression v)) hash-resolved2expression (ResolvedUndefined) = Value $ Undefined+resolved2expression  ResolvedUndefined = Value Undefined resolved2expression (ResolvedRegexp a) = Value $ PuppetRegexp a+resolved2expression (ResolvedDouble d) = Value $ Double d++arithmeticOperation :: Expression -> Expression -> (Integer -> Integer -> Integer) -> (Double -> Double -> Double) -> GeneralValue -> CatalogMonad GeneralValue+arithmeticOperation a b opi opf def = do+    ra <- tryResolveExpression a+    rb <- tryResolveExpression b+    case (ra, rb) of+        (Right (ResolvedInt sa)   , Right (ResolvedInt    sb)) -> return $ Right $ ResolvedInt $ opi sa sb+        (Right (ResolvedDouble sa), Right (ResolvedInt    sb)) -> return $ Right $ ResolvedDouble $ opf sa (fromIntegral sb)+        (Right (ResolvedInt sa)   , Right (ResolvedDouble sb)) -> return $ Right $ ResolvedDouble $ opf (fromIntegral sa) sb+        (Right (ResolvedDouble sa), Right (ResolvedDouble sb)) -> return $ Right $ ResolvedDouble $ opf sa sb+        _ -> return def+++stringTransform :: [Expression] -> Value -> (String -> String) -> CatalogMonad GeneralValue+stringTransform [u] n f = do+    r <- tryResolveExpressionString u+    case r of+        Right s -> return $ Right $ ResolvedString $ f s+        Left _  -> return $ Left $ Value n+stringTransform _ _ _ = throwPosError "This function takes a single argument."

@@ -5,16 +5,24 @@     ,regmatch     ,versioncmp     ,file+    ,puppetSplit+    ,puppetSHA1+    ,puppetMD5     ) where  import Data.Hash.MD5 import qualified Crypto.Hash.SHA1 as SHA1 import qualified Data.ByteString.Char8 as BS-import Data.String.Utils (join)+import Data.String.Utils (join,replace) import Text.RegexPR import Puppet.Interpreter.Types import Control.Monad.Error import System.IO+import qualified Data.ByteString.Base16 as B16++puppetMD5  = md5s . Str+puppetSHA1 = BS.unpack . B16.encode . SHA1.hash . BS.pack+ {- TODO : achieve compatibility with puppet the first String must be the fqdn@@ -28,29 +36,26 @@ mysql_password :: String -> CatalogMonad String mysql_password pwd = return $ '*':hash     where-        hash = BS.unpack $ SHA1.hash (BS.pack pwd)+        hash = puppetSHA1 pwd  regsubst :: String -> String -> String -> String -> CatalogMonad String regsubst str src dst flags = do-    let multiline   = elem 'M' flags-        extended    = elem 'E' flags-        insensitive = elem 'I' flags-        global      = elem 'G' flags+    let multiline   = 'M' `elem` flags+        extended    = 'E' `elem` flags+        insensitive = 'I' `elem` flags+        global      = 'G' `elem` flags         refunc | global = gsubRegexPR                | otherwise = subRegexPR-    if multiline-        then throwError "Multiline flag not implemented"-        else return ()-    if extended-        then throwError "Extended flag not implemented"-        else return ()-    if insensitive-        then throwError "Case insensitive flag not implemented"-        else return ()-    return $ refunc src dst str+    when multiline   $ throwError "Multiline flag not implemented"+    when extended    $ throwError "Extended flag not implemented"+    when insensitive $ throwError "Case insensitive flag not implemented"+    return $ refunc (alterregexp src) dst str +alterregexp :: String -> String+alterregexp = replace "\\n" "\n"+ regmatch :: String -> String -> Bool-regmatch str reg = case matchRegexPR str reg of+regmatch str reg = case matchRegexPR (alterregexp str) reg of     Just _  -> True     Nothing -> False @@ -62,4 +67,7 @@  file :: [String] -> IO (Maybe String) file [] = return Nothing-file (x:xs) = catch (withFile x ReadMode hGetContents >>= return . Just) (\_ -> file xs)+file (x:xs) = catch (liftM Just (withFile x ReadMode hGetContents)) (\_ -> file xs)++puppetSplit :: String -> String -> [String]+puppetSplit str reg = splitRegexPR reg str

@@ -17,13 +17,14 @@ -- 'FinalCatalog' and in the resolved parts of a 'Catalog'. They are to be -- compared with the 'Value's. data ResolvedValue-    = ResolvedString !String-    | ResolvedRegexp !String-    | ResolvedInt   !Integer-    | ResolvedBool !Bool+    = ResolvedString     !String+    | ResolvedRegexp     !String+    | ResolvedInt        !Integer+    | ResolvedDouble     !Double+    | ResolvedBool       !Bool     | ResolvedRReference !String !ResolvedValue-    | ResolvedArray ![ResolvedValue]-    | ResolvedHash ![(String, ResolvedValue)]+    | ResolvedArray      ![ResolvedValue]+    | ResolvedHash       ![(String, ResolvedValue)]     | ResolvedUndefined     deriving(Show, Eq, Ord) @@ -81,9 +82,11 @@ internal state. -} data ScopeState = ScopeState {-    curScope :: ![ScopeName],+    curScope :: ![[ScopeName]],     -- ^ The list of scopes. It works like a stack, and its initial value must-    -- be @[\"::\"]@+    -- be @[[\"::\"]]@. It is a stack of lists of strings. These lists can be+    -- one element wide (usual case), or two elements (inheritance), so that+    -- variables could be assigned to both scopes.     curVariables :: !(Map.Map String (GeneralValue, SourcePos)),     -- ^ The list of known variables. It should be noted that the interpreter     -- tries to resolve them as soon as it can, so that it can store their@@ -121,11 +124,11 @@ type CatalogMonad = ErrorT String (StateT ScopeState IO)  generalizeValueE :: Expression -> GeneralValue-generalizeValueE e = Left e+generalizeValueE = Left generalizeValueR :: ResolvedValue -> GeneralValue-generalizeValueR e = Right e+generalizeValueR = Right generalizeStringE :: Expression -> GeneralString-generalizeStringE s = Left s+generalizeStringE = Left generalizeStringS :: String -> GeneralString-generalizeStringS s = Right s+generalizeStringS = Right 

@@ -7,8 +7,8 @@  fakeTypes = map faketype ["class", "ssh_authorized_key_secure"] -defaultTypes = map defaulttype ["augeas","computer","cron","exec","filebucket","group","host","interface","k5login","macauthorization","mailalias","maillist","mcx","mount","nagios_command","nagios_contact","nagios_contactgroup","nagios_host","nagios_hostdependency","nagios_hostescalation","nagios_hostextinfo","nagios_hostgroup","nagios_service","nagios_servicedependency","nagios_serviceescalation","nagios_serviceextinfo","nagios_servicegroup","nagios_timeperiod","notify","package","resources","router","schedule","scheduledtask","selboolean","selmodule","service","sshauthorizedkey","sshkey","stage","tidy","user","vlan","yumrepo","zfs","zone","zpool","mysql_database","mysql_user","mysql_grant"]+defaultTypes = map defaulttype ["augeas","computer","cron","exec","filebucket","group","host","interface","k5login","macauthorization","mailalias","maillist","mcx","mount","nagios_command","nagios_contact","nagios_contactgroup","nagios_host","nagios_hostdependency","nagios_hostescalation","nagios_hostextinfo","nagios_hostgroup","nagios_service","nagios_servicedependency","nagios_serviceescalation","nagios_serviceextinfo","nagios_servicegroup","nagios_timeperiod","notify","package","resources","router","schedule","scheduledtask","selboolean","selmodule","service","sshauthorizedkey","sshkey","stage","tidy","user","vlan","yumrepo","zfs","zone","zpool","mysql_database","mysql_user","mysql_grant","anchor"]  -- | The map of native types. They are described in "Puppet.NativeTypes.Helpers".-nativeTypes :: Map.Map PuppetTypeName (PuppetTypeMethods)+nativeTypes :: Map.Map PuppetTypeName PuppetTypeMethods nativeTypes = Map.fromList (fakeTypes ++ defaultTypes ++ nativeFile)

@@ -41,6 +41,6 @@     parammap = rrparams res     source    = Map.member "source"  parammap     content   = Map.member "content" parammap-    in if (source && content)+    in if source && content         then Left "Source and content can't be specified at the same time"         else Right res

@@ -19,7 +19,7 @@     }  faketype :: PuppetTypeName -> (PuppetTypeName, PuppetTypeMethods)-faketype tname = (tname, PuppetTypeMethods (\x -> Right x) Set.empty)+faketype tname = (tname, PuppetTypeMethods Right Set.empty)  defaulttype :: PuppetTypeName -> (PuppetTypeName, PuppetTypeMethods) defaulttype tname = (tname, PuppetTypeMethods (defaultValidate Set.empty) Set.empty)@@ -34,7 +34,7 @@ checkParameterList validparameters res | Set.null validparameters = Right res                                        | otherwise = if Set.null setdiff                                             then Right res-                                            else Left $ "Unknown parameters " ++ (show $ Set.toList setdiff)+                                            else Left $ "Unknown parameters " ++ show (Set.toList setdiff)     where         keyset = Map.keysSet (rrparams res)         setdiff = Set.difference keyset (Set.insert "tag" validparameters)@@ -52,7 +52,7 @@ 'ResolvedBool' it will convert them to strings. -} string :: String -> PuppetTypeValidate-string param res = case (Map.lookup param (rrparams res)) of+string param res = case Map.lookup param (rrparams res) of     Just (ResolvedString _)   -> Right res     Just (ResolvedInt n)      -> Right (insertparam res param (ResolvedString $ show n))     Just (ResolvedBool True)  -> Right (insertparam res param (ResolvedString "true"))@@ -63,7 +63,7 @@ -- | Makes sure that the parameter, if defined, has a value among this list. values :: [String] -> String -> PuppetTypeValidate values valuelist param res = case (Map.lookup param (rrparams res)) of-    Just (ResolvedString x) -> if (elem x valuelist)+    Just (ResolvedString x) -> if elem x valuelist         then Right res         else Left $ "Parameter " ++ param ++ " value should be one of " ++ show valuelist     Just _  -> Left $ "Parameter " ++ param ++ " value should be one of " ++ show valuelist@@ -85,7 +85,7 @@     where         integer' pr rs = case (Map.lookup pr (rrparams rs)) of             Nothing -> Right rs-            Just (ResolvedString x) -> if (all isDigit x)+            Just (ResolvedString x) -> if all isDigit x                 then Right $ insertparam rs pr (ResolvedInt $ read x)                 else Left $ "Parameter " ++ pr ++ " should be a number"             Just (ResolvedInt _) -> Right rs

@@ -40,8 +40,8 @@     where         showrres (RResource _ rname _ params rels mpos)  =             "    " ++ show rname ++ ":" ++ " #" ++ show mpos ++ "\n"-                ++ commaretsep (map showparams (Map.toList params))-                ++ commareqs ((null rels) || (Map.null params))+                ++ commaretsep (map showparams (Map.toList $ Map.delete "title" params))+                ++ commareqs (null rels || Map.null params)                 ++ commaretsep (map showrequire (sort rels)) ++ ";\n"         commareqs c | c             = ""                     | otherwise     = ",\n"

@@ -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.3+Version:             0.1.4  -- A short (one-line) description of the package. Synopsis:            Tools to parse and evaluate the Puppet DSL.@@ -53,10 +53,10 @@                        Puppet.Interpreter.Types, Puppet.Interpreter.Catalog, Puppet.NativeTypes.Helpers      -- Packages needed in order to build this package.-  Build-depends:       base >=3 && <5,parsec,MissingH,containers,pretty,mtl,unix,hslogger,filepath,Glob,regexpr,process,bytestring,cryptohash+  Build-depends:       base >=3 && <5,parsec,MissingH,containers,pretty,mtl,unix,hslogger,filepath,Glob,regexpr,process,bytestring,cryptohash,base16-bytestring      -- Modules not exported by this package.-  Other-modules:       Puppet.Interpreter.Functions, Puppet.NativeTypes.File, Erb.Compute, SafeProcess, Paths_language_puppet, Erb.Parser, Erb.Ruby+  Other-modules:       Puppet.Interpreter.Functions, Puppet.NativeTypes.File, Erb.Compute, SafeProcess, Paths_language_puppet, Erb.Parser, Erb.Ruby, Erb.Evaluate      -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.   -- Build-tools: