diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,7 @@ +# v1.3.9 (2017/07/30) + +* Moved to megaparsec 6 + # v1.3.8.1 (2017/07/21) * Fix haddocks error (#208) diff --git a/Puppet/Interpreter/Resolve.hs b/Puppet/Interpreter/Resolve.hs --- a/Puppet/Interpreter/Resolve.hs +++ b/Puppet/Interpreter/Resolve.hs @@ -632,17 +632,22 @@ S.Just x -> return x S.Nothing -> throwPosError ("No expression to run the function on" <+> pretty hol) sourcevalue <- resolveExpression sourceexpression + let check Nothing = const (return ()) + check (Just dtype) = mapM_ (\v -> unless (datatypeMatch dtype v) (throwPosError (pretty v <+> "isn't of type" <+> pretty dtype))) case (sourcevalue, hol ^. hoLambdaParams) of - (PArray pr, BPSingle varname) -> return (map (\x -> [(varname, x)]) (V.toList pr)) - (PArray pr, BPPair idx var) -> return $ do - (i,v) <- Prelude.zip ([0..] :: [Int]) (V.toList pr) - return [(idx,PString (T.pack (show i))),(var,v)] - (PHash hh, BPSingle varname) -> return $ do - (k,v) <- HM.toList hh - return [(varname, PArray (V.fromList [PString k,v]))] - (PHash hh, BPPair idx var) -> return $ do - (k,v) <- HM.toList hh - return [(idx,PString k),(var,v)] + (PArray pr, BPSingle (LParam mvtype varname)) -> do + check mvtype pr + return (map (\x -> [(varname, x)]) (V.toList pr)) + (PArray pr, BPPair (LParam _ idx) (LParam mvtype var)) -> do + check mvtype pr + return [ [(idx,PString (T.pack (show i))),(var,v)] | (i,v) <- Prelude.zip ([0..] :: [Int]) (V.toList pr) ] + (PHash hh, BPSingle (LParam mvtype varname)) -> do + check mvtype hh + return [ [(varname, PArray (V.fromList [PString k,v]))] | (k,v) <- HM.toList hh] + (PHash hh, BPPair (LParam midxtype idx) (LParam mvtype var)) -> do + check mvtype hh + check midxtype (PString <$> HM.keys hh) + return [ [(idx,PString k),(var,v)] | (k,v) <- HM.toList hh] (invalid, _) -> throwPosError ("Can't iterate on this data type:" <+> pretty invalid) -- | Sets the proper variables, and returns the scope variables the way diff --git a/Puppet/Parser.hs b/Puppet/Parser.hs --- a/Puppet/Parser.hs +++ b/Puppet/Parser.hs @@ -23,17 +23,20 @@ import qualified Data.Text.Encoding as T import Data.Tuple.Strict hiding (fst,zip) import qualified Data.Vector as V +import Data.Void (Void) import Text.Megaparsec hiding (token) +import Text.Megaparsec.Char +import qualified Text.Megaparsec.Char.Lexer as L import Text.Megaparsec.Expr -import qualified Text.Megaparsec.Lexer as L -import Text.Megaparsec.Text import Text.Regex.PCRE.ByteString.Utils import Puppet.Parser.Types import Puppet.Utils +type Parser = Parsec Void T.Text + -- | Run a puppet parser against some 'T.Text' input. -runPParser :: String -> T.Text -> Either (ParseError Char Dec) (V.Vector Statement) +runPParser :: String -> T.Text -> Either (ParseError Char Void) (V.Vector Statement) runPParser = parse puppetParser someSpace :: Parser () @@ -43,17 +46,15 @@ token = L.lexeme someSpace integerOrDouble :: Parser (Either Integer Double) -integerOrDouble = fmap Right (try (L.signed someSpace L.float)) <|> fmap Left (hex <|> dec) +integerOrDouble = fmap Left hex <|> (either Right Left . floatingOrInteger <$> L.scientific) where - dec = L.signed someSpace L.integer - hex = try (string "0x") *> L.hexadecimal - + hex = string "0x" *> L.hexadecimal -symbol :: String -> Parser () +symbol :: T.Text -> Parser () symbol = void . try . L.symbol someSpace symbolic :: Char -> Parser () -symbolic = symbol . pure +symbolic = symbol . T.singleton braces :: Parser a -> Parser a braces = between (symbol "{") (symbol "}") @@ -128,10 +129,10 @@ nxt <- token $ many nxtl return $ T.pack $ f : nxt -operator :: String -> Parser () +operator :: T.Text -> Parser () operator = void . try . symbol -reserved :: String -> Parser () +reserved :: T.Text -> Parser () reserved s = try $ do void (string s) notFollowedBy (satisfy identifierPart) @@ -147,8 +148,8 @@ qualif :: Parser T.Text -> Parser T.Text qualif p = token $ do - header <- T.pack <$> option "" (try (string "::")) - ( header <> ) . T.intercalate "::" <$> p `sepBy1` try (string "::") + header <- option "" (string "::") + ( header <> ) . T.intercalate "::" <$> p `sepBy1` string "::" qualif1 :: Parser T.Text -> Parser T.Text qualif1 p = try $ do @@ -200,7 +201,7 @@ -- this is specialized because we can't be "tokenized" here variableAccept x = isAsciiLower x || isAsciiUpper x || isDigit x || x == '_' rvariableName = do - v <- T.pack . concat <$> some (string "::" <|> some (satisfy variableAccept)) + v <- T.concat <$> some (string "::" <|> fmap T.pack (some (satisfy variableAccept))) when (v == "string") (fail "The special variable $string must not be used") return v rvariable = Terminal . UVariableReference <$> rvariableName @@ -655,17 +656,17 @@ <|> (reserved "Enum" *> (DTEnum . NE.fromList <$> brackets ((stringLiteral' <|> bareword) `sepBy1` symbolic ','))) "DataType" where - integer = integerOrDouble >>= either (return . fromIntegral) (const (fail "Integer value expected")) + integer = integerOrDouble >>= either (return . fromIntegral) (\d -> fail ("Integer value expected, instead of " ++ show d)) float = either fromIntegral id <$> integerOrDouble dtArgs str def parseArgs = do void $ reserved str fromMaybe def <$> optional (brackets parseArgs) dtbounded s constructor parser = dtArgs s (constructor Nothing Nothing) $ do - lst <- parser `sepBy` symbolic ',' + lst <- parser `sepBy1` symbolic ',' case lst of [minlen] -> return $ constructor (Just minlen) Nothing [minlen,maxlen] -> return $ constructor (Just minlen) (Just maxlen) - _ -> fail ("Too many arguments to datatype " ++ s) + _ -> fail ("Too many arguments to datatype " ++ T.unpack s) dtString = dtbounded "String" DTString integer dtInteger = dtbounded "Integer" DTInteger integer dtFloat = dtbounded "Float" DTFloat float @@ -721,8 +722,10 @@ lambParams = between (symbolic '|') (symbolic '|') hp where acceptablePart = T.pack <$> identifier + lambdaParameter :: Parser LambdaParameter + lambdaParameter = LParam <$> optional datatype <*> (char '$' *> acceptablePart) hp = do - vars <- (char '$' *> acceptablePart) `sepBy1` comma + vars <- lambdaParameter `sepBy1` comma case vars of [a] -> return (BPSingle a) [a,b] -> return (BPPair a b) diff --git a/Puppet/Parser/PrettyPrinter.hs b/Puppet/Parser/PrettyPrinter.hs --- a/Puppet/Parser/PrettyPrinter.hs +++ b/Puppet/Parser/PrettyPrinter.hs @@ -97,9 +97,10 @@ instance Pretty LambdaParameters where pretty b = magenta (char '|') <+> vars <+> magenta (char '|') where + pmspace = foldMap ((<> " ") . pretty) vars = case b of - BPSingle v -> pretty (UVariableReference v) - BPPair v1 v2 -> pretty (UVariableReference v1) <> comma <+> pretty (UVariableReference v2) + BPSingle (LParam mt v) -> pmspace mt <> pretty (UVariableReference v) + BPPair (LParam mt1 v1) (LParam mt2 v2) -> pmspace mt1 <> pretty (UVariableReference v1) <> comma <+> pmspace mt2 <> pretty (UVariableReference v2) instance Pretty SearchExpression where pretty (EqualitySearch t e) = text (T.unpack t) <+> text "==" <+> pretty e diff --git a/Puppet/Parser/Types.hs b/Puppet/Parser/Types.hs --- a/Puppet/Parser/Types.hs +++ b/Puppet/Parser/Types.hs @@ -24,6 +24,7 @@ HOLambdaCall(..), ChainableRes(..), HasHOLambdaCall(..), + LambdaParameter(..), LambdaParameters(..), CompRegex(..), CollectorType(..), @@ -104,7 +105,7 @@ -- | Generates a 'PPosition' based on a filename and line number. toPPos :: Text -> Int -> PPosition toPPos fl ln = - let p = (initialPos (T.unpack fl)) { sourceLine = unsafePos $ fromIntegral (max 1 ln) } + let p = (initialPos (T.unpack fl)) { sourceLine = mkPos $ fromIntegral (max 1 ln) } in (p :!: p) -- | High Order "lambdas" @@ -121,8 +122,12 @@ -- Currently only two types of block parameters are supported: -- single values and pairs. data LambdaParameters - = BPSingle !Text -- ^ @|k|@ - | BPPair !Text !Text -- ^ @|k,v|@ + = BPSingle !LambdaParameter -- ^ @|k|@ + | BPPair !LambdaParameter !LambdaParameter -- ^ @|k,v|@ + deriving (Eq, Show) + +data LambdaParameter + = LParam !(Maybe DataType) !Text deriving (Eq, Show) -- The description of the /higher level lambda/ call. diff --git a/PuppetDB/Dummy.hs b/PuppetDB/Dummy.hs --- a/PuppetDB/Dummy.hs +++ b/PuppetDB/Dummy.hs @@ -3,7 +3,6 @@ module PuppetDB.Dummy where import Puppet.Interpreter.Types -import Control.Monad.Except dummyPuppetDB :: Monad m => PuppetDBAPI m dummyPuppetDB = PuppetDBAPI 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.8.1 +version: 1.3.9 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/ @@ -15,7 +15,7 @@ build-type: Simple cabal-version: >=1.8 -Tested-With: GHC == 7.10.3, GHC == 8.0.2 +Tested-With: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.1 extra-source-files: CHANGELOG.markdown @@ -93,7 +93,6 @@ , containers == 0.5.* , cryptonite >= 0.6 , directory >= 1.2 && < 1.4 - , either >= 4.3 && < 4.5 , exceptions >= 0.8 && < 0.9 , filecache >= 0.2.9 && < 0.3 , formatting @@ -105,7 +104,7 @@ , hspec , lens >= 4.12 && < 5 , lens-aeson >= 1.0 - , megaparsec >= 5 && < 6 + , megaparsec >= 6 && < 7 , memory >= 0.7 , mtl >= 2.2.1 && < 2.3 , operational >= 0.2.3 && < 0.3 diff --git a/progs/PuppetResources.hs b/progs/PuppetResources.hs --- a/progs/PuppetResources.hs +++ b/progs/PuppetResources.hs @@ -23,6 +23,7 @@ import Data.Tuple (swap) import qualified Data.Vector as V import qualified Data.Version (showVersion) +import Data.Void (Void) import Network.HTTP.Client import Options.Applicative import qualified Paths_language_puppet @@ -47,7 +48,7 @@ import PuppetDB.Remote (pdbConnect) import PuppetDB.TestDB (loadTestDB) -type ParseError' = P.ParseError Char P.Dec +type ParseError' = P.ParseError Char Void type QueryFunc = NodeName -> IO (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) data MultNodes = MultNodes [T.Text] | AllNodes deriving Show diff --git a/tests/Helpers.hs b/tests/Helpers.hs --- a/tests/Helpers.hs +++ b/tests/Helpers.hs @@ -17,7 +17,6 @@ import Puppet.Stdlib import Control.Lens -import Control.Monad.Except import qualified Data.HashMap.Strict as HM import qualified Data.Maybe.Strict as S import Data.Text (Text, unpack) diff --git a/tests/lexer.hs b/tests/lexer.hs --- a/tests/lexer.hs +++ b/tests/lexer.hs @@ -7,7 +7,7 @@ import System.Environment import Puppet.Parser.PrettyPrinter import Text.PrettyPrint.ANSI.Leijen -import Text.Megaparsec (parse, eof) +import Text.Megaparsec (parse, eof, parseErrorPretty) import System.Posix.Terminal import System.Posix.Types import System.IO @@ -26,7 +26,7 @@ testparser fp = fmap (parse (puppetParser <* eof) fp) (T.readFile fp) >>= \case Right _ -> return ("PASS", True) - Left rr -> return (show rr, False) + Left rr -> return (parseErrorPretty rr, False) check :: String -> IO () check fname = do @@ -38,7 +38,7 @@ then renderPretty 0.2 200 else renderCompact case res of - Left rr -> print rr + Left rr -> putStrLn (parseErrorPretty rr) Right x -> do putStrLn "" displayIO stdout (rfunc (pretty (ppStatements x)))