diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,4 +1,13 @@ -language-puppet (1.3.14) UNRELEASED; urgency=medium +language-puppet (1.3.15) artful; urgency=medium + + * Improve parsing error messages + * Improve source position display + * Support OS X via filecache-0.3 + * Add ability to use the json ruby module in erbs + + -- Bartavelle Sun, 18 Feb 2018 20:40:57 +0100 + +language-puppet (1.3.14) xenial; urgency=medium * Allow declaring type of variables during assignment * The `lookup` function now fails if an input strategy is unknown diff --git a/README.adoc b/README.adoc --- a/README.adoc +++ b/README.adoc @@ -183,7 +183,7 @@ == Unsupported Puppet idioms or features OS:: - * `OS X` is currently not supported (https://github.com/bartavelle/language-puppet/issues/197[issue #197]) + * `OS X` is supported when using the latest `filecache-0.3`. puppet functions:: * the `require` function is not supported (see https://github.com/bartavelle/language-puppet/issues/17[issue #17]) diff --git a/language-puppet.cabal b/language-puppet.cabal --- a/language-puppet.cabal +++ b/language-puppet.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: language-puppet -version: 1.3.14 +version: 1.3.15 synopsis: Tools to parse and evaluate the Puppet DSL. description: This is a set of tools that is supposed to fill all your Puppet needs : syntax checks, catalog compilation, PuppetDB queries, simulationg of complex interactions between nodes, Puppet master replacement, and more ! homepage: http://lpuppet.banquise.net/ @@ -88,7 +88,7 @@ , Puppet.Runner.Daemon.FileParser , Puppet.Runner.Daemon.OptionalTests , Puppet.Runner.Daemon - extensions: OverloadedStrings, BangPatterns, LambdaCase, NoImplicitPrelude + extensions: OverloadedStrings, BangPatterns, LambdaCase, NoImplicitPrelude, FlexibleContexts, FlexibleInstances ghc-options: -Wall -funbox-strict-fields -j1 -- ghc-prof-options: -auto-all -caf-all build-depends: aeson >= 0.8 @@ -102,7 +102,7 @@ , cryptonite >= 0.6 , directory >= 1.2 && < 1.4 , exceptions >= 0.8 && < 0.9 - , filecache >= 0.2.9 && < 0.3 + , filecache >= 0.2.9 && < 0.4 , filepath >= 1.4 , formatting , hashable == 1.2.* @@ -124,8 +124,8 @@ , random , regex-pcre-builtin >= 0.94.4 , scientific >= 0.2 && < 0.4 - , servant >= 0.9 - , servant-client >= 0.9 + , servant >= 0.9 && < 0.13 + , servant-client >= 0.9 && < 0.13 , split == 0.2.* , stm == 2.4.* , strict-base-types >= 0.3 @@ -161,7 +161,7 @@ hs-source-dirs: tests type: exitcode-stdio-1.0 ghc-options: -Wall -rtsopts -threaded - extensions: OverloadedStrings, NoImplicitPrelude + extensions: OverloadedStrings, NoImplicitPrelude, FlexibleContexts Other-Modules: Helpers build-depends: language-puppet,base,hspec,temporary,strict-base-types,HUnit,lens,vector,unordered-containers,text,hslogger,neat-interpolation,protolude >=0.2,scientific,mtl main-is: hiera.hs @@ -183,7 +183,7 @@ hs-source-dirs: tests type: exitcode-stdio-1.0 ghc-options: -Wall -Wno-missing-signatures -rtsopts -threaded - extensions: OverloadedStrings, NoImplicitPrelude + extensions: OverloadedStrings, NoImplicitPrelude, FlexibleContexts build-depends: language-puppet,base,strict-base-types,lens,text,hspec,unordered-containers,megaparsec,vector,scientific,mtl,hspec-megaparsec, protolude >= 0.2 other-modules: Function.ShellquoteSpec Function.SprintfSpec diff --git a/progs/PuppetResources.hs b/progs/PuppetResources.hs --- a/progs/PuppetResources.hs +++ b/progs/PuppetResources.hs @@ -23,7 +23,6 @@ import qualified System.FilePath.Glob as Glob import System.IO (hIsTerminalDevice) import qualified System.Log.Logger as Log -import qualified Text.Megaparsec as Megaparsec import qualified Text.Regex.PCRE.String as Reg import Puppet.Parser hiding (Parser) @@ -32,7 +31,6 @@ puppetDBFacts) import qualified PuppetDB -type ParseError' = Megaparsec.ParseError Char Void type QueryFunc = NodeName -> IO (Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) data MultNodes @@ -178,8 +176,12 @@ unifyFacts :: Container PValue -> Container PValue -> Container PValue -> Container PValue unifyFacts defaults override c = override `Map.union` c `Map.union` defaults -parseFile :: FilePath -> IO (Either ParseError' (V.Vector Statement)) -parseFile fp = runPParser fp <$> readFile fp +parseFile :: FilePath -> IO (V.Vector Statement) +parseFile fp = do + s <- readFile fp + case runPuppetParser fp s of + Left err -> putDoc (red "ERROR:" <+> getError (prettyParseError s err)) *> exitFailure + Right r -> pure r printContent :: Text -> FinalCatalog -> IO () printContent filename catalog = @@ -233,7 +235,9 @@ unless (Set.null deadfiles) $ do putDoc ("The following files" <+> pretty (Set.size deadfiles) <+> "are not used: " <> list (map ppstring $ Set.toList deadfiles)) putText "" - allparses <- parallel (map parseFile (Set.toList usedfiles)) + allparses <- do + let parsefp fp = runPuppetParser fp <$> readFile fp + parallel (map (parsefp) (Set.toList usedfiles)) let (parseFailed, parseSucceeded) = partitionEithers allparses unless (null parseFailed) $ do putDoc ("The following" <+> pretty (length parseFailed) <+> "files could not be parsed:" <> softline <> indent 4 (vcat (map (ppstring . show) parseFailed))) @@ -360,11 +364,11 @@ run Options {_optVersion = True, ..} = putStrLn ("language-puppet " ++ Data.Version.showVersion Meta.version) -- Parse mode -run Options {_optParse = Just fp, ..} = parseFile fp >>= \case - Left rr -> panic (toS $ Megaparsec.parseErrorPretty rr) - Right s -> if _optLoglevel == Log.DEBUG - then mapM_ print s - else putDoc $ ppStatements s +run Options {_optParse = Just fp, ..} = do + sx <- parseFile fp + if _optLoglevel == Log.DEBUG + then mapM_ print sx + else putDoc $ ppStatements sx run Options {_optPuppetdir = Nothing, _optParse = Nothing } = panic "Without a puppet dir, only the `--parse` option can be supported" @@ -384,9 +388,7 @@ where retrieveNodes :: MultNodes -> IO [NodeName] retrieveNodes AllNodes = do - allstmts <- parseFile (workingdir <> "/manifests/site.pp") >>= \case - Left err -> panic (show err) - Right x -> return x + allstmts <- parseFile (workingdir <> "/manifests/site.pp") let getNodeName (NodeDeclaration (NodeDecl (NodeName n) _ _ _)) = Just n getNodeName _ = Nothing return $ mapMaybe getNodeName (V.toList allstmts) diff --git a/ruby/hrubyerb.rb b/ruby/hrubyerb.rb --- a/ruby/hrubyerb.rb +++ b/ruby/hrubyerb.rb @@ -1,6 +1,7 @@ require 'erb' require 'digest/md5' require 'yaml' +require 'json' class Scope def initialize(context,variables,filename,stt,rdr) diff --git a/src/Hiera/Server.hs b/src/Hiera/Server.hs --- a/src/Hiera/Server.hs +++ b/src/Hiera/Server.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} @@ -34,6 +33,7 @@ import qualified Data.Text as Text import qualified Data.Vector as Vector import qualified Data.Yaml as Yaml +import qualified System.Directory as Directory import qualified System.FilePath as FilePath import System.FilePath.Lens (directory) @@ -201,15 +201,16 @@ basedir = case datadir of '/' : _ -> mempty _ -> fp ^. directory <> "/" - efilecontent <- Cache.query cache filename (decodefunction filename) - case efilecontent of - S.Left r -> do - let errs = "Hiera: error when reading file " <> ppstring filename <+> ppstring r - if "Yaml file not found: " `List.isInfixOf` r - then logDebug (show errs) - else logWarning (show errs) - return Nothing - S.Right val -> return (Just val) + querycache = do + efilecontent <- Cache.query cache filename (decodefunction filename) + case efilecontent of + S.Left r -> do + logWarningStr $ "Hiera: error when reading file " <> filename <> ": "<> r + pure Nothing + S.Right val -> pure (Just val) + ifM (Directory.doesFileExist filename) + querycache + (pure Nothing) let vals = catMaybes mvals -- step 3, query through all the results return (strictifyEither $ runReader (runExceptT (recursiveQuery hquery [])) (QRead vars qt vals)) diff --git a/src/Puppet/Interpreter.hs b/src/Puppet/Interpreter.hs --- a/src/Puppet/Interpreter.hs +++ b/src/Puppet/Interpreter.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} module Puppet.Interpreter @@ -200,7 +199,7 @@ 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 dummyppos nodename + mainstage = Resource (RIdentifier "stage" "main") mempty mempty mempty [ContRoot] Normal mempty (initialPPos mempty) nodename evaluateNode :: NodeDecl -> InterpreterMonad [Resource] evaluateNode (NodeDecl _ sx inheritnode p) = do @@ -834,7 +833,7 @@ mainFunctionCall "debug" a = logWithModifier Log.DEBUG dullwhite a mainFunctionCall "emerg" a = logWithModifier Log.EMERGENCY red a mainFunctionCall "err" a = logWithModifier Log.ERROR dullred a -mainFunctionCall "info" a = logWithModifier Log.INFO green a +mainFunctionCall "info" a = logWithModifier Log.INFO dullgreen a mainFunctionCall "notice" a = logWithModifier Log.NOTICE white a mainFunctionCall "warning" a = logWithModifier Log.WARNING dullyellow a mainFunctionCall "contain" includes = diff --git a/src/Puppet/Interpreter/Helpers.hs b/src/Puppet/Interpreter/Helpers.hs --- a/src/Puppet/Interpreter/Helpers.hs +++ b/src/Puppet/Interpreter/Helpers.hs @@ -1,5 +1,4 @@ {-# OPTIONS_HADDOCK hide, prune, ignore-exports #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} -- | Internal helpers module. @@ -19,16 +18,15 @@ import Facter import Puppet.Interpreter.Types -import Puppet.Parser initialState :: Facts -> Container Text -- ^ Server settings -> InterpreterState initialState facts settings = - InterpreterState baseVars initialclass mempty [ContRoot] dummyppos mempty [] [] + InterpreterState baseVars initialclass mempty [ContRoot] (initialPPos mempty) mempty [] [] where - callervars = Map.fromList [("caller_module_name", PString "::" :!: dummyppos :!: ContRoot), ("module_name", PString "::" :!: dummyppos :!: ContRoot)] + callervars = Map.fromList [("caller_module_name", PString "::" :!: (initialPPos mempty) :!: ContRoot), ("module_name", PString "::" :!: (initialPPos mempty) :!: ContRoot)] factvars = -- add the `facts` key: https://docs.puppet.com/puppet/4.10/lang_facts_and_builtin_vars.html#accessing-facts-from-puppet-code let facts' = Map.insert "facts" (PHash facts) facts @@ -37,7 +35,7 @@ baseVars = Map.fromList [ ("::", ScopeInformation (factvars `mappend` callervars) mempty mempty (CurContainer ContRoot mempty) mempty S.Nothing) , ("settings", ScopeInformation settingvars mempty mempty (CurContainer (ContClass "settings") mempty) mempty S.Nothing) ] - initialclass = mempty & at "::" ?~ (ClassIncludeLike :!: dummyppos) + initialclass = mempty & at "::" ?~ (ClassIncludeLike :!: (initialPPos mempty)) getModulename :: RIdentifier -> Text getModulename (RIdentifier t n) = @@ -93,7 +91,7 @@ scp <- getScopeName preuse (scopes . ix scp . scopeContainer) >>= \case Just x -> return x - Nothing -> throwPosError ("Internal error: can't find the current container for" <+> green (ppline scp)) + Nothing -> throwPosError ("Internal error: can't find the current container for" <+> ppline scp) rcurcontainer :: Resource -> CurContainerDesc rcurcontainer r = fromMaybe ContRoot (r ^? rscope . _head) @@ -162,5 +160,5 @@ classes = (PArray . Vector.fromList . map PString . Map.keys) (s ^. loadedClasses) scps = s ^. scopes container_desc = fromMaybe ContRoot (scps ^? ix scope_name . scopeContainer . cctype) -- get the current containder description - cscps = scps & ix scope_name . scopeVariables . at "classes" ?~ ( classes :!: dummyppos :!: container_desc ) + cscps = scps & ix scope_name . scopeVariables . at "classes" ?~ ( classes :!: (initialPPos mempty) :!: container_desc ) in Just (scope_name, cscps) diff --git a/src/Puppet/Interpreter/IO.hs b/src/Puppet/Interpreter/IO.hs --- a/src/Puppet/Interpreter/IO.hs +++ b/src/Puppet/Interpreter/IO.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs #-} -- | This is an internal module. module Puppet.Interpreter.IO ( diff --git a/src/Puppet/Interpreter/PrettyPrinter.hs b/src/Puppet/Interpreter/PrettyPrinter.hs --- a/src/Puppet/Interpreter/PrettyPrinter.hs +++ b/src/Puppet/Interpreter/PrettyPrinter.hs @@ -1,5 +1,4 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} module Puppet.Interpreter.PrettyPrinter () where diff --git a/src/Puppet/Interpreter/Resolve.hs b/src/Puppet/Interpreter/Resolve.hs --- a/src/Puppet/Interpreter/Resolve.hs +++ b/src/Puppet/Interpreter/Resolve.hs @@ -2,8 +2,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE FlexibleContexts #-} - -- | This module is all about converting and resolving foreign data into -- the fully exploitable corresponding data type. -- diff --git a/src/Puppet/Interpreter/Types.hs b/src/Puppet/Interpreter/Types.hs --- a/src/Puppet/Interpreter/Types.hs +++ b/src/Puppet/Interpreter/Types.hs @@ -1,7 +1,5 @@ {-# LANGUAGE AutoDeriveTypeable #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} diff --git a/src/Puppet/Language/Core.hs b/src/Puppet/Language/Core.hs --- a/src/Puppet/Language/Core.hs +++ b/src/Puppet/Language/Core.hs @@ -14,11 +14,18 @@ showPos :: Position -> Doc -showPos p = green (pretty '#' <+> ppline (show p)) +showPos = blue . pptext . sourcePosPretty +-- | showing a position interval only show the first position showPPos :: PPosition -> Doc -showPPos p = green (pretty '#' <+> ppline (show (Tuple.fst p))) +showPPos = showPos . Tuple.fst +-- | Generates an initial position interval based on a filename. +initialPPos :: FilePath -> PPosition +initialPPos x = + let i = initialPos x + in (i :!: i) + -- | A pair containing the start and end of a given token. type PPosition = Pair Position Position @@ -69,7 +76,7 @@ | otherwise = Text.cons (Char.toUpper (Text.head t)) (Text.tail t) containerComma'' :: Pretty a => [(Doc, a)] -> Doc -containerComma'' x = indent 2 ins +containerComma'' x = indent 4 ins where ins = mconcat $ intersperse (comma <> line <> mempty) (fmap showC x) showC (a,b) = a <+> "=>" <+> pretty b diff --git a/src/Puppet/Language/Resource.hs b/src/Puppet/Language/Resource.hs --- a/src/Puppet/Language/Resource.hs +++ b/src/Puppet/Language/Resource.hs @@ -126,9 +126,9 @@ expandSet (ri, lts) = [(ri, lt) | lt <- Set.toList lts] meta :: Resource -> Doc -meta r = showPPos (r ^. rpos) <+> green (node <+> brackets scp) +meta r = showPPos (r ^. rpos) <+> red node <+> green (brackets scp) where - node = red (ppline (r ^. rnode)) + node = ppline (r ^. rnode) scp = "Scope" <+> pretty (r ^.. rscope . folded . filtered (/=ContRoot) . to pretty) resourceBody :: Resource -> Doc diff --git a/src/Puppet/Language/Value.hs b/src/Puppet/Language/Value.hs --- a/src/Puppet/Language/Value.hs +++ b/src/Puppet/Language/Value.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-} module Puppet.Language.Value diff --git a/src/Puppet/Parser.hs b/src/Puppet/Parser.hs --- a/src/Puppet/Parser.hs +++ b/src/Puppet/Parser.hs @@ -3,23 +3,23 @@ {-| Parse puppet source code from text. -} module Puppet.Parser ( -- * Runner - runPParser + runPuppetParser -- * Parsers , Parser , puppetParser + , PuppetParseError + , prettyParseError + -- ** exposed to ease testing , expression , datatype - -- * Position - , initialPPos - , dummypos - , dummyppos - -- * Pretty Printer + -- * Pretty Print , module Puppet.Parser.PrettyPrinter , module Puppet.Parser.Types , module Puppet.Parser.Lens ) where import XPrelude.Extra hiding (option, try, many, some) +import XPrelude.PP hiding (braces, comma, brackets, parens, sep) import qualified Data.Char as Char import qualified Data.List as List @@ -28,9 +28,9 @@ import qualified Data.Scientific as Scientific import qualified Data.Text as Text import qualified Data.Vector as V -import Text.Megaparsec hiding (token) +import Text.Megaparsec import Text.Megaparsec.Char -import qualified Text.Megaparsec.Char.Lexer as L +import qualified Text.Megaparsec.Char.Lexer as Lexer import Text.Megaparsec.Expr import qualified Text.Regex.PCRE.ByteString.Utils as Regex @@ -39,29 +39,37 @@ import Puppet.Parser.PrettyPrinter import Puppet.Parser.Types + +type PuppetParseError = ParseError Char Void type Parser = Parsec Void Text --- | Run a puppet parser against some 'Text' input. -runPParser :: String -> Text -> Either (ParseError Char Void) (Vector Statement) -runPParser = parse puppetParser +-- | Build a 'PrettyError' from a 'ParseError' given the text source. +-- The source is used to display the line on which the error occurs. +prettyParseError :: Text -> ParseError Char Void -> PrettyError +prettyParseError s err = PrettyError $ "cannot parse" <+> pretty (parseErrorPretty' s err) -someSpace :: Parser () -someSpace = L.space (skipSome spaceChar) (L.skipLineComment "#") (L.skipBlockComment "/*" "*/") +-- | Run a puppet parser against some 'Text' input. +runPuppetParser :: String -> Text -> Either PuppetParseError (Vector Statement) +runPuppetParser src input = parse puppetParser src input -token :: Parser a -> Parser a -token = L.lexeme someSpace +-- space consumer +sc :: Parser () +sc = Lexer.space space1 (Lexer.skipLineComment "#") (Lexer.skipBlockComment "/*" "*/") -integerOrDouble :: Parser (Either Integer Double) -integerOrDouble = fmap Left hex <|> (either Right Left . Scientific.floatingOrInteger <$> L.scientific) - where - hex = string "0x" *> L.hexadecimal +lexeme :: Parser a -> Parser a +lexeme = Lexer.lexeme sc symbol :: Text -> Parser () -symbol = void . try . L.symbol someSpace +symbol = void . Lexer.symbol sc symbolic :: Char -> Parser () symbolic = symbol . Text.singleton +integerOrDouble :: Parser (Either Integer Double) +integerOrDouble = fmap Left hex <|> (either Right Left . Scientific.floatingOrInteger <$> Lexer.scientific) + where + hex = string "0x" *> Lexer.hexadecimal + braces :: Parser a -> Parser a braces = between (symbol "{") (symbol "}") @@ -82,18 +90,18 @@ -- | Parse a collection of puppet 'Statement'. puppetParser :: Parser (Vector Statement) -puppetParser = optional someSpace >> statementList +puppetParser = optional sc >> statementList --- | Parse a puppet 'Expression'. +-- | Parse an 'Expression'. expression :: Parser Expression expression = condExpression - <|> makeExprParser (token terminal) expressionTable + <|> makeExprParser (lexeme terminal) expressionTable "expression" where condExpression = do selectedExpression <- try $ do - trm <- token terminal + trm <- lexeme terminal lookups <- optional indexLookupChain symbolic '?' return $ maybe trm ($ trm) lookups @@ -133,7 +141,7 @@ identl :: Parser Char -> Parser Char -> Parser Text identl fstl nxtl = do f <- fstl - nxt <- token $ many nxtl + nxt <- lexeme $ many nxtl return $ Text.pack $ f : nxt operator :: Text -> Parser () @@ -144,7 +152,7 @@ try $ do void (string s) notFollowedBy (satisfy identifierPart) - someSpace + sc variableName :: Parser Text variableName = do @@ -155,7 +163,7 @@ return out qualif :: Parser Text -> Parser Text -qualif p = token $ do +qualif p = lexeme $ do header <- option "" (string "::") ( header <> ) . Text.intercalate "::" <$> p `sepBy1` string "::" @@ -268,7 +276,7 @@ -- include foo::bar let argsc sep e = (fmap (Terminal . UString) (qualif1 className) <|> e "Function argument A") `sep` comma terminalF = terminalG (fail "function hack") - expressionF = makeExprParser (token terminalF) expressionTable "function expression" + expressionF = makeExprParser (lexeme terminalF) expressionTable "function expression" withparens = parens (argsc sepEndBy expression) withoutparens = argsc sepEndBy1 expressionF args <- withparens <|> if nonparens @@ -278,7 +286,7 @@ literalValue :: Parser UnresolvedValue -literalValue = token (fmap UString stringLiteral' <|> fmap UString bareword <|> fmap UNumber numericalvalue "Literal Value") +literalValue = lexeme (fmap UString stringLiteral' <|> fmap UString bareword <|> fmap UNumber numericalvalue "Literal Value") where numericalvalue = integerOrDouble >>= \i -> case i of Left x -> return (fromIntegral x) @@ -466,8 +474,6 @@ depOperator = (operator "->" *> pure RBefore) <|> (operator "~>" *> pure RNotify) - - assignment :: Parser AttributeDecl assignment = AttributeDecl <$> key <*> arrowOp <*> expression where @@ -478,7 +484,7 @@ <|> (symbol "+>" *> pure AppendArrow) searchExpression :: Parser SearchExpression -searchExpression = makeExprParser (token searchterm) searchTable +searchExpression = makeExprParser (lexeme searchterm) searchTable where searchTable :: [[Operator Parser SearchExpression]] searchTable = [ [ InfixL ( reserved "and" >> return AndSearch ) @@ -499,7 +505,7 @@ e <- option AlwaysTrue searchExpression void (char '|') void (count (length openchev) (char '>')) - someSpace + sc overrides <- option [] $ braces (sepComma assignment) let collectortype = if length openchev == 1 then Collector @@ -756,15 +762,3 @@ [a] -> return (BPSingle a) [a,b] -> return (BPPair a b) _ -> fail "Invalid number of variables between the pipes" - --- | Generates an initial position based on a filename. -initialPPos :: Text -> PPosition -initialPPos x = - let i = initialPos (toS x) - in (i :!: i) - -dummyppos :: PPosition -dummyppos = initialPPos "dummy" - -dummypos :: Position -dummypos = initialPos "dummy" diff --git a/src/Puppet/Parser/Lens.hs b/src/Puppet/Parser/Lens.hs --- a/src/Puppet/Parser/Lens.hs +++ b/src/Puppet/Parser/Lens.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} module Puppet.Parser.Lens ( diff --git a/src/Puppet/Runner/Daemon/FileParser.hs b/src/Puppet/Runner/Daemon/FileParser.hs --- a/src/Puppet/Runner/Daemon/FileParser.hs +++ b/src/Puppet/Runner/Daemon/FileParser.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs #-} module Puppet.Runner.Daemon.FileParser (parseFunc) where import XPrelude @@ -22,7 +21,7 @@ -- | Return an HOF that would parse the file associated with a toplevel. -- The toplevel is defined by the tuple (type, name) -- The result of the parsing is a single Statement (which recursively contains others statements) -parseFunc :: PuppetDirPaths -> FileCache (V.Vector Statement) -> MStats -> TopLevelType -> Text -> IO (S.Either PrettyError Statement) +parseFunc :: PuppetDirPaths -> FileCacheR PrettyError (V.Vector Statement) -> MStats -> TopLevelType -> Text -> IO (S.Either PrettyError Statement) parseFunc ppath filecache stats = \toptype topname -> let nameparts = Text.splitOn "::" topname in let topLevelFilePath :: TopLevelType -> Text -> Either PrettyError Text @@ -36,20 +35,20 @@ Left rr -> return (S.Left rr) Right fname -> do let sfname = Text.unpack fname - handleFailure :: SomeException -> IO (S.Either String (V.Vector Statement)) - handleFailure e = return (S.Left (show e)) - x <- measure stats fname (FileCache.query filecache sfname (parseFile sfname `catch` handleFailure)) + x <- measure stats fname (FileCache.query filecache sfname (parseFile sfname)) case x of S.Right stmts -> filterStatements toptype topname stmts - S.Left rr -> return (S.Left (PrettyError (red (pptext rr)))) + S.Left rr -> return (S.Left rr) -parseFile :: FilePath -> IO (S.Either String (V.Vector Statement)) +parseFile :: FilePath -> IO (S.Either PrettyError (V.Vector Statement)) parseFile fname = do traceEventIO ("START parsing " ++ fname) cnt <- readFile fname - o <- case runPParser fname cnt of + o <- case runPuppetParser fname cnt of Right r -> traceEventIO ("Stopped parsing " ++ fname) >> return (S.Right r) - Left rr -> traceEventIO ("Stopped parsing " ++ fname ++ " (failure: " ++ Megaparsec.parseErrorPretty rr ++ ")") >> return (S.Left (Megaparsec.parseErrorPretty rr)) + Left rr -> do + traceEventIO ("Stopped parsing " ++ fname ++ " (failure: " ++ Megaparsec.parseErrorPretty rr ++ ")") + pure (S.Left $ prettyParseError cnt rr) traceEventIO ("STOP parsing " ++ fname) return o diff --git a/src/Puppet/Runner/Preferences.hs b/src/Puppet/Runner/Preferences.hs --- a/src/Puppet/Runner/Preferences.hs +++ b/src/Puppet/Runner/Preferences.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} diff --git a/src/PuppetDB/TestDB.hs b/src/PuppetDB/TestDB.hs --- a/src/PuppetDB/TestDB.hs +++ b/src/PuppetDB/TestDB.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} diff --git a/src/XPrelude.hs b/src/XPrelude.hs --- a/src/XPrelude.hs +++ b/src/XPrelude.hs @@ -1,3 +1,7 @@ +{-| +General specific prelude for language-puppet. +Customization of the with extra specific utilities. +-} module XPrelude ( module XPrelude.Extra , module XPrelude.PP diff --git a/src/XPrelude/Extra.hs b/src/XPrelude/Extra.hs --- a/src/XPrelude/Extra.hs +++ b/src/XPrelude/Extra.hs @@ -1,8 +1,5 @@ {-# OPTIONS_HADDOCK ignore-exports #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} --- | General specific prelude for language-puppet --- | Customization of the Protolude with extra specific utilities. module XPrelude.Extra ( module Exports , String @@ -10,7 +7,6 @@ , unwrapError , isEmpty , dropInitialColons - , textElem , getDirectoryContents , takeBaseName , strictifyEither @@ -24,6 +20,7 @@ , logInfo , logInfoStr , logWarning + , logWarningStr , logError , logDebugStr ) where @@ -83,10 +80,6 @@ strictifyEither (Left x) = S.Left x strictifyEither (Right x) = S.Right x -textElem :: Char -> Text -> Bool -textElem c = Text.any (==c) - - -- | See "System.FilePath.Posix" takeBaseName :: Text -> Text takeBaseName fullname = @@ -171,6 +164,9 @@ logWarning :: Text -> IO () logWarning = Log.warningM "language-puppet" . toS + +logWarningStr :: String -> IO () +logWarningStr = Log.warningM "language-puppet" logError :: Text -> IO () logError = Log.errorM "language-puppet" . toS diff --git a/tests/Function/DeleteAtSpec.hs b/tests/Function/DeleteAtSpec.hs --- a/tests/Function/DeleteAtSpec.hs +++ b/tests/Function/DeleteAtSpec.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE FlexibleContexts #-} module Function.DeleteAtSpec (spec, main) where diff --git a/tests/Function/MergeSpec.hs b/tests/Function/MergeSpec.hs --- a/tests/Function/MergeSpec.hs +++ b/tests/Function/MergeSpec.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedLists #-} module Function.MergeSpec (spec, main) where diff --git a/tests/Function/SizeSpec.hs b/tests/Function/SizeSpec.hs --- a/tests/Function/SizeSpec.hs +++ b/tests/Function/SizeSpec.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedLists #-} module Function.SizeSpec (spec, main) where diff --git a/tests/Helpers.hs b/tests/Helpers.hs --- a/tests/Helpers.hs +++ b/tests/Helpers.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedLists #-} module Helpers ( module Exports @@ -28,7 +27,7 @@ compileCatalog :: MonadError String m => Text -> m (FinalCatalog, EdgeMap, FinalCatalog, [Resource], InterpreterState) compileCatalog input = do - statements <- either (throwError . show) return (runPParser "dummy" input) + statements <- either (throwError . show) return (runPuppetParser mempty input) let nodename = "node.fqdn" sttmap = [((TopNode, nodename), NodeDeclaration (NodeDecl (NodeName nodename) statements S.Nothing (initialPPos "dummy"))) diff --git a/tests/InterpreterSpec.hs b/tests/InterpreterSpec.hs --- a/tests/InterpreterSpec.hs +++ b/tests/InterpreterSpec.hs @@ -71,7 +71,7 @@ getStatement :: NodeName -> Text -> HashMap (TopLevelType, NodeName) Statement getStatement n i = HM.fromList [ ((TopNode, n), nodeStatement i) - , ((TopClass, "foo"), ClassDeclaration $ ClassDecl mempty mempty mempty mempty (initialPPos "dummy")) + , ((TopClass, "foo"), ClassDeclaration $ ClassDecl mempty mempty mempty mempty (initialPPos mempty)) ] nodeStatement :: Text -> Statement