{-# LANGUAGE TupleSections #-}
{-| Parse puppet source code from text. -}
module Puppet.Parser (
-- * Runner
runPParser
-- * Parsers
, Parser
, puppetParser
, expression
, datatype
-- * Position
, initialPPos
, dummypos
, dummyppos
-- * Pretty Printer
, module Puppet.Parser.PrettyPrinter
, module Puppet.Parser.Types
, module Puppet.Parser.Lens
) where
import XPrelude.Extra hiding (option, try, many, some)
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.List.NonEmpty as NE
import qualified Data.Maybe.Strict as S
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.Char
import qualified Text.Megaparsec.Char.Lexer as L
import Text.Megaparsec.Expr
import qualified Text.Regex.PCRE.ByteString.Utils as Regex
import Puppet.Language
import Puppet.Parser.Lens
import Puppet.Parser.PrettyPrinter
import Puppet.Parser.Types
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
someSpace :: Parser ()
someSpace = L.space (skipSome spaceChar) (L.skipLineComment "#") (L.skipBlockComment "/*" "*/")
token :: Parser a -> Parser a
token = L.lexeme someSpace
integerOrDouble :: Parser (Either Integer Double)
integerOrDouble = fmap Left hex <|> (either Right Left . Scientific.floatingOrInteger <$> L.scientific)
where
hex = string "0x" *> L.hexadecimal
symbol :: Text -> Parser ()
symbol = void . try . L.symbol someSpace
symbolic :: Char -> Parser ()
symbolic = symbol . Text.singleton
braces :: Parser a -> Parser a
braces = between (symbol "{") (symbol "}")
parens :: Parser a -> Parser a
parens = between (symbol "(") (symbol ")")
brackets :: Parser a -> Parser a
brackets = between (symbol "[") (symbol "]")
comma :: Parser ()
comma = symbol ","
sepComma :: Parser a -> Parser [a]
sepComma p = p `sepEndBy` comma
sepComma1 :: Parser a -> Parser [a]
sepComma1 p = p `sepEndBy1` comma
-- | Parse a collection of puppet 'Statement'.
puppetParser :: Parser (Vector Statement)
puppetParser = optional someSpace >> statementList
-- | Parse a puppet 'Expression'.
expression :: Parser Expression
expression =
condExpression
<|> makeExprParser (token terminal) expressionTable
<?> "expression"
where
condExpression = do
selectedExpression <- try $ do
trm <- token terminal
lookups <- optional indexLookupChain
symbolic '?'
return $ maybe trm ($ trm) lookups
let cas = do
c <- (SelectorDefault <$ symbol "default") -- default case
<|> fmap SelectorType (try datatype)
<|> fmap SelectorValue
( fmap UVariableReference variableReference
<|> fmap UBoolean puppetBool
<|> (UUndef <$ symbol "undef")
<|> literalValue
<|> fmap UInterpolable interpolableString
<|> (URegexp <$> termRegexp)
)
void $ symbol "=>"
e <- expression
return (c :!: e)
cases <- braces (sepComma1 cas)
return (ConditionalValue selectedExpression (V.fromList cases))
variable :: Parser Expression
variable = Terminal . UVariableReference <$> variableReference
stringLiteral' :: Parser Text
stringLiteral' = char '\'' *> interior <* symbolic '\''
where
interior = Text.pack . concat <$> many (some (noneOf ['\'', '\\']) <|> (char '\\' *> fmap escape anyChar))
escape '\'' = "'"
escape x = ['\\',x]
identifier :: Parser String
identifier = some (satisfy identifierPart)
identifierPart :: Char -> Bool
identifierPart x = Char.isAsciiLower x || Char.isAsciiUpper x || Char.isDigit x || (x == '_')
identl :: Parser Char -> Parser Char -> Parser Text
identl fstl nxtl = do
f <- fstl
nxt <- token $ many nxtl
return $ Text.pack $ f : nxt
operator :: Text -> Parser ()
operator = void . try . symbol
reserved :: Text -> Parser ()
reserved s =
try $ do
void (string s)
notFollowedBy (satisfy identifierPart)
someSpace
variableName :: Parser Text
variableName = do
let acceptablePart = Text.pack <$> many (satisfy identifierAcceptable)
identifierAcceptable x = Char.isAsciiLower x || Char.isAsciiUpper x || Char.isDigit x || (x == '_')
out <- qualif acceptablePart
when (out == "string") (panic "The special variable $string should never be used")
return out
qualif :: Parser Text -> Parser Text
qualif p = token $ do
header <- option "" (string "::")
( header <> ) . Text.intercalate "::" <$> p `sepBy1` string "::"
qualif1 :: Parser Text -> Parser Text
qualif1 p = try $ do
r <- qualif p
unless ("::" `Text.isInfixOf` r) (fail "This parser is not qualified")
return r
className :: Parser Text
className = qualif moduleName
-- yay with reserved words
typeName :: Parser Text
typeName = className
moduleName :: Parser Text
moduleName = genericModuleName False
resourceNameRef :: Parser Text
resourceNameRef = qualif (genericModuleName True)
genericModuleName :: Bool -> Parser Text
genericModuleName isReference = do
let acceptable x = Char.isAsciiLower x || Char.isDigit x || (x == '_')
firstletter = if isReference
then fmap Char.toLower (satisfy Char.isAsciiUpper)
else satisfy Char.isAsciiLower
identl firstletter (satisfy acceptable)
parameterName :: Parser Text
parameterName = moduleName
variableReference :: Parser Text
variableReference = char '$' *> variableName
interpolableString :: Parser (Vector Expression)
interpolableString = V.fromList <$> between (char '"') (symbolic '"')
( many (interpolableVariableReference <|> doubleQuotedStringContent <|> fmap (Terminal . UString . Text.singleton) (char '$')) )
where
doubleQuotedStringContent = Terminal . UString . Text.pack . concat <$>
some ((char '\\' *> fmap escaper anyChar) <|> some (noneOf [ '"', '\\', '$' ]))
escaper :: Char -> String
escaper 'n' = "\n"
escaper 't' = "\t"
escaper 'r' = "\r"
escaper '"' = "\""
escaper '\\' = "\\"
escaper '$' = "$"
escaper x = ['\\',x]
-- this is specialized because we can't be "tokenized" here
variableAccept x = Char.isAsciiLower x || Char.isAsciiUpper x || Char.isDigit x || x == '_'
rvariableName = do
v <- Text.concat <$> some (string "::" <|> fmap Text.pack (some (satisfy variableAccept)))
when (v == "string") (fail "The special variable $string must not be used")
return v
rvariable = Terminal . UVariableReference <$> rvariableName
simpleIndexing = Lookup <$> rvariable <*> between (symbolic '[') (symbolic ']') expression
interpolableVariableReference = do
void (char '$')
let fenced = try (simpleIndexing <* char '}')
<|> try (rvariable <* char '}')
<|> (expression <* char '}')
(symbolic '{' *> fenced) <|> try rvariable <|> pure (Terminal (UString (Text.singleton '$')))
regexp :: Parser Text
regexp = do
void (char '/')
Text.pack . concat <$> many ( do { void (char '\\') ; x <- anyChar; return ['\\', x] } <|> some (noneOf [ '/', '\\' ]) )
<* symbolic '/'
puppetArray :: Parser UnresolvedValue
puppetArray = fmap (UArray . V.fromList) (brackets (sepComma expression)) <?> "Array"
puppetHash :: Parser UnresolvedValue
puppetHash = fmap (UHash . V.fromList) (braces (sepComma hashPart)) <?> "Hash"
where
hashPart = (:!:) <$> (expression <* operator "=>")
<*> expression
puppetBool :: Parser Bool
puppetBool = (reserved "true" >> return True)
<|> (reserved "false" >> return False)
<?> "Boolean"
resourceReferenceRaw :: Parser (Text, [Expression])
resourceReferenceRaw = do
restype <- resourceNameRef <?> "Resource reference type"
resnames <- brackets (expression `sepBy1` comma) <?> "Resource reference values"
return (restype, resnames)
resourceReference :: Parser UnresolvedValue
resourceReference = do
(restype, resnames) <- resourceReferenceRaw
return $ UResourceReference restype $ case resnames of
[x] -> x
_ -> Terminal $ UArray (V.fromList resnames)
bareword :: Parser Text
bareword = identl (satisfy Char.isAsciiLower) (satisfy acceptable) <?> "Bare word"
where
acceptable x = Char.isAsciiLower x || Char.isAsciiUpper x || Char.isDigit x || (x == '_') || (x == '-')
-- The first argument defines if non-parenthesized arguments are acceptable
genFunctionCall :: Bool -> Parser (Text, Vector Expression)
genFunctionCall nonparens = do
fname <- moduleName <?> "Function name"
-- this is a hack. Contrary to what the documentation says,
-- a "bareword" can perfectly be a qualified name :
-- 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"
withparens = parens (argsc sepEndBy expression)
withoutparens = argsc sepEndBy1 expressionF
args <- withparens <|> if nonparens
then withoutparens <?> "Function arguments B"
else fail "Function arguments C"
return (fname, V.fromList args)
literalValue :: Parser UnresolvedValue
literalValue = token (fmap UString stringLiteral' <|> fmap UString bareword <|> fmap UNumber numericalvalue <?> "Literal Value")
where
numericalvalue = integerOrDouble >>= \i -> case i of
Left x -> return (fromIntegral x)
Right y -> return (Scientific.fromFloatDigits y)
-- this is a hack for functions :(
terminalG :: Parser Expression -> Parser Expression
terminalG g = parens expression
<|> fmap (Terminal . UInterpolable) interpolableString
<|> (reserved "undef" *> return (Terminal UUndef))
<|> fmap (Terminal . URegexp) termRegexp
<|> variable
<|> fmap Terminal puppetArray
<|> fmap Terminal puppetHash
<|> fmap (Terminal . UBoolean) puppetBool
<|> fmap (Terminal . UDataType) datatype
<|> fmap Terminal resourceReference
<|> g
<|> fmap Terminal literalValue
compileRegexp :: Text -> Parser CompRegex
compileRegexp p = case Regex.compile' Regex.compBlank Regex.execBlank (encodeUtf8 p) of
Right r -> return $ CompRegex p r
Left ms -> fail ("Can't parse regexp /" ++ Text.unpack p ++ "/ : " ++ show ms)
termRegexp :: Parser CompRegex
termRegexp = regexp >>= compileRegexp
terminal :: Parser Expression
terminal = terminalG (fmap Terminal (fmap UHOLambdaCall (try lambdaCall) <|> try funcCall))
where
funcCall :: Parser UnresolvedValue
funcCall = do
(fname, args) <- genFunctionCall False
return $ UFunctionCall fname args
expressionTable :: [[Operator Parser Expression]]
expressionTable = [ [ Postfix indexLookupChain ] -- http://stackoverflow.com/questions/10475337/parsec-expr-repeated-prefix-postfix-operator-not-supported
, [ Prefix ( operator "-" >> return Negate ) ]
, [ Prefix ( operator "!" >> return Not ) ]
, [ InfixL ( operator "." >> return FunctionApplication ) ]
, [ InfixL ( reserved "in" >> return Contains ) ]
, [ InfixL ( operator "/" >> return Division )
, InfixL ( operator "*" >> return Multiplication )
]
, [ InfixL ( operator "+" >> return Addition )
, InfixL ( operator "-" >> return Substraction )
]
, [ InfixL ( operator "<<" >> return LeftShift )
, InfixL ( operator ">>" >> return RightShift )
]
, [ InfixL ( operator "==" >> return Equal )
, InfixL ( operator "!=" >> return Different )
]
, [ InfixL ( operator "=~" >> return RegexMatch )
, InfixL ( operator "!~" >> return NotRegexMatch )
]
, [ InfixL ( operator ">=" >> return MoreEqualThan )
, InfixL ( operator "<=" >> return LessEqualThan )
, InfixL ( operator ">" >> return MoreThan )
, InfixL ( operator "<" >> return LessThan )
]
, [ InfixL ( reserved "and" >> return And )
, InfixL ( reserved "or" >> return Or )
]
]
indexLookupChain :: Parser (Expression -> Expression)
indexLookupChain = List.foldr1 (flip (.)) <$> some checkLookup
where
checkLookup = flip Lookup <$> between (operator "[") (operator "]") expression
stringExpression :: Parser Expression
stringExpression = fmap (Terminal . UInterpolable) interpolableString <|> (reserved "undef" *> return (Terminal UUndef)) <|> fmap (Terminal . UBoolean) puppetBool <|> variable <|> fmap Terminal literalValue
varAssign :: Parser VarAssignDecl
varAssign = do
p <- getPosition
mt <- optional datatype
v <- variableReference
void $ symbolic '='
e <- expression
when (Text.all Char.isDigit v) (fail "Can't assign fully numeric variables")
pe <- getPosition
return (VarAssignDecl mt v e (p :!: pe))
nodeDecl :: Parser [NodeDecl]
nodeDecl = do
p <- getPosition
reserved "node"
let toString (UString s) = s
toString (UNumber n) = scientific2text n
toString _ = panic "Can't happen at nodeDecl"
nodename = (reserved "default" >> return NodeDefault) <|> fmap (NodeName . toString) literalValue
ns <- (fmap NodeMatch termRegexp <|> nodename) `sepBy1` comma
inheritance <- option S.Nothing (fmap S.Just (reserved "inherits" *> nodename))
st <- braces statementList
pe <- getPosition
return [NodeDecl n st inheritance (p :!: pe) | n <- ns]
defineDecl :: Parser DefineDecl
defineDecl = do
p <- getPosition
reserved "define"
name <- typeName
-- TODO check native type
params <- option V.empty puppetClassParameters
st <- braces statementList
pe <- getPosition
return (DefineDecl name params st (p :!: pe))
puppetClassParameters :: Parser (Vector (Pair (Pair Text (S.Maybe UDataType)) (S.Maybe Expression)))
puppetClassParameters = V.fromList <$> parens (sepComma var)
where
toStrictMaybe (Just x) = S.Just x
toStrictMaybe Nothing = S.Nothing
var :: Parser (Pair (Pair Text (S.Maybe UDataType)) (S.Maybe Expression))
var = do
tp <- toStrictMaybe <$> optional datatype
n <- variableReference
df <- toStrictMaybe <$> optional (symbolic '=' *> expression)
return (n :!: tp :!: df)
puppetIfStyleCondition :: Parser (Pair Expression (Vector Statement))
puppetIfStyleCondition = (:!:) <$> expression <*> braces statementList
unlessCondition :: Parser ConditionalDecl
unlessCondition = do
p <- getPosition
reserved "unless"
(cond :!: stmts) <- puppetIfStyleCondition
pe <- getPosition
return (ConditionalDecl (V.singleton (Not cond :!: stmts)) (p :!: pe))
ifCondition :: Parser ConditionalDecl
ifCondition = do
p <- getPosition
reserved "if"
maincond <- puppetIfStyleCondition
others <- many (reserved "elsif" *> puppetIfStyleCondition)
elsecond <- option V.empty (reserved "else" *> braces statementList)
let ec = if V.null elsecond
then []
else [Terminal (UBoolean True) :!: elsecond]
pe <- getPosition
return (ConditionalDecl (V.fromList (maincond : others ++ ec)) (p :!: pe))
caseCondition :: Parser ConditionalDecl
caseCondition = do
let puppetRegexpCase = Terminal . URegexp <$> termRegexp
defaultCase = Terminal (UBoolean True) <$ try (reserved "default")
matchesToExpression e (x, stmts) = f x :!: stmts
where f = case x of
(Terminal (UBoolean _)) -> identity
(Terminal (URegexp _)) -> RegexMatch e
_ -> Equal e
cases = do
matches <- (puppetRegexpCase <|> defaultCase <|> expression) `sepBy1` comma
void $ symbolic ':'
stmts <- braces statementList
return $ map (,stmts) matches
p <- getPosition
reserved "case"
expr1 <- expression
condlist <- concat <$> braces (some cases)
pe <- getPosition
return (ConditionalDecl (V.fromList (map (matchesToExpression expr1) condlist)) (p :!: pe) )
data OperatorChain a = OperatorChain a LinkType (OperatorChain a)
| EndOfChain a
instance Foldable OperatorChain where
foldMap f (EndOfChain x) = f x
foldMap f (OperatorChain a _ nx) = f a <> foldMap f nx
operatorChainStatement :: OperatorChain a -> a
operatorChainStatement (OperatorChain a _ _) = a
operatorChainStatement (EndOfChain x) = x
zipChain :: OperatorChain a -> [ ( a, a, LinkType ) ]
zipChain (OperatorChain a d nx) = (a, operatorChainStatement nx, d) : zipChain nx
zipChain (EndOfChain _) = []
depOperator :: Parser LinkType
depOperator = (operator "->" *> pure RBefore)
<|> (operator "~>" *> pure RNotify)
assignment :: Parser AttributeDecl
assignment = AttributeDecl <$> key <*> arrowOp <*> expression
where
key = identl (satisfy Char.isAsciiLower) (satisfy acceptable) <?> "Assignment key"
acceptable x = Char.isAsciiLower x || Char.isAsciiUpper x || Char.isDigit x || (x == '_') || (x == '-')
arrowOp =
(symbol "=>" *> pure AssignArrow)
<|> (symbol "+>" *> pure AppendArrow)
searchExpression :: Parser SearchExpression
searchExpression = makeExprParser (token searchterm) searchTable
where
searchTable :: [[Operator Parser SearchExpression]]
searchTable = [ [ InfixL ( reserved "and" >> return AndSearch )
, InfixL ( reserved "or" >> return OrSearch )
] ]
searchterm = parens searchExpression <|> check
check = do
attrib <- parameterName
opr <- (operator "==" *> return EqualitySearch) <|> (operator "!=" *> return NonEqualitySearch)
term <- stringExpression
return (opr attrib term)
resCollDecl :: Position -> Text -> Parser ResCollDecl
resCollDecl p restype = do
openchev <- some (char '<')
when (length openchev > 2) (fail "Too many brackets")
void $ symbolic '|'
e <- option AlwaysTrue searchExpression
void (char '|')
void (count (length openchev) (char '>'))
someSpace
overrides <- option [] $ braces (sepComma assignment)
let collectortype = if length openchev == 1
then Collector
else ExportedCollector
pe <- getPosition
return (ResCollDecl collectortype restype e (V.fromList overrides) (p :!: pe) )
classDecl :: Parser ClassDecl
classDecl = do
p <- getPosition
reserved "class"
ClassDecl <$> className
<*> option V.empty puppetClassParameters
<*> option S.Nothing (fmap S.Just (reserved "inherits" *> className))
<*> braces statementList
<*> ( (p :!:) <$> getPosition )
mainFuncDecl :: Parser MainFuncDecl
mainFuncDecl = do
p <- getPosition
(fname, args) <- genFunctionCall True
pe <- getPosition
return (MainFuncDecl fname args (p :!: pe))
hoLambdaDecl :: Parser HigherOrderLambdaDecl
hoLambdaDecl = do
p <- getPosition
fc <- try lambdaCall
pe <- getPosition
return (HigherOrderLambdaDecl fc (p :!: pe))
dotLambdaDecl :: Parser HigherOrderLambdaDecl
dotLambdaDecl = do
p <- getPosition
ex <- expression
pe <- getPosition
hf <- case ex of
FunctionApplication e (Terminal (UHOLambdaCall hf)) -> do
unless (S.isNothing (hf ^. hoLambdaExpr)) (fail "Can't call a function with . and ()")
return (hf & hoLambdaExpr .~ S.Just e)
Terminal (UHOLambdaCall hf) -> do
when (S.isNothing (hf ^. hoLambdaExpr)) (fail "This function needs data to operate on")
return hf
_ -> fail "A method chained by dots."
unless (hf ^. hoLambdaFunc == LambEach) (fail "Expected 'each', the other types of method calls are not supported by language-puppet at the statement level.")
return (HigherOrderLambdaDecl hf (p :!: pe))
resDefaultDecl :: Parser ResDefaultDecl
resDefaultDecl = do
p <- getPosition
rnd <- resourceNameRef
let assignmentList = V.fromList <$> sepComma1 assignment
asl <- braces assignmentList
pe <- getPosition
return (ResDefaultDecl rnd asl (p :!: pe))
resOverrideDecl :: Parser [ResOverrideDecl]
resOverrideDecl = do
p <- getPosition
restype <- resourceNameRef
names <- brackets (expression `sepBy1` comma) <?> "Resource reference values"
assignments <- V.fromList <$> braces (sepComma assignment)
pe <- getPosition
return [ ResOverrideDecl restype n assignments (p :!: pe) | n <- names ]
-- | Heterogeneous chain (interleaving resource declarations with
-- resource references) needs to be supported:
--
-- class { 'docker::service': } ->
-- Class['docker']
chainableResources :: Parser [Statement]
chainableResources = do
let withresname = do
p <- getPosition
restype <- resourceNameRef
lookAhead anyChar >>= \x -> case x of
'[' -> do
resnames <- brackets (expression `sepBy1` comma)
pe <- getPosition
pure (ChainResRefr restype resnames (p :!: pe))
_ -> ChainResColl <$> resCollDecl p restype
chain <- parseRelationships $ pure <$> try withresname <|> map ChainResDecl <$> resDeclGroup
let relations = do
(g1, g2, lt) <- zipChain chain
(rt1, rn1, _ :!: pe1) <- concatMap extractResRef g1
(rt2, rn2, ps2 :!: _ ) <- concatMap extractResRef g2
return (DepDecl (rt1 :!: rn1) (rt2 :!: rn2) lt (pe1 :!: ps2))
return $ map DependencyDeclaration relations <> (chain ^.. folded . folded . to extractChainStatement . folded)
where
extractResRef :: ChainableRes -> [(Text, Expression, PPosition)]
extractResRef (ChainResColl _) = []
extractResRef (ChainResDecl (ResDecl rt rn _ _ pp)) = [(rt,rn,pp)]
extractResRef (ChainResRefr rt rns pp) = [(rt,rn,pp) | rn <- rns]
extractChainStatement :: ChainableRes -> [Statement]
extractChainStatement (ChainResColl r) = [ResourceCollectionDeclaration r]
extractChainStatement (ChainResDecl d) = [ResourceDeclaration d]
extractChainStatement ChainResRefr{} = []
parseRelationships :: Parser a -> Parser (OperatorChain a)
parseRelationships p = do
g <- p
o <- optional depOperator
case o of
Just o' -> OperatorChain g o' <$> parseRelationships p
Nothing -> pure (EndOfChain g)
resDeclGroup :: Parser [ResDecl]
resDeclGroup = do
let resourceName = expression
resourceDeclaration = do
p <- getPosition
names <- brackets (sepComma1 resourceName) <|> fmap return resourceName
void $ symbolic ':'
vals <- fmap V.fromList (sepComma assignment)
pe <- getPosition
return [(n, vals, p :!: pe) | n <- names ]
groupDeclaration = (,) <$> many (char '@') <*> typeName <* symbolic '{'
(virts, rtype) <- try groupDeclaration -- for matching reasons, this gets a try until the opening brace
let sep = symbolic ';' <|> comma
x <- resourceDeclaration `sepEndBy1` sep
void $ symbolic '}'
virtuality <- case virts of
"" -> return Normal
"@" -> return Virtual
"@@" -> return Exported
_ -> fail "Invalid virtuality"
return [ ResDecl rtype rname conts virtuality pos | (rname, conts, pos) <- concat x ]
statement :: Parser [Statement]
statement =
(pure . HigherOrderLambdaDeclaration <$> try dotLambdaDecl)
<|> (pure . VarAssignmentDeclaration <$> varAssign)
<|> (map NodeDeclaration <$> nodeDecl)
<|> (pure . DefineDeclaration <$> defineDecl)
<|> (pure . ConditionalDeclaration <$> unlessCondition)
<|> (pure . ConditionalDeclaration <$> ifCondition)
<|> (pure . ConditionalDeclaration <$> caseCondition)
<|> (pure . ResourceDefaultDeclaration <$> try resDefaultDecl)
<|> (map ResourceOverrideDeclaration <$> try resOverrideDecl)
<|> chainableResources
<|> (pure . ClassDeclaration <$> classDecl)
<|> (pure . HigherOrderLambdaDeclaration <$> hoLambdaDecl)
<|> (pure . MainFunctionDeclaration <$> mainFuncDecl)
<?> "Statement"
datatype :: Parser UDataType
datatype = dtString
<|> dtInteger
<|> dtFloat
<|> dtNumeric
<|> (UDTBoolean <$ reserved "Boolean")
<|> (UDTScalar <$ reserved "Scalar")
<|> (UDTData <$ reserved "Data")
<|> (UDTAny <$ reserved "Any")
<|> (UDTCollection <$ reserved "Collection")
<|> dtArray
<|> dtHash
<|> (UDTUndef <$ reserved "Undef")
<|> (reserved "Optional" *> (UDTOptional <$> brackets datatype))
<|> (UNotUndef <$ reserved "NotUndef")
<|> (reserved "Variant" *> (UDTVariant . NE.fromList <$> brackets (datatype `sepBy1` symbolic ',')))
-- while all the other cases are straightforward, it seems that the
-- following syntax is a valid regexp for puppet:
-- '^dqsqsdqs$'
-- instead of:
-- /^dqsqsdqs$/
--
-- That is the reason there is a "quotedRegexp" case
<|> (reserved "Pattern" *> (UDTPattern . NE.fromList <$> brackets ( (termRegexp <|> quotedRegexp) `sepBy1` symbolic ',')))
<|> (reserved "Enum" *> (UDTEnum . NE.fromList <$> brackets (expression `sepBy1` symbolic ',')))
<|> dtExternal
<?> "UDataType"
where
quotedRegexp = stringLiteral' >>= compileRegexp
integer = integerOrDouble >>= either (return . fromIntegral) (\d -> fail ("Integer value expected, instead of " ++ show d))
float = either fromIntegral identity <$> 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 `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 " ++ Text.unpack s)
dtString = dtbounded "String" UDTString integer
dtInteger = dtbounded "Integer" UDTInteger integer
dtFloat = dtbounded "Float" UDTFloat float
dtNumeric = dtbounded "Numeric" (\ma mb -> UDTVariant (UDTFloat ma mb :| [UDTInteger (truncate <$> ma) (truncate <$> mb)])) float
dtArray = do
reserved "Array"
ml <- optional $ brackets $ do
tp <- datatype
rst <- optional (symbolic ',' *> integer `sepBy1` symbolic ',')
return (tp, rst)
case ml of
Nothing -> return (UDTArray UDTData 0 Nothing)
Just (t, Nothing) -> return (UDTArray t 0 Nothing)
Just (t, Just [mi]) -> return (UDTArray t mi Nothing)
Just (t, Just [mi, mx]) -> return (UDTArray t mi (Just mx))
Just (_, Just _) -> fail "Too many arguments to datatype Array"
dtHash = do
reserved "Hash"
ml <- optional $ brackets $ do
tk <- datatype
symbolic ','
tv <- datatype
rst <- optional (symbolic ',' *> integer `sepBy1` symbolic ',')
return (tk, tv, rst)
case ml of
Nothing -> return (UDTHash UDTScalar UDTData 0 Nothing)
Just (tk, tv, Nothing) -> return (UDTHash tk tv 0 Nothing)
Just (tk, tv, Just [mi]) -> return (UDTHash tk tv mi Nothing)
Just (tk, tv, Just [mi, mx]) -> return (UDTHash tk tv mi (Just mx))
Just (_, _, Just _) -> fail "Too many arguments to datatype Hash"
dtExternal =
reserved "Stdlib::HTTPUrl" $> UDTData
<|> reserved "Stdlib::Absolutepath" $> UDTData
<|> reserved "Stdlib::Unixpath" $> UDTData
<|> reserved "Nginx::ErrorLogSeverity" $> UDTData
statementList :: Parser (Vector Statement)
statementList = (V.fromList . concat) <$> many statement
lambdaCall :: Parser HOLambdaCall
lambdaCall = do
let tostrict (Just x) = S.Just x
tostrict Nothing = S.Nothing
HOLambdaCall <$> lambFunc
<*> fmap (tostrict . join) (optional (parens (optional expression)))
<*> lambParams
<*> (symbolic '{' *> fmap (V.fromList . concat) (many (try statement)))
<*> fmap tostrict (optional expression) <* symbolic '}'
where
lambFunc :: Parser LambdaFunc
lambFunc = (reserved "each" *> pure LambEach)
<|> (reserved "map" *> pure LambMap )
<|> (reserved "reduce" *> pure LambReduce)
<|> (reserved "filter" *> pure LambFilter)
<|> (reserved "slice" *> pure LambSlice)
<|> (reserved "lookup" *> pure LambLookup)
lambParams :: Parser LambdaParameters
lambParams = between (symbolic '|') (symbolic '|') hp
where
acceptablePart = Text.pack <$> identifier
lambdaParameter :: Parser LambdaParameter
lambdaParameter = LParam <$> optional datatype <*> (char '$' *> acceptablePart)
hp = do
vars <- lambdaParameter `sepBy1` comma
case vars of
[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"