{-# LANGUAGE LambdaCase #-}
module Puppet.Interpreter where

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

import Prelude hiding (mapM)
import Puppet.Utils
import System.Log.Logger
import Data.Maybe
import Data.List (nubBy)
import qualified Data.Text as T
import Data.Tuple.Strict (Pair(..))
import qualified Data.Tuple.Strict as S
import qualified Data.Either.Strict as S
import qualified Data.HashSet as HS
import qualified Data.HashMap.Strict as HM
import Control.Monad.Error hiding (mapM,forM)
import Control.Lens
import qualified Data.Maybe.Strict as S
import qualified Data.Graph as G
import qualified Data.Tree as T
import Data.Foldable (toList,foldl',Foldable,foldlM)
import Data.Traversable (mapM,forM)
import Control.Monad.Operational

-- helpers
vmapM :: (Monad m, Foldable t) => (a -> m b) -> t a -> m [b]
vmapM f = mapM f . toList

-- | This is the main function for computing catalogs. It returns the
-- result of the compulation (either an error, or a tuple containing all
-- the resources, dependency map, exported resources, and defined resources
-- (this last one might not be up to date and is only useful for code
-- coverage tests)) along with all messages that have been generated by the
-- compilation process.
getCatalog :: Monad m
           => (InterpreterReader m -> InterpreterState -> InterpreterMonad (FinalCatalog, EdgeMap, FinalCatalog, [Resource]) -> m (Either Doc (FinalCatalog, EdgeMap, FinalCatalog, [Resource]), InterpreterState, InterpreterWriter)) -- ^ A function that will interpret the InterpreterMonad and will convert it to something else (for example, 'interpretIO')
           -> ( TopLevelType -> T.Text -> m (S.Either Doc Statement) ) -- ^ get statements function
           -> (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> m (S.Either Doc T.Text)) -- ^ compute template function
           -> PuppetDBAPI m
           -> T.Text -- ^ Node name
           -> Facts -- ^ Facts ...
           -> Container PuppetTypeMethods -- ^ List of native types
           -> Container ( [PValue] -> InterpreterMonad PValue )
           -> HieraQueryFunc m -- ^ Hiera query function
           -> ImpureMethods m
           -> m (Pair (S.Either Doc (FinalCatalog, EdgeMap, FinalCatalog, [Resource]))  [Pair Priority Doc])
getCatalog convertMonad gtStatement gtTemplate pdbQuery ndename facts nTypes extfuncs hquery im = do
    -- nameThread ("Catalog " <> T.unpack ndename)
    let rdr = InterpreterReader nTypes gtStatement gtTemplate pdbQuery extfuncs ndename hquery im
        dummypos = initialPPos "dummy"
        initialclass = mempty & at "::" ?~ (IncludeStandard :!: dummypos)
        stt  = InterpreterState baseVars initialclass mempty [ContRoot] dummypos mempty [] []
        factvars = facts & each %~ (\x -> PString x :!: initialPPos "facts" :!: ContRoot)
        callervars = ifromList [("caller_module_name", PString "::" :!: dummypos :!: ContRoot), ("module_name", PString "::" :!: dummypos :!: ContRoot)]
        baseVars = isingleton "::" (ScopeInformation (factvars <> callervars) mempty mempty (CurContainer ContRoot mempty) mempty S.Nothing)
    (output, _, warnings) <- convertMonad rdr stt (computeCatalog ndename)
    return (strictifyEither output :!: warnings)

isParent :: T.Text -> CurContainerDesc -> InterpreterMonad Bool
isParent _ (ContImport _ _) = return False -- no relationship through import
isParent _ ContRoot         = return False
isParent _ (ContImported _) = return False
isParent _ (ContDefine _ _ _) = return False
isParent cur (ContClass possibleparent) = do
    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)

finalize :: [Resource] -> InterpreterMonad [Resource]
finalize rlist = do
    -- step 1, apply defaults
    scp  <- getScopeName
    defs <- use (scopes . ix scp . scopeDefaults)
    let getOver = use (scopes . ix scp . scopeOverrides) -- retrieves current overrides
        addDefaults r = do
            let thisresdefaults = defs ^. ix (r ^. rid . itype) . defValues
            foldM (addAttribute CantReplace) r (itoList thisresdefaults)
        addOverrides r = do
            overs <- getOver
            case overs ^. at (r ^. rid) of
                Just x -> do
                    scopes . ix scp . scopeOverrides . at (r ^. rid) .= Nothing
                    addOverrides' r x
                Nothing -> return r
        addOverrides' r (ResRefOverride _ prms p) = do
            let forb = throwPosError ("Override of parameters of the following resource is forbidden in the current context:" </> pretty r <+>  showPPos p)
            s <- getScope
            overrideType <- case r ^. rscope of
                                [] -> forb -- 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
                                                    then return Replace -- we can override what's defined in a parent
                                                    else forb
            foldM (\cr a -> addAttribute overrideType cr a) r (HM.toList prms)
    withDefaults <- mapM (addOverrides >=> addDefaults) rlist
    -- There might be some overrides that could not be applied. The only
    -- valid reason is that they override something in exported resources.
    --
    -- This will probably do something unexpected on defines, but let's do
    -- 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
                   foldM (addAttribute canOverride) r (itoList resprms)
    fmap toList getOver >>= mapM_ keepforlater
    let expandableDefine (curstd, curdef) r = do
            n <- isNativeType (r ^. rid . itype)
            return $! if n || (r ^. rvirtuality /= Normal)
                          then (r : curstd, curdef)
                          else (curstd, r : curdef)
    (standard, defines) <- foldM expandableDefine ([], []) withDefaults
    expanded <- mapM expandDefine defines
    return $! standard ++ concat expanded

popScope :: InterpreterMonad ()
popScope = curScope %= tail

pushScope :: CurContainerDesc -> InterpreterMonad ()
pushScope s = curScope %= (s :)

evalTopLevel :: Statement -> InterpreterMonad ([Resource], Statement)
evalTopLevel (TopContainer tops s) = do
    pushScope ContRoot
    r <- vmapM evaluateStatement tops >>= finalize . concat
    -- popScope
    (nr, ns) <- evalTopLevel s
    popScope
    return (r <> nr, ns)
evalTopLevel x = return ([], x)

getstt :: TopLevelType -> T.Text -> InterpreterMonad ([Resource], Statement)
getstt topleveltype toplevelname = do
    -- check if this is a known class (spurious or inner class)
    use (nestedDeclarations . at (topleveltype, toplevelname)) >>= \case
        Just x -> return ([], x) -- it is known !
        Nothing -> singleton (GetStatement topleveltype toplevelname) >>= evalTopLevel

computeCatalog :: T.Text -> InterpreterMonad (FinalCatalog, EdgeMap, FinalCatalog, [Resource])
computeCatalog ndename = do
    (restop, node) <- getstt TopNode ndename
    let finalStep [] = return []
        finalStep allres = do
            -- collect stuff and apply thingies
            (realized :!: modified) <- realize allres
            -- we need to run it again against collected stuff, especially
            -- for defines that have been realized
            refinalized <- finalize (toList modified) >>= finalStep
            -- replace the modified stuff
            let res = foldl' (\curm e -> curm & at (e ^. rid) ?~ e) realized refinalized
            return (toList res)
        mainstage = Resource (RIdentifier "stage" "main") mempty mempty mempty [ContRoot] Normal mempty (initialPPos "dummy") ndename
    resnode <- evaluateNode node >>= finalStep . (++ (mainstage : restop))
    let (real :!: exported) = foldl' classify (mempty :!: mempty) resnode
        classify :: Pair (HM.HashMap RIdentifier Resource) (HM.HashMap RIdentifier Resource)
                 -> Resource
                 -> Pair (HM.HashMap RIdentifier Resource) (HM.HashMap RIdentifier Resource)
        classify (curr :!: cure) r =
            let i curm = curm & at (r ^. rid) ?~ r
            in  case r ^. rvirtuality of
                    Normal   -> i curr :!: cure
                    Exported -> curr :!: i cure
                    ExportedRealized -> i curr :!: i cure
                    _ -> curr :!: cure
    verified <- fmap (ifromList . map (\r -> (r ^. rid, r))) $ mapM validateNativeType (toList real)
    mp <- makeEdgeMap verified
    definedRes <- use definedResources
    return (verified, mp, exported, HM.elems definedRes)

dependencyErrors :: [T.Tree G.Vertex] -> (G.Vertex -> (RIdentifier, RIdentifier, [RIdentifier])) -> InterpreterMonad ()
dependencyErrors _ _ = throwPosError "Undefined dependency cycle"

makeEdgeMap :: FinalCatalog -> InterpreterMonad EdgeMap
makeEdgeMap ct = do
    -- merge the looaded classes and resources
    defs' <- HM.map _rpos `fmap` use definedResources
    clss' <- use loadedClasses
    let defs = defs' <> classes' <> aliases' <> names'
        names' = HM.map _rpos ct
        -- generate fake resources for all extra aliases
        aliases' = ifromList $ do
            r <- ct ^.. traversed :: [Resource]
            extraAliases <- r ^.. ralias . folded . filtered (/= r ^. rid . iname) :: [T.Text]
            return (r ^. rid & iname .~ extraAliases, r ^. rpos)
        classes' = ifromList $ do
            (cn, _ :!: cp) <- itoList clss'
            return (RIdentifier "class" cn, cp)
    -- Preparation step : all relations to a container become relations to
    -- the stuff that's contained. We build a map of resources, stored by
    -- container.
    let containerMap :: HM.HashMap RIdentifier [RIdentifier]
        !containerMap = ifromListWith (<>) $ do
            r <- toList ct
            let toResource ContRoot           = return $ RIdentifier "class" "::"
                toResource (ContClass cn)     = return $ RIdentifier "class" cn
                toResource (ContDefine t n _) = return $ RIdentifier t n
                toResource (ContImported _)   = mzero
                toResource (ContImport _ _)   = mzero
            o <- toResource (rcurcontainer r)
            return (o, [r ^. rid])
        -- This function uses the previous map in order to resolve to non
        -- container resources.
        resolveDestinations :: RIdentifier -> [RIdentifier]
        resolveDestinations r = case containerMap ^. at r of
                                    Just x -> concatMap resolveDestinations x
                                    Nothing -> [r]
    -- step 1 - add relations that are stored in resources
    let reorderlink :: (RIdentifier, RIdentifier, LinkType) -> (RIdentifier, RIdentifier, LinkType)
        reorderlink (s, d, RBefore) = (d, s, RRequire)
        reorderlink (s, d, RNotify) = (d, s, RSubscribe)
        reorderlink x = x
        addRR curmap r = iunionWith (<>) curmap newmap
            where
               newmap = ifromListWith (<>) $ do
                   (rawdst, lts) <- itoList (r ^. rrelations)
                   dst <- resolveDestinations rawdst
                   lt <- toList lts
                   let (nsrc, ndst, nlt) = reorderlink (r ^. rid, dst, lt)
                   return (r ^. rid, [LinkInformation nsrc ndst nlt (r ^. rpos)])
        step1 = foldl' addRR mempty ct
    -- step 2 - add other relations (mainly stuff made from the "->"
    -- operator)
    let realign (LinkInformation s d t p) = do
            let (ns, nd, nt) = reorderlink (s, d, t)
            rs <- resolveDestinations ns
            rd <- resolveDestinations nd
            return (rs, [LinkInformation rs rd nt p])
    rels <- fmap (concatMap realign) (use extraRelations)
    let step2 = iunionWith (<>) step1 (ifromList rels)
    -- check that all resources are defined, and build graph
    let checkResDef :: (RIdentifier, [LinkInformation]) -> InterpreterMonad (RIdentifier, RIdentifier, [RIdentifier])
        checkResDef (ri, lifs) = do
            let checkExists r msg = unless (defs & has (ix r)) (throwPosError msg)
                errmsg = "Unknown resource" <+> pretty ri <+> "used in the following relationships:" <+> vcat prels
                prels = [ pretty (li ^. linksrc) <+> "->" <+> pretty (li ^. linkdst) <+> showPPos (li ^. linkPos) | li <- lifs ]
            checkExists ri errmsg
            let genlnk :: LinkInformation -> InterpreterMonad RIdentifier
                genlnk lif = do
                    let d = lif ^. linkdst
                    checkExists d ("Unknown resource" <+> pretty d <+> "used in a relation at" <+> showPPos (lif ^. linkPos))
                    return d
            ds <- mapM genlnk lifs
            return (ri, ri, ds)
    (graph, gresolver) <- fmap G.graphFromEdges' $ mapM checkResDef (itoList step2)
    -- now check for scc
    let sccs = filter ((>1) . length . T.flatten) (G.scc graph)
    unless (null sccs) (dependencyErrors sccs gresolver)
    return step2

realize :: [Resource] -> InterpreterMonad (Pair FinalCatalog FinalCatalog)
realize rs = do
    let rma = ifromList (map (\r -> (r ^. rid, r)) rs)
        mutate :: Pair FinalCatalog FinalCatalog -> ResourceModifier -> InterpreterMonad (Pair FinalCatalog FinalCatalog)
        mutate (curmap :!: modified) rmod = do
            let filtrd = curmap ^.. folded . filtered fmod
                vcheck f r = f (r ^. rvirtuality)
                (isGoodvirtuality, alterVirtuality) = case rmod ^. rmType of
                                                          RealizeVirtual   -> (vcheck (/= Exported), \r -> return (r & rvirtuality .~ Normal))
                                                          RealizeCollected -> (vcheck (`elem` [Exported, ExportedRealized]), \r -> return (r & rvirtuality .~ ExportedRealized))
                                                          DontRealize      -> (vcheck (`elem` [Normal, ExportedRealized]), return)
                fmod r = (r ^. rid . itype == rmod ^. rmResType) && checkSearchExpression (rmod ^. rmSearch) r && isGoodvirtuality r
                mutation = alterVirtuality >=> rmod ^. rmMutation
                applyModification :: Pair (Pair FinalCatalog FinalCatalog) Bool -> Resource -> InterpreterMonad (Pair (Pair FinalCatalog FinalCatalog) Bool)
                applyModification (cma :!: cmo :!: matched) r = do
                    nr <- mutation r
                    let i m = m & at (nr ^. rid) ?~ nr
                    return $ if nr /= r
                                 then i cma :!: i cmo :!: True
                                 else cma :!: cmo :!: matched
            (result :!: mtch) <- foldM applyModification (curmap :!: modified :!: False) filtrd
            when (rmod ^. rmModifierType == ModifierMustMatch && not mtch) (throwError ("Could not apply this resource override :" <+> pretty rmod))
            return result
        equalModifier (ResourceModifier a1 b1 c1 d1 _ e1) (ResourceModifier a2 b2 c2 d2 _ e2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2
    result <- use resMod >>= foldM mutate (rma :!: mempty) . nubBy equalModifier
    resMod .= []
    return result

evaluateNode :: Statement -> InterpreterMonad [Resource]
evaluateNode (Node _ stmts inheritance p) = do
    curPos .= p
    pushScope ContRoot
    unless (S.isNothing inheritance) $ throwPosError "Node inheritance is not handled yet, and will probably never be"
    vmapM evaluateStatement stmts >>= finalize . concat
evaluateNode x = throwPosError ("Asked for a node evaluation, but got this instead:" <$> pretty x)

evaluateStatementsVector :: Foldable f => f Statement -> InterpreterMonad [Resource]
evaluateStatementsVector = fmap concat . vmapM evaluateStatement

-- | Converts a list of pairs into a container, checking there is no
-- duplicate
fromArgumentList :: [Pair T.Text a] -> InterpreterMonad (Container a)
fromArgumentList = foldM insertArgument mempty
    where
        insertArgument curmap (k :!: v) =
            case curmap ^. at k of
                Just _ -> throwPosError ("Parameter" <+> dullyellow (ttext k) <+> "already defined!")
                Nothing -> return (curmap & at k ?~ v)

evaluateStatement :: Statement -> InterpreterMonad [Resource]
evaluateStatement r@(ClassDeclaration cname _ _ _ _) =
    if "::" `T.isInfixOf` cname
       then nestedDeclarations . at (TopClass, cname) ?= r >> return []
       else do
           scp <- getScopeName
           if scp == "::"
               then nestedDeclarations . at (TopClass, cname) ?= r >> return []
               else nestedDeclarations . at (TopClass, scp <> "::" <> cname) ?= r >> return []
evaluateStatement r@(DefineDeclaration dname _ _ _) =
    if "::" `T.isInfixOf` dname
       then nestedDeclarations . at (TopDefine, dname) ?= r >> return []
       else do
           scp <- getScopeName
           if scp == "::"
               then nestedDeclarations . at (TopDefine, dname) ?= r >> return []
               else nestedDeclarations . at (TopDefine, scp <> "::" <> dname) ?= r >> return []
evaluateStatement r@(ResourceCollection e resType searchExp mods p) = do
    curPos .= p
    unless (fnull mods || e == Collector) (throwPosError ("It doesnt seem possible to amend attributes with an exported resource collector:" <$> pretty r))
    rsearch <- resolveSearchExpression searchExp
    let et = case e of
                 Collector -> RealizeVirtual
                 ExportedCollector -> RealizeCollected
    resMod %= (ResourceModifier resType ModifierCollector et rsearch return p : )
    -- Now collectd from the PuppetDB !
    if et == RealizeCollected
        then do
            let q = searchExpressionToPuppetDB resType rsearch
            fqdn <- singleton GetNodeName
            -- we must filter the resources that originated from this host
            -- here ! They are also turned into "normal" resources
            res <- ( map (rvirtuality .~ Normal)
                   . filter ((/= fqdn) . _rnode)
                   ) `fmap` singleton (PDBGetResources q)
            scpdesc <- ContImported `fmap` getScope
            void $ enterScope SENormal scpdesc "importing" p
            pushScope scpdesc
            o <- finalize res
            popScope
            return o

        else return []
evaluateStatement (Dependency (t1 :!: n1) (t2 :!: n2) p) = do
    curPos .= p
    rn1 <- resolveExpressionStrings n1
    rn2 <- resolveExpressionStrings n2
    forM_ rn1 $ \an1 -> forM_ rn2 $ \an2 ->
        extraRelations %= (LinkInformation (RIdentifier t1 an1) (RIdentifier t2 an2) RBefore p :)
    return []
evaluateStatement (ResourceDeclaration rt ern eargs virt p) = do
    curPos .= p
    resnames <- resolveExpressionStrings ern
    args <- vmapM resolveArgument eargs >>= fromArgumentList
    fmap concat (mapM (\n -> registerResource rt n args virt p) resnames)
evaluateStatement (MainFunctionCall funcname funcargs p) = do
    curPos .= p
    vmapM resolveExpression funcargs >>= mainFunctionCall funcname
evaluateStatement (VariableAssignment varname varexpr p) = do
    curPos .= p
    varval <- resolveExpression varexpr
    loadVariable varname varval
    return []
evaluateStatement (ConditionalStatement conds p) = do
    curPos .= p
    let checkCond [] = return []
        checkCond ((e :!: stmts) : xs) = do
            result <- fmap pValue2Bool (resolveExpression e)
            if result
                then evaluateStatementsVector stmts
                else checkCond xs
    checkCond (toList conds)
evaluateStatement (DefaultDeclaration resType decls p) = do
    curPos .= p
    let resolveDefaultValue (prm :!: v) = fmap (prm :!:) (resolveExpression v)
    rdecls <- vmapM resolveDefaultValue decls >>= fromArgumentList
    scp <- getScopeName
    -- invariant that must be respected : the current scope must me create
    -- in "scopes", or nothing gets saved
    let newDefaults = ResDefaults resType scp rdecls p
        addDefaults x = scopes . ix scp . scopeDefaults . at resType ?= x
        -- default merging with parent
        mergedDefaults curdef = newDefaults & defValues .~ (rdecls <> (curdef ^. defValues))
    preuse (scopes . ix scp . scopeDefaults . ix resType) >>= \case
        Nothing -> addDefaults newDefaults
        Just de -> if de ^. defSrcScope == scp
                       then throwPosError ("Defaults for resource" <+> ttext resType <+> "already declared at" <+> showPPos (de ^. defPos))
                       else addDefaults (mergedDefaults de)
    return []
evaluateStatement (ResourceOverride rt urn eargs p) = do
    curPos .= p
    raassignements <- vmapM resolveArgument eargs >>= fromArgumentList
    rn <- resolveExpressionString urn
    scp <- getScopeName
    curoverrides <- use (scopes . ix scp . scopeOverrides)
    let rident = RIdentifier rt rn
    -- check that we didn't already override those values
    withAssignements <- case curoverrides ^. at rident of
                            Just (ResRefOverride _ prevass prevpos) -> do
                                let cm = prevass `HM.intersection` raassignements
                                unless (fnull cm) (throwPosError ("The following parameters were already overriden at" <+> showPPos prevpos <+> ":" <+> containerComma cm))
                                return (prevass <> raassignements)
                            Nothing -> return raassignements
    scopes . ix scp . scopeOverrides . at rident ?= ResRefOverride rident withAssignements p
    return []
evaluateStatement (SHFunctionCall c p) = curPos .= p >> evaluateHFC c
evaluateStatement r = throwError ("Do not know how to evaluate this statement:" <$> pretty r)

-----------------------------------------------------------
-- Class evaluation
-----------------------------------------------------------

loadVariable ::  T.Text -> PValue -> InterpreterMonad ()
loadVariable varname varval = do
    curcont <- getCurContainer
    scp <- getScopeName
    p <- use curPos
    scopeDefined <- has (ix scp) `fmap` use scopes
    variableDefined <- preuse (scopes . ix scp . scopeVariables . ix varname)
    case (scopeDefined, variableDefined) of
        (False, _) -> throwPosError ("Internal error: trying to save a variable in unknown scope" <+> ttext scp)
        (_, Just (_ :!: pp :!: ctx)) -> do
            isParent scp (curcont ^. cctype) >>= \case
                True -> do
                    debug ("The variable"
                          <+> pretty (UVariableReference varname)
                          <+> "had been overriden because of some arbitrary inheritance rule that was set up to emulate puppet behaviour. It was defined at"
                          <+> showPPos pp
                          )
                    scopes . ix scp . scopeVariables . at varname ?= (varval :!: p :!: curcont ^. cctype)
                False -> throwPosError ("Variable" <+> pretty (UVariableReference varname) <+> "already defined at" <+> showPPos pp
                                </> "Context:" <+> pretty ctx
                                </> "Value:" <+> pretty varval
                                </> "Current scope:" <+> ttext scp
                                )
        _ -> scopes . ix scp . scopeVariables . at varname ?= (varval :!: p :!: curcont ^. cctype)

-- | This function loads class and define parameters into scope. It checks
-- that all mandatory parameters are set, that no extra parameter is
-- declared.
--
-- It is able to fill unset parameters with values from Hiera (for classes
-- only) or default values.
loadParameters :: Foldable f => Container PValue -> f (Pair T.Text (S.Maybe Expression)) -> PPosition -> S.Maybe T.Text -> InterpreterMonad ()
loadParameters params classParams defaultPos wHiera = do
    params' <- case wHiera of
        S.Just classname -> do
            -- pass 1 : with classes, we retrieve the parameters that have no default values and
            -- that are not set, to try to get them with Hiera
            let !classParamSet   = HS.fromList (fmap S.fst (classParams ^.. folded))
                !definedParamSet = ikeys params
                !unsetParams     = classParamSet `HS.difference` definedParamSet
                loadHieraParam curprms paramname = do
                    v <- runHiera (classname <> "::" <> paramname) Priority
                    case v of
                        S.Nothing -> return curprms
                        S.Just vl -> return (curprms & at paramname ?~ vl)
            foldM loadHieraParam params (toList unsetParams)
        S.Nothing -> return params
    -- pass 2 : we check that everything is right
    let !classParamSet     = HS.fromList (map S.fst (toList classParams))
        !mandatoryParamSet = HS.fromList (map S.fst (classParams ^.. folded . filtered (S.isNothing . S.snd)))
        !definedParamSet   = ikeys params'
        !unsetParams       = mandatoryParamSet `HS.difference` definedParamSet
        !spuriousParams    = definedParamSet `HS.difference` classParamSet
        mclassdesc = S.maybe mempty ((\x -> mempty <+> "when including class" <+> x) . ttext) wHiera
    unless (fnull unsetParams) $ throwPosError ("The following mandatory parameters where not set:" <+> tupled (map ttext $ toList unsetParams) <> mclassdesc)
    unless (fnull spuriousParams) $ throwPosError ("The following parameters are unknown:" <+> tupled (map (dullyellow . ttext) $ toList spuriousParams) <> mclassdesc)
    let isDefault = not . flip HS.member definedParamSet . S.fst
    mapM_ (uncurry loadVariable) (itoList params')
    curPos .= defaultPos
    forM_ (filter isDefault (toList classParams)) $ \(k :!: v) -> do
        rv <- case v of
                  S.Nothing -> throwPosError "Internal error: invalid invariant at loadParameters"
                  S.Just e  -> resolveExpression e
        loadVariable k rv

data ScopeEnteringContext = SENormal
                          | SEChild  !T.Text -- ^ We enter the scope as the child of another class
                          | SEParent !T.Text -- ^ We enter the scope as the parent of another class

-- | Enters a new scope, checks it is not already defined, and inherits the
-- defaults from the current scope
--
-- Inheriting the defaults is necessary for non native types, because they
-- will be expanded in "finalize", so if this was not done, we would be
-- expanding the defines without the defaults applied
enterScope :: ScopeEnteringContext
           -> CurContainerDesc
           -> T.Text
           -> PPosition
           -> InterpreterMonad T.Text
enterScope secontext cont modulename p = do
    let scopename = scopeName cont
    -- This is a special hack for inheritance, because at this time we
    -- have not properly stacked the scopes.
    curcaller <- case secontext of
                     SEParent l -> return (PString $ T.takeWhile (/=':') l)
                     _ -> resolveVariable "module_name"
    scopeAlreadyDefined <- has (ix scopename) `fmap` use scopes
    let isImported = case cont of
                         ContImported _ -> True
                         _ -> False
    -- it is OK to reuse a scope related to imported stuff
    unless (scopeAlreadyDefined && isImported) $ do
        when scopeAlreadyDefined (throwPosError ("Internal error: scope" <+> brackets (ttext scopename) <+> "already defined when loading scope for" <+> pretty cont))
        scp <- getScopeName
        -- TODO fill tags
        basescope <- case secontext of
            SEChild prt -> do
                parentscope <- use (scopes . at prt)
                when (isNothing parentscope) (throwPosError ("Internal error: could not find parent scope" <+> ttext prt))
                let Just psc = parentscope
                return (psc & scopeParent .~ S.Just prt)
            _ -> do
                curdefs <- use (scopes . ix scp . scopeDefaults)
                return $ ScopeInformation mempty curdefs mempty (CurContainer cont mempty) mempty S.Nothing
        scopes . at scopename ?= basescope
    scopes . ix scopename . scopeVariables . at "caller_module_name" ?= (curcaller          :!: p :!: cont)
    scopes . ix "::"      . scopeVariables . at "calling_module"     ?= (curcaller          :!: p :!: cont)
    scopes . ix scopename . scopeVariables . at "module_name"        ?= (PString modulename :!: p :!: cont)
    debug ("enterScope, scopename=" <> ttext scopename <+> "caller_module_name=" <> pretty curcaller <+> "module_name=" <> ttext modulename)
    return scopename

dropInitialColons :: T.Text -> T.Text
dropInitialColons t = fromMaybe t (T.stripPrefix "::" t)

expandDefine :: Resource -> InterpreterMonad [Resource]
expandDefine r = do
    let deftype = dropInitialColons (r ^. rid . itype)
        defname = r ^. rid . iname
        modulename = case T.splitOn "::" deftype of
                         [] -> deftype
                         (x:_) -> x
    let curContType = ContDefine deftype defname (r ^. rpos)
    p <- use curPos
    void $ enterScope SENormal curContType modulename p
    (spurious, dls) <- getstt TopDefine deftype
    let isImported (ContImported _) = True
        isImported _ = False
    isImportedDefine <- isImported `fmap` getScope
    case dls of
        (DefineDeclaration _ defineParams stmts cp) -> do
            curPos .= r ^. rpos
            curscp <- getScope
            when isImportedDefine (pushScope (ContImport (r ^. rnode) curscp ))
            pushScope curContType
            loadVariable "title" (PString defname)
            loadVariable "name" (PString defname)
            -- not done through loadvariable because of override
            -- errors
            loadParameters (r ^. rattributes) defineParams cp S.Nothing
            curPos .= cp
            res <- evaluateStatementsVector stmts
            out <- finalize (spurious ++ res)
            when isImportedDefine popScope
            popScope
            return out
        _ -> throwPosError ("Internal error: we did not retrieve a DefineDeclaration, but had" <+> pretty dls)


loadClass :: T.Text
          -> S.Maybe T.Text -- ^ Set if this is an inheritance load, so that we can set calling module properly
          -> Container PValue
          -> ClassIncludeType
          -> InterpreterMonad [Resource]
loadClass rclassname loadedfrom params cincludetype = do
    let classname = dropInitialColons rclassname
    ndn <- singleton GetNodeName
    singleton (TraceEvent ('[' : T.unpack ndn ++ "] loadClass " ++ T.unpack classname))
    p <- use curPos
    -- check if the class has already been loaded
    -- http://docs.puppetlabs.com/puppet/3/reference/lang_classes.html#using-resource-like-declarations
    use (loadedClasses . at classname) >>= \case
        Just (prv :!: pp) -> do
            when (  (cincludetype == IncludeResource)
                 || (prv          == IncludeResource)
                 )
                (throwPosError ("Can't include class" <+> ttext classname <+> "twice when using the resource-like syntax (first occurence at" <+> showPPos pp <> ")"))
            return []
        -- already loaded, go on
        Nothing -> do
            loadedClasses . at classname ?= (cincludetype :!: p)
            -- load the actual class, note we are not changing the current position
            -- right now
            (spurious, cls) <- getstt TopClass classname
            case cls of
                (ClassDeclaration _ classParams inh stmts cp) -> do
                    -- check if we need to define a resource representing the class
                    -- This will be the case for the first standard include
                    inhstmts <- case inh of
                                    S.Nothing     -> return []
                                    S.Just ihname -> loadClass ihname (S.Just classname) mempty IncludeStandard
                    let !scopedesc = ContClass classname
                        modulename = case T.splitOn "::" classname of
                                         []    -> classname
                                         (x:_) -> x
                        secontext = case (inh, loadedfrom) of
                                        (S.Just x,_) -> SEChild x
                                        (_,S.Just x) -> SEParent x
                                        _ -> SENormal
                    void $ enterScope secontext scopedesc modulename p
                    classresource <- if cincludetype == IncludeStandard
                                         then do
                                             scp <- use curScope
                                             fqdn <- singleton GetNodeName
                                             return [Resource (RIdentifier "class" classname) (HS.singleton classname) mempty mempty scp Normal mempty p fqdn]
                                         else return []
                    pushScope scopedesc
                    -- not done through loadvariable because of override
                    -- errors
                    loadParameters params classParams cp (S.Just classname)
                    curPos .= cp
                    res <- evaluateStatementsVector stmts
                    out <- finalize (classresource ++ spurious ++ inhstmts ++ res)
                    popScope
                    return out
                _ -> throwPosError ("Internal error: we did not retrieve a ClassDeclaration, but had" <+> pretty cls)
-----------------------------------------------------------
-- Resource stuff
-----------------------------------------------------------

addRelationship :: LinkType -> PValue -> Resource -> InterpreterMonad Resource
addRelationship lt (PResourceReference dt dn) r = return (r & rrelations %~ insertLt)
    where
        insertLt = iinsertWith (<>) (RIdentifier dt dn) (mempty & contains lt .~ True)
addRelationship lt (PArray vals) r = foldlM (flip (addRelationship lt)) r vals
addRelationship _ PUndef r = return r
addRelationship _ notrr _ = throwPosError ("Expected a resource reference, not:" <+> pretty notrr)

addTagResource :: Resource -> T.Text -> Resource
addTagResource r rv = r & rtags . contains rv .~ True

addAttribute :: OverrideType -> Resource -> (T.Text, PValue) -> InterpreterMonad Resource
addAttribute _ r ("alias", v) = fmap (\rv -> r & ralias . contains rv .~ True) (resolvePValueString v)
addAttribute _ r ("audit", _) = use curPos >>= \p -> warn ("Metaparameter audit ignored at" <+> showPPos p) >> return r
addAttribute _ r ("noop", _) = use curPos >>= \p -> warn ("Metaparameter noop ignored at" <+> showPPos p) >> return r
addAttribute _ r ("loglevel", _) = use curPos >>= \p -> warn ("Metaparameter loglevel ignored at" <+> showPPos p) >> return r
addAttribute _ r ("schedule", _) = use curPos >>= \p -> warn ("Metaparameter schedule ignored at" <+> showPPos p) >> return r
addAttribute _ r ("stage", _) = use curPos >>= \p -> warn ("Metaparameter stage ignored at" <+> showPPos p) >> return r
addAttribute _ r ("tag", PArray v) = foldM (\cr cv -> fmap (addTagResource cr) (resolvePValueString cv)) r (toList v)
addAttribute _ r ("tag", v) = fmap (addTagResource r) (resolvePValueString v)
addAttribute _ r ("before", d) = addRelationship RBefore d r
addAttribute _ r ("notify", d) = addRelationship RNotify d r
addAttribute _ r ("require", d) = addRelationship RRequire d r
addAttribute _ r ("subscribe", d) = addRelationship RSubscribe d r
addAttribute b r (t,v) = case (r ^. rattributes . at t, b) of
                             (_, Replace)     -> return (r & rattributes . at t ?~ v)
                             (Nothing, _)     -> return (r & rattributes . at t ?~ v)
                             (_, CantReplace) -> return r
                             _                -> do
                                 -- we must check if the resource scope is
                                 -- a parent of the current scope
                                 curscope <- getScopeName
                                 i <- isParent curscope (rcurcontainer r)
                                 if i
                                     then return (r & rattributes . at t ?~ v)
                                     else throwPosError ("Attribute" <+> dullmagenta (ttext t) <+> "defined multiple times for" <+> pretty (r ^. rid) <+> showPPos (r ^. rpos))

registerResource :: T.Text -> T.Text -> Container PValue -> Virtuality -> PPosition -> InterpreterMonad [Resource]
registerResource "class" _ _ Virtual p  = curPos .= p >> throwPosError "Cannot declare a virtual class (or perhaps you can, but I do not know what this means)"
registerResource "class" _ _ Exported p = curPos .= p >> throwPosError "Cannot declare an exported class (or perhaps you can, but I do not know what this means)"
registerResource rt rn arg vrt p = do
    curPos .= p
    CurContainer cnt tgs <- getCurContainer
    -- default tags
    -- http://docs.puppetlabs.com/puppet/3/reference/lang_tags.html#automatic-tagging
    -- http://docs.puppetlabs.com/puppet/3/reference/lang_tags.html#containment
    let !defaulttags = {-# SCC "rrGetTags" #-} HS.fromList (rt : classtags) <> tgs
        allsegs x = x : T.splitOn "::" x
        !classtags = getClassTags cnt
        getClassTags (ContClass cn     ) = allsegs cn
        getClassTags (ContDefine dt _ _) = allsegs dt
        getClassTags (ContRoot         ) = []
        getClassTags (ContImported _   ) = []
        getClassTags (ContImport _ _   ) = []
    allScope <- use curScope
    fqdn <- singleton GetNodeName
    let baseresource = Resource (RIdentifier rt rn) (HS.singleton rn) mempty mempty allScope vrt defaulttags p fqdn
    r <- foldM (addAttribute CantOverride) baseresource (itoList arg)
    let resid = RIdentifier rt rn
    case rt of
        "class" -> {-# SCC "rrClass" #-} do
            definedResources . at resid ?= r
            let attrs = r ^. rattributes
            fmap (r:) $ loadClass rn S.Nothing attrs $ if HM.null attrs
                                                           then IncludeStandard
                                                           else IncludeResource
        _ -> {-# SCC "rrGeneralCase" #-}
            use (definedResources . at resid) >>= \case
                Just otheres -> throwPosError ("Resource" <+> pretty resid <+> "already defined:" <$>
                                               pretty r <$>
                                               pretty otheres
                                              )
                Nothing -> do
                    definedResources . at resid ?= r
                    return [r]

-- A helper function for the various loggers
logWithModifier :: Priority -> (Doc -> Doc) -> [PValue] -> InterpreterMonad [Resource]
logWithModifier prio m [t] = do
    p <- use curPos
    rt <- resolvePValueString t
    logWriter prio (m (ttext rt) <+> showPPos p)
    return []
logWithModifier _ _ _ = throwPosError "This function takes a single argument"

-- functions : this can't really be exported as it uses a lot of stuff from
-- this module ...
mainFunctionCall :: T.Text -> [PValue] -> InterpreterMonad [Resource]
mainFunctionCall "showscope" _ = use curScope >>= warn . pretty >> return []
-- The logging functions
mainFunctionCall "alert" a   = logWithModifier ALERT        red         a
mainFunctionCall "crit" a    = logWithModifier CRITICAL     red         a
mainFunctionCall "debug" a   = logWithModifier DEBUG        dullwhite   a
mainFunctionCall "emerg" a   = logWithModifier EMERGENCY    red         a
mainFunctionCall "err" a     = logWithModifier ERROR        dullred     a
mainFunctionCall "info" a    = logWithModifier INFO         green       a
mainFunctionCall "notice" a  = logWithModifier NOTICE       white       a
mainFunctionCall "warning" a = logWithModifier WARNING      dullyellow  a
mainFunctionCall "include" includes =
    fmap concat $ forM includes $ \e -> do
        classname <- resolvePValueString e
        loadClass classname S.Nothing mempty IncludeStandard
mainFunctionCall "create_resources" [rtype, hs] = mainFunctionCall "create_resources" [rtype, hs, PHash mempty]
mainFunctionCall "create_resources" [PString rtype, PHash hs, PHash defs] = do
    p <- use curPos
    let genRes (rname, PHash rargs) = registerResource rtype rname (rargs <> defs) Normal p
        genRes (rname, x) = throwPosError ("create_resource(): the value corresponding to key" <+> ttext rname <+> "should be a hash, not" <+> pretty x)
    fmap concat (mapM genRes (itoList hs))
mainFunctionCall "create_resources" args = throwPosError ("create_resource(): expects between two and three arguments, of type [string,hash,hash], and not:" <+> pretty args)
mainFunctionCall "realize" args = do
    p <- use curPos
    let realiz (PResourceReference rt rn) = resMod %= (ResourceModifier rt ModifierMustMatch RealizeVirtual (REqualitySearch "title" (PString rn)) return p : )
        realiz x = throwPosError ("realize(): all arguments must be resource references, not" <+> pretty x)
    mapM_ realiz args >> return []
mainFunctionCall "tag" args = do
    scp <- getScopeName
    let addTag x = scopes . ix scp . scopeExtraTags . contains x .= True
    mapM_ (resolvePValueString >=> addTag) args
    return []
mainFunctionCall "fail" [x] = fmap (("fail:" <+>) . dullred . ttext) (resolvePValueString x) >>= throwPosError
mainFunctionCall "fail" _ = throwPosError "fail(): This function takes a single argument"
mainFunctionCall "hiera_include" [x] = do
    ndname <- resolvePValueString x
    classes <- runHiera ndname ArrayMerge >>= \case
                    S.Just (PArray r) -> return (toList r)
                    _ -> return []
    p <- use curPos
    curPos %= (_1 . lSourceName %~ (<> " [hiera_include call]"))
    o <- mainFunctionCall "include" classes
    curPos .= p
    return o
mainFunctionCall "hiera_include" _ = throwPosError "hiera_include(): This function takes a single argument"
mainFunctionCall fname args = do
    p <- use curPos
    let representation = MainFunctionCall fname mempty p
    rs <- singleton (ExternalFunction fname args)
    unless (rs == PUndef) $ throwPosError ("This function call should return" <+> pretty PUndef <+> "and not" <+> pretty rs <$> pretty representation)
    return []
-- Method stuff

evaluateHFC :: HFunctionCall -> InterpreterMonad [Resource]
evaluateHFC hf = do
    varassocs <- hfGenerateAssociations hf
    let runblock :: [(T.Text, PValue)] -> InterpreterMonad [Resource]
        runblock assocs = do
            saved <- hfSetvars assocs
            res <- evaluateStatementsVector (hf ^. hfstatements)
            hfRestorevars  saved
            return res
    results <- mapM runblock varassocs
    return (concat results)