<commit_before>{-# LANGUAGE GADTs        #-}
{-# LANGUAGE LambdaCase   #-}
{-# LANGUAGE RankNTypes   #-}
module Puppet.Interpreter
       ( interpretCatalog
       , evaluateStatement
       , computeCatalog
       ) where

import           Control.Applicative
import           Control.Lens hiding (ignored)
import           Control.Monad.Except
import           Control.Monad.Operational        hiding (view)
import           Control.Monad.Trans.Except
import qualified Data.Either.Strict               as S
import           Data.Foldable                    (foldl', foldlM, toList)
import qualified Data.Graph                       as G
import qualified Data.HashMap.Strict              as HM
import qualified Data.HashSet                     as HS
import           Data.List                        (nubBy, sortBy)
import           Data.Maybe
import qualified Data.Maybe.Strict                as S
import           Data.Ord                         (comparing)
import           Data.Semigroup                   (Max(..))
import           Data.Text (Text)
import qualified Data.Text                        as T
import           Data.Traversable                 (for)
import qualified Data.Tree                        as T
import           Data.Tuple.Strict                (Pair (..))
import qualified Data.Vector                      as V
import           System.Log.Logger

import           Puppet.Interpreter.PrettyPrinter (containerComma)
import           Puppet.Interpreter.Resolve
import           Puppet.Interpreter.Types
import           Puppet.Interpreter.Utils
import           Puppet.Interpreter.IO
import           Puppet.Lens
import           Puppet.NativeTypes
import           Puppet.Parser.PrettyPrinter
import           Puppet.Parser.Types
import           Puppet.Parser.Utils
import           Puppet.PP
import           Puppet.Utils


{-| Call the operational 'interpretMonad' function to compute the catalog.
    Returns either an error, or a tuple containing all the resources,
    dependency map, exported resources, and defined resources alongside with
    all messages that have been generated by the compilation process.

    The later 'definedResources' (eg. all class declarations) are pulled out of the
    'InterpreterState' and might not be up to date.
    There are only useful for coverage testing (checking dependencies for instance).
-}
interpretCatalog :: (Functor m, Monad m)
           => InterpreterReader m -- ^ The whole environment required for computing catalog.
           -> NodeName
           -> Facts
           -> Container Text -- ^ Server settings
           -> m (Pair (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource]))  [Pair Priority Doc])
interpretCatalog interpretReader node facts settings = do
    (output, _, warnings) <- interpretMonad interpretReader (initialState facts settings) (computeCatalog node)
    return (strictifyEither output :!: warnings)

isParent :: Text -> CurContainerDesc -> InterpreterMonad Bool
isParent cur (ContClass possibleparent) = preuse (scopes . ix cur . scopeParent) >>= \case
        Nothing         -> throwPosError ("Internal error: could not find scope" <+> ttext cur <+> "possible parent" <+> ttext possibleparent)
        Just S.Nothing  -> return False
        Just (S.Just p) -> if p == possibleparent
                               then return True
                               else isParent p (ContClass possibleparent)
isParent _ _ = return False

-- | Apply resource defaults, references overrides and expand defines
finalize :: [Resource] -> InterpreterMonad [Resource]
finalize rx = do
    scp  <- getScopeName
    resdefaults <- use (scopes . ix scp . scopeResDefaults)
    let getOver = use (scopes . ix scp . scopeOverrides) -- retrieves current overrides
        addResDefaults r = ifoldlM (addAttribute CantReplace) r resdefval
            where resdefval = resdefaults ^. ix (r ^. rid . itype) . resDefValues
        addOverrides r = getOver >>= foldlM addOverrides' r . view (at (r ^. rid))
        addOverrides' r (ResRefOverride _ prms p) = do
            -- we used this override, so we discard it
            scopes . ix scp . scopeOverrides . at (r ^. rid) .= Nothing
            let forb msg  = throwPosError ("Override of parameters ("
                                          <> list (map (ttext . fst) $ itoList prms)
                                          <> ") of the following resource is forbidden in the current context:"
                                          </> pretty r
                                          <+>  showPPos p
                                          </> ":"
                                          <+> msg)
            s <- getScope
            overrideType <- case r ^. rscope of
                                [] -> forb "Could not find the current resource context" -- we could not get the current resource context
                                (x:_) -> if x == s
                                             then return CantOverride -- we are in the same context : can't replace, but add stuff
                                             else isParent (scopeName s) x >>= \i ->
                                                if i || (r ^. rid . itype == "class")
                                                    then return Replace -- we can override what's defined in a parent
                                                    else forb "Can't override something that was not defined in the parent."
            ifoldlM (addAttribute overrideType) r prms
    -- step 1, apply resDefaults and resRefOverride
    withDefaults <- mapM (addOverrides >=> addResDefaults) rx
    -- There might be some overrides that could not be applied. The only
    -- valid reason is that they override something in exported resources.
    --
    -- it probably do something unexpected on defines, but let's keep it that way for now.
    let keepforlater (ResRefOverride resid resprms ropos) = resMod %= (appended : )
            where
               appended = ResourceModifier (resid ^. itype) ModifierMustMatch DontRealize (REqualitySearch "title" (PString (resid ^. iname))) overrider ropos
               overrider r = do
                   -- we must define if we can override the value
                   let canOverride = CantOverride -- TODO check inheritance
                   ifoldlM (addAttribute canOverride) r resprms
    void $ getOver >>= mapM keepforlater
    let expandableDefine r = do
            n <- isNativeType (r ^. rid . itype)
            -- if we have a native type, or a virtual/exported resource it
            -- should not be expanded !
            if n || r ^. rvirtuality /= Normal
                then return [r]
                else expandDefine r
    concat <$> mapM expandableDefine withDefaults
    where
        expandDefine :: Resource -> InterpreterMonad [Resource]
        expandDefine r = do
            let deftype = dropInitialColons (r ^. rid . itype)
                defname = r ^. rid . iname
                modulename = getModulename (r ^. rid)
                curContType = ContDefine deftype defname (r ^. rpos)
            p <- use curPos
            -- we add the relations of this define to the global list of relations
            -- before dropping it, so that they are stored for the final
            -- relationship resolving
            let extr = do
                    (dstid, linkset) <- itoList (r ^. rrelations)
                    link <- toList linkset
                    return (LinkInformation (r ^. rid) dstid link p)
            extraRelations <>= extr
            void $ enterScope SENormal curContType modulename p
            (spurious, stmt) <- interpretTopLevel TopDefine deftype
            DefineDecl _ defineParams stmts cp <- extractPrism "expandDefine" _DefineDecl stmt
            let isImported (ContImported _) = True<commit_msg>Comment on why expandDefine is at the end of finalize<commit_after>{-# LANGUAGE GADTs        #-}
{-# LANGUAGE LambdaCase   #-}
{-# LANGUAGE RankNTypes   #-}
module Puppet.Interpreter
       ( interpretCatalog
       , evaluateStatement
       , computeCatalog
       ) where

import           Control.Applicative
import           Control.Lens hiding (ignored)
import           Control.Monad.Except
import           Control.Monad.Operational        hiding (view)
import           Control.Monad.Trans.Except
import qualified Data.Either.Strict               as S
import           Data.Foldable                    (foldl', foldlM, toList)
import qualified Data.Graph                       as G
import qualified Data.HashMap.Strict              as HM
import qualified Data.HashSet                     as HS
import           Data.List                        (nubBy, sortBy)
import           Data.Maybe
import qualified Data.Maybe.Strict                as S
import           Data.Ord                         (comparing)
import           Data.Semigroup                   (Max(..))
import           Data.Text (Text)
import qualified Data.Text                        as T
import           Data.Traversable                 (for)
import qualified Data.Tree                        as T
import           Data.Tuple.Strict                (Pair (..))
import qualified Data.Vector                      as V
import           System.Log.Logger

import           Puppet.Interpreter.PrettyPrinter (containerComma)
import           Puppet.Interpreter.Resolve
import           Puppet.Interpreter.Types
import           Puppet.Interpreter.Utils
import           Puppet.Interpreter.IO
import           Puppet.Lens
import           Puppet.NativeTypes
import           Puppet.Parser.PrettyPrinter
import           Puppet.Parser.Types
import           Puppet.Parser.Utils
import           Puppet.PP
import           Puppet.Utils


{-| Call the operational 'interpretMonad' function to compute the catalog.
    Returns either an error, or a tuple containing all the resources,
    dependency map, exported resources, and defined resources alongside with
    all messages that have been generated by the compilation process.

    The later 'definedResources' (eg. all class declarations) are pulled out of the
    'InterpreterState' and might not be up to date.
    There are only useful for coverage testing (checking dependencies for instance).
-}
interpretCatalog :: (Functor m, Monad m)
           => InterpreterReader m -- ^ The whole environment required for computing catalog.
           -> NodeName
           -> Facts
           -> Container Text -- ^ Server settings
           -> m (Pair (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource]))  [Pair Priority Doc])
interpretCatalog interpretReader node facts settings = do
    (output, _, warnings) <- interpretMonad interpretReader (initialState facts settings) (computeCatalog node)
    return (strictifyEither output :!: warnings)

isParent :: Text -> CurContainerDesc -> InterpreterMonad Bool
isParent cur (ContClass possibleparent) = preuse (scopes . ix cur . scopeParent) >>= \case
        Nothing         -> throwPosError ("Internal error: could not find scope" <+> ttext cur <+> "possible parent" <+> ttext possibleparent)
        Just S.Nothing  -> return False
        Just (S.Just p) -> if p == possibleparent
                               then return True
                               else isParent p (ContClass possibleparent)
isParent _ _ = return False

-- | Apply resource defaults, references overrides and expand defines
finalize :: [Resource] -> InterpreterMonad [Resource]
finalize rx = do
    scp  <- getScopeName
    resdefaults <- use (scopes . ix scp . scopeResDefaults)
    let getOver = use (scopes . ix scp . scopeOverrides) -- retrieves current overrides
        addResDefaults r = ifoldlM (addAttribute CantReplace) r resdefval
            where resdefval = resdefaults ^. ix (r ^. rid . itype) . resDefValues
        addOverrides r = getOver >>= foldlM addOverrides' r . view (at (r ^. rid))
        addOverrides' r (ResRefOverride _ prms p) = do
            -- we used this override, so we discard it
            scopes . ix scp . scopeOverrides . at (r ^. rid) .= Nothing
            let forb msg  = throwPosError ("Override of parameters ("
                                          <> list (map (ttext . fst) $ itoList prms)
                                          <> ") of the following resource is forbidden in the current context:"
                                          </> pretty r
                                          <+>  showPPos p
                                          </> ":"
                                          <+> msg)
            s <- getScope
            overrideType <- case r ^. rscope of
                                [] -> forb "Could not find the current resource context" -- we could not get the current resource context
                                (x:_) -> if x == s
                                             then return CantOverride -- we are in the same context : can't replace, but add stuff
                                             else isParent (scopeName s) x >>= \i ->
                                                if i || (r ^. rid . itype == "class")
                                                    then return Replace -- we can override what's defined in a parent
                                                    else forb "Can't override something that was not defined in the parent."
            ifoldlM (addAttribute overrideType) r prms
    -- step 1, apply resDefaults and resRefOverride
    withDefaults <- mapM (addOverrides >=> addResDefaults) rx
    -- There might be some overrides that could not be applied. The only
    -- valid reason is that they override something in exported resources.
    --
    -- it probably do something unexpected on defines, but let's keep it that way for now.
    let keepforlater (ResRefOverride resid resprms ropos) = resMod %= (appended : )
            where
               appended = ResourceModifier (resid ^. itype) ModifierMustMatch DontRealize (REqualitySearch "title" (PString (resid ^. iname))) overrider ropos
               overrider r = do
                   -- we must define if we can override the value
                   let canOverride = CantOverride -- TODO check inheritance
                   ifoldlM (addAttribute canOverride) r resprms
    void $ getOver >>= mapM keepforlater
    let expandableDefine r = do
            n <- isNativeType (r ^. rid . itype)
            -- if we have a native type, or a virtual/exported resource it
            -- should not be expanded !
            if n || r ^. rvirtuality /= Normal
                then return [r]
                else expandDefine r
    -- Now that all defaults / override have been applied, the defines can
    -- finally be expanded.
    -- The reason it has to be there is that parameters of the define could
    -- be affected.
    concat <$> mapM expandableDefine withDefaults
    where
        expandDefine :: Resource -> InterpreterMonad [Resource]
        expandDefine r = do
            let deftype = dropInitialColons (r ^. rid . itype)
                defname = r ^. rid . iname
                modulename = getModulename (r ^. rid)
                curContType = ContDefine deftype defname (r ^. rpos)
            p <- use curPos
            -- we add the relations of this define to the global list of relations
            -- before dropping it, so that they are stored for the final
            -- relationship resolving
            let extr = do
                    (dstid, linkset) <- itoList (r ^. rrelations)
                    link <- toList linkset
                    return (LinkInformation (r ^. rid) dstid link p)
            extraRelations <>= extr
            void $ enterScope SENormal curContType modulename p
            (spurious, stmt) <- interpretTopLevel TopDefine deftype
            DefineDecl _ defineParams stmts cp <- extractPrism "expandDefine" _DefineDecl stmt
            let isImported (ContImported _) = True
{'fraction_non_alphanumeric': 0.06865131373650378, 'fraction_numerical': 0.00012482057043000687, 'mean_word_length': 1.6547382372432073, 'pattern_counts': {'":': 2, '<': 49, '<?xml version=': 0, '>': 75, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 46, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '2090757', 'n_tokens_mistral': 3931, 'n_tokens_neox': 3777, 'n_words': 1468}