language-puppet-1.5.1: tests/Helpers.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedLists #-}

module Helpers
  ( module Exports,
    checkExprsSuccess,
    checkExprsError,
    pureCatalog,
    getResource,
    getAttribute,
    renderToString,
    withStdlibFunction,
  )
where

import qualified Data.HashMap.Strict as HM
import qualified Data.Maybe.Strict as S
import qualified Data.Vector as Vector
import Puppet.Interpreter as Exports
import Puppet.Parser as Exports
import Puppet.Runner as Exports hiding (getCatalog)
import Test.Hspec as Exports
import XPrelude as Exports

-- | Given a raw text input to be parsed, compute the manifest in a pure setting.
-- The 'InterpreterWriter' might be useful for debugging purpose.
pureCatalog :: Text -> Either String (FinalCatalog, InterpreterWriter)
pureCatalog = runExcept . fmap (\s -> (s ^. _1, s ^. _6)) . compileCatalog
  where
    compileCatalog :: Text -> Except String (FinalCatalog, EdgeMap, FinalCatalog, [Resource], InterpreterState, InterpreterWriter)
    compileCatalog input = do
      statements <- either (throwError . show) pure (runPuppetParser mempty input)
      let nodename = "pure"
          top_node = [((TopNode, nodename), NodeDeclaration (NodeDecl (NodeName nodename) statements S.Nothing (initialPPos mempty)))]
          (res, finalState, logs) = pureEval top_node (computeCatalog nodename)
      (catalog, em, exported, defResources) <- either (throwError . show) pure res
      pure (catalog, em, exported, defResources, finalState, logs)

getResource :: (MonadFail m) => RIdentifier -> FinalCatalog -> m Resource
getResource resid catalog = maybe (fail ("Unknown resource " <> renderToString resid)) pure (HM.lookup resid catalog)

getAttribute :: (MonadFail m) => Text -> Resource -> m PValue
getAttribute att res =
  case res ^? rattributes . ix att of
    Nothing -> fail ("Unknown attribute: " <> toS att)
    Just x -> return x

withStdlibFunction :: Text -> (([PValue] -> InterpreterMonad PValue) -> Spec) -> Spec
withStdlibFunction fname testsuite =
  case stdlibFunctions ^? ix fname of
    Just f -> testsuite f
    Nothing -> panic ("Don't know this function: " <> fname)

checkExprsSuccess :: Text -> [Expression] -> Text -> Expectation
checkExprsSuccess fname args res =
  case evalExprs fname args of
    Left rr -> expectationFailure (show rr)
    Right res' -> res' `shouldBe` res

checkExprsError :: Text -> [Expression] -> String -> Expectation
checkExprsError fname args msg =
  case evalExprs fname args of
    Left rr -> show rr `shouldContain` msg
    Right r -> expectationFailure ("Should have errored, received this instead: " <> show r)

evalExprs :: Text -> [Expression] -> Either PrettyError Text
evalExprs fname =
  dummyEval . resolveValue . UFunctionCall fname . Vector.fromList >=> \case
    PString s -> return s
    v -> Left ("Expected a string, not " <> PrettyError (pretty v))

renderToString :: (Pretty a) => a -> String
renderToString d = displayS (renderCompact (pretty d)) ""