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

import Puppet.Interpreter.Types
import Puppet.Interpreter.PrettyPrinter(containerComma)
import Puppet.Interpreter.Resolve
import Puppet.Parser.Types
import Puppet.Lens
import Puppet.Parser.PrettyPrinter
import Puppet.PP hiding ((<$>))
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)
import Control.Monad.Operational hiding (view)
import Control.Applicative

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

getModulename :: RIdentifier -> T.Text
getModulename (RIdentifier t n) =
    let gm x = case T.splitOn "::" x of
                   [] -> x
                   (y:_) -> y
    in case t of
           "class" -> gm n
           _ -> gm t

-- | 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
           => (forall a. InterpreterReader m -> InterpreterState -> InterpreterMonad a -> m (Either PrettyError a, 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 PrettyError Statement) ) -- ^ get statements function
           -> (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> m (S.Either PrettyError T.Text)) -- ^ compute template function
           -> PuppetDBAPI m
           -> T.Text -- ^ Node name
           -> Facts -- ^ Facts ...
           -> Container NativeTypeMethods -- ^ List of native types
           -> Container ( [PValue] -> InterpreterMonad PValue )
           -> HieraQueryFunc m -- ^ Hiera query function
           -> ImpureMethods m
           -> HS.HashSet T.Text -- ^ The set of ignored modules
           -> m (Pair (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource]))  [Pair Priority Doc])
getCatalog convertMonad gtStatement gtTemplate pdbQuery ndename facts nTypes extfuncs hquery im ignord = do
    -- nameThread ("Catalog " <> T.unpack ndename)
    let rdr = InterpreterReader nTypes gtStatement gtTemplate pdbQuery extfuncs ndename hquery im ignord
        stt = initialState facts
    (output, _, warnings) <- convertMonad rdr stt (computeCatalog ndename)
    return (strictifyEither output :!: warnings)

isParent :: T.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

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 = ifoldlM (addAttribute CantReplace) r thisresdefaults
            where thisresdefaults = defs ^. ix (r ^. rid . itype) . defValues
        addOverrides r = getOver >>= foldlM addOverrides' r
        addOverrides' r (ResRefOverride _ prms p) = do
            -- we used this override, so we discard it
            scopes . ix scp . scopeOverrides . at (r ^. rid) .= Nothing
            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
            ifoldlM (addAttribute overrideType) r 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
                   ifoldlM (addAttribute canOverride) r resprms
    void $ getOver >>= mapM keepforlater
    let expandableDefine r = do
            n <- isNativeType (r ^. rid . itype)
            if n
                then return [r]
                else expandDefine r
    join <$> mapM expandableDefine withDefaults

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 =
    -- 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

extractPrism :: Prism' a b -> Doc -> a -> InterpreterMonad b
extractPrism p t a = case preview p a of
                         Just b -> return b
                         Nothing -> throwPosError ("Could not extract prism in " <> t)

computeCatalog :: T.Text -> InterpreterMonad (FinalCatalog, EdgeMap, FinalCatalog, [Resource])
computeCatalog ndename = do
    (restop, node') <- getstt TopNode ndename
    node <- extractPrism _Node' "computeCatalog" node'
    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 dummypos 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 <- ifromList . map (\r -> (r ^. rid, r)) <$> mapM validateNativeType (toList real)
    mp <- makeEdgeMap verified
    definedRes <- use definedResources
    return (verified, mp, exported, HM.elems definedRes)

makeEdgeMap :: FinalCatalog -> InterpreterMonad EdgeMap
makeEdgeMap ct = do
    -- merge the looaded classes and resources
    defs' <- HM.map _rpos <$> 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.
    -- step 1 - add relations that are stored in resources
    let reorderlink :: (RIdentifier, RIdentifier, LinkType) -> (RIdentifier, RIdentifier, LinkType)
        reorderlink (s, d, RRequire)   = (d, s, RBefore)
        reorderlink (s, d, RSubscribe) = (d, s, RNotify)
        reorderlink x = x
        addRR curmap r = iunionWith (<>) curmap newmap
            where
               -- compute the explicit resources, along with the container relationship
               newmap = ifromListWith (<>) resresources
               resid = r ^. rid
               respos = r ^. rpos
               resresources = do
                   (rawdst, lts) <- itoList (r ^. rrelations)
                   lt <- toList lts
                   let (nsrc, ndst, nlt) = reorderlink (resid, rawdst, lt)
                   return (nsrc, [LinkInformation nsrc ndst nlt respos])
        step1 = foldl' addRR mempty ct
    -- step 2 - add other relations (mainly stuff made from the "->"
    -- operator)
    let realign (LinkInformation s d t p) =
            let (ns, nd, nt) = reorderlink (s, d, t)
            in  (ns, [LinkInformation ns nd nt p])
    rels <- map 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 = do
                    let modulename = getModulename r
                    ign <- singleton (IsIgnoredModule modulename)
                    unless ((defs & has (ix r)) || ign) (throwPosError msg)
                errmsg = "Unknown resource" <+> pretty ri <+> "used in the following relationships:" <+> vcat (map pretty 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)
    edgeList <- mapM checkResDef (itoList step2)
    let (graph, gresolver) = G.graphFromEdges' edgeList
    -- now check for scc
    let sccs = filter ((>1) . length . T.flatten) (G.scc graph)
    unless (null sccs) $ do
        let trees = vcat (map showtree sccs)
            showtree = indent 2 . vcat . map (mkp . gresolver) . T.flatten
            mkp (a,_,links) = resdesc <+> lnks
                where
                   resdesc = case ct ^. at a of
                                 Just r -> pretty r
                                 _ -> pretty a
                   lnks = pretty links
        throwPosError $ "Dependency error, the following resources are strongly connected!" </> trees
        -- let edgePairs = concatMap (\(_,k,ls) -> [(k,l) | l <- ls]) edgeList
        -- throwPosError (vcat (map (\(RIdentifier st sn, RIdentifier dt dn) -> "\"" <> ttext st <> ttext sn <> "\" -> \"" <> ttext dt <> ttext dn <> "\"") edgePairs))
    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 (PrettyError ("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 :: Nd -> InterpreterMonad [Resource]
evaluateNode (Nd _ 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

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 (ClassDecl cname _ _ _ _)) =
    if "::" `T.isInfixOf` cname
       then nestedDeclarations . at (TopClass, cname) ?= r >> return []
       else do
           scp <- getScopeName
           let rcname = if scp == "::"
                            then cname
                            else scp <> "::" <> cname
           nestedDeclarations . at (TopClass, rcname) ?= r
           return []
evaluateStatement r@(DefineDeclaration (DefineDec 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 (RColl 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)
                   ) <$> singleton (PDBGetResources q)
            scpdesc <- ContImported <$> getScope
            void $ enterScope SENormal scpdesc "importing" p
            pushScope scpdesc
            o <- finalize res
            popScope
            return o
        else return []
evaluateStatement (Dependency (Dep (t1 :!: n1) (t2 :!: n2) lt p)) = do
    curPos .= p
    rn1 <- map (fixResourceName t1) <$> resolveExpressionStrings n1
    rn2 <- map (fixResourceName t2) <$> resolveExpressionStrings n2
    extraRelations <>= [ LinkInformation (RIdentifier t1 an1) (RIdentifier t2 an2) lt p | an1 <- rn1, an2 <- rn2 ]
    return []
evaluateStatement (ResourceDeclaration (ResDec rt ern eargs virt p)) = do
    curPos .= p
    resnames <- resolveExpressionStrings ern
    args <- vmapM resolveArgument eargs >>= fromArgumentList
    concat <$> mapM (\n -> registerResource rt n args virt p) resnames
evaluateStatement (MainFunctionCall (MFC funcname funcargs p)) = do
    curPos .= p
    vmapM resolveExpression funcargs >>= mainFunctionCall funcname
evaluateStatement (VariableAssignment (VarAss varname varexpr p)) = do
    curPos .= p
    varval <- resolveExpression varexpr
    loadVariable varname varval
    return []
evaluateStatement (ConditionalStatement (CondStatement conds p)) = do
    curPos .= p
    let checkCond [] = return []
        checkCond ((e :!: stmts) : xs) = do
            result <- pValue2Bool <$> resolveExpression e
            if result
                then evaluateStatementsVector stmts
                else checkCond xs
    checkCond (toList conds)
evaluateStatement (DefaultDeclaration (DefaultDec resType decls p)) = do
    curPos .= p
    let resolveDefaultValue (prm :!: v) = (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 (ResOver 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 (SFC c p)) = curPos .= p >> evaluateHFC c
evaluateStatement r = throwError (PrettyError ("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) <$> 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)) -> 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 (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 were 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) <$> 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 = getModulename (r ^. rid)
    let 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, dls') <- getstt TopDefine deftype
    dls <- extractPrism _DefineDeclaration' "expandDefine" dls'
    let isImported (ContImported _) = True
        isImported _ = False
    isImportedDefine <- isImported <$> getScope
    case dls of
        (DefineDec _ defineParams stmts cp) -> do
            curPos .= r ^. rpos
            curscp <- getScope
            when isImportedDefine (pushScope (ContImport (r ^. rnode) curscp ))
            pushScope curContType
            imods <- singleton (IsIgnoredModule modulename)
            out <- if imods
                       then return mempty
                       else do
                            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
                            finalize (spurious ++ res)
            when isImportedDefine popScope
            popScope
            return out


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
            cls <- extractPrism _ClassDeclaration' "loadClass" cls'
            case cls of
                (ClassDecl _ 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 = getModulename (RIdentifier "class" classname)
                        secontext = case (inh, loadedfrom) of
                                        (S.Just x,_) -> SEChild (dropInitialColons x)
                                        (_,S.Just x) -> SEParent (dropInitialColons 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
                    imods <- singleton (IsIgnoredModule modulename)
                    out <- if imods
                               then return mempty
                               else do
                                    loadVariable "title" (PString classname)
                                    loadVariable "name" (PString classname)
                                    loadParameters params classParams cp (S.Just classname)
                                    curPos .= cp
                                    res <- evaluateStatementsVector stmts
                                    finalize (classresource ++ spurious ++ inhstmts ++ res)
                    popScope
                    return out
-----------------------------------------------------------
-- Resource stuff
-----------------------------------------------------------

addRelationship :: LinkType -> PValue -> Resource -> InterpreterMonad Resource
addRelationship lt (PResourceReference dt dn) r = return (r & rrelations %~ insertLt)
    where
        insertLt = iinsertWith (<>) (RIdentifier dt dn) (HS.singleton lt)
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 -> T.Text -> Resource -> PValue -> InterpreterMonad Resource
addAttribute _ "alias"     r v = (\rv -> r & ralias . contains rv .~ True) <$> resolvePValueString v
addAttribute _ "audit"     r _ = use curPos >>= \p -> warn ("Metaparameter audit ignored at" <+> showPPos p) >> return r
addAttribute _ "noop"      r _ = use curPos >>= \p -> warn ("Metaparameter noop ignored at" <+> showPPos p) >> return r
addAttribute _ "loglevel"  r _ = use curPos >>= \p -> warn ("Metaparameter loglevel ignored at" <+> showPPos p) >> return r
addAttribute _ "schedule"  r _ = use curPos >>= \p -> warn ("Metaparameter schedule ignored at" <+> showPPos p) >> return r
addAttribute _ "stage"     r _ = use curPos >>= \p -> warn ("Metaparameter stage ignored at" <+> showPPos p) >> return r
addAttribute _ "tag"       r (PArray v) = foldM (\cr cv -> addTagResource cr <$> resolvePValueString cv) r (toList v)
addAttribute _ "tag"       r v = addTagResource r <$> resolvePValueString v
addAttribute _ "before"    r d = addRelationship RBefore d r
addAttribute _ "notify"    r d = addRelationship RNotify d r
addAttribute _ "require"   r d = addRelationship RRequire d r
addAttribute _ "subscribe" r d = addRelationship RSubscribe d r
addAttribute b t r 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, !defaultLink) = getClassTags cnt
        getClassTags (ContClass cn      ) = (allsegs cn,RIdentifier "class" cn)
        getClassTags (ContDefine dt dn _) = (allsegs dt,RIdentifier dt dn)
        getClassTags (ContRoot          ) = ([],RIdentifier "class" "::")
        getClassTags (ContImported _    ) = ([],RIdentifier "class" "::")
        getClassTags (ContImport _ _    ) = ([],RIdentifier "class" "::")
        defaultRelation = HM.singleton defaultLink (HS.singleton RRequire)
    allScope <- use curScope
    fqdn <- singleton GetNodeName
    let baseresource = Resource (RIdentifier rt rn) (HS.singleton rn) mempty defaultRelation allScope vrt defaulttags p fqdn
    r <- ifoldlM (addAttribute CantOverride) baseresource 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 = concat <$> mapM doInclude includes
    where doInclude 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)
    concat . HM.elems <$> itraverse genRes 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] = ("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 <- toListOf (traverse . _PArray . traverse) <$> runHiera ndname ArrayMerge
    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 (MFC 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)