{-# LANGUAGE TupleSections #-}
{-| Parse puppet source code from text. -}
module Puppet.Parser (
-- * Runner
runPParser
-- * Parsers
, puppetParser
, expression
) where
import Control.Applicative
import Control.Lens hiding (noneOf)
import Control.Monad
import Data.Char
import qualified Data.Foldable as F
import qualified Data.Maybe.Strict as S
import Data.Scientific
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Tuple.Strict hiding (fst,zip)
import qualified Data.Vector as V
import Text.Megaparsec hiding (token)
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
-- | Run a puppet parser against some 'T.Text' input.
runPParser :: String -> T.Text -> Either ParseError (V.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 Right (try (L.signed someSpace L.float)) <|> fmap Left (hex <|> dec)
where
dec = L.signed someSpace L.integer
hex = try (string "0x") *> L.hexadecimal
symbol :: String -> Parser ()
symbol = void . try . L.symbol someSpace
symbolic :: Char -> Parser ()
symbolic = symbol . pure
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 (V.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 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 T.Text
stringLiteral' = char '\'' *> interior <* symbolic '\''
where
interior = T.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 = isAsciiLower x || isAsciiUpper x || isDigit x || (x == '_')
identl :: Parser Char -> Parser Char -> Parser T.Text
identl fstl nxtl = do
f <- fstl
nxt <- token $ many nxtl
return $ T.pack $ f : nxt
operator :: String -> Parser ()
operator = void . try . symbol
reserved :: String -> Parser ()
reserved s = try $ do
void (string s)
notFollowedBy (satisfy identifierPart)
someSpace
variableName :: Parser T.Text
variableName = do
let acceptablePart = T.pack <$> many (satisfy identifierAcceptable)
identifierAcceptable x = isAsciiLower x || isAsciiUpper x || isDigit x || (x == '_')
out <- qualif acceptablePart
when (out == "string") (fail "The special variable $string should never be used")
return out
qualif :: Parser T.Text -> Parser T.Text
qualif p = token $ do
header <- T.pack <$> option "" (try (string "::"))
( header <> ) . T.intercalate "::" <$> p `sepBy1` try (string "::")
qualif1 :: Parser T.Text -> Parser T.Text
qualif1 p = try $ do
r <- qualif p
unless ("::" `T.isInfixOf` r) (fail "This parser is not qualified")
return r
className :: Parser T.Text
className = qualif moduleName
-- yay with reserved words
typeName :: Parser T.Text
typeName = className
moduleName :: Parser T.Text
moduleName = genericModuleName False
resourceNameRef :: Parser T.Text
resourceNameRef = qualif (genericModuleName True)
genericModuleName :: Bool -> Parser T.Text
genericModuleName isReference = do
let acceptable x = isAsciiLower x || isDigit x || (x == '_')
firstletter = if isReference
then fmap toLower (satisfy isAsciiUpper)
else satisfy isAsciiLower
identl firstletter (satisfy acceptable)
parameterName :: Parser T.Text
parameterName = moduleName
variableReference :: Parser T.Text
variableReference = char '$' *> variableName
interpolableString :: Parser (V.Vector Expression)
interpolableString = V.fromList <$> between (char '"') (symbolic '"')
( many (interpolableVariableReference <|> doubleQuotedStringContent <|> fmap (Terminal . UString . T.singleton) (char '$')) )
where
doubleQuotedStringContent = Terminal . UString . T.pack . concat <$>
some ((char '\\' *> fmap stringEscape anyChar) <|> some (noneOf "\"\\$"))
stringEscape :: Char -> String
stringEscape 'n' = "\n"
stringEscape 't' = "\t"
stringEscape 'r' = "\r"
stringEscape '"' = "\""
stringEscape '\\' = "\\"
stringEscape '$' = "$"
stringEscape x = ['\\',x]
-- 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))
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 = try $ do
void (char '$')
lookAhead anyChar >>= \c -> case c of
'{' -> between (symbolic '{') (char '}') ( try simpleIndexing
<|> rvariable
)
-- This is not as robust as the "qualif"
-- implementation, but considerably shorter.
--
-- This needs refactoring.
_ -> rvariable
regexp :: Parser T.Text
regexp = do
void (char '/')
T.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 (T.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 T.Text
bareword = identl (satisfy isAsciiLower) (satisfy acceptable) <?> "Bare word"
where
acceptable x = isAsciiLower x || isAsciiUpper x || isDigit x || (x == '_') || (x == '-')
-- The first argument defines if non-parenthesized arguments are acceptable
genFunctionCall :: Bool -> Parser (T.Text, V.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 (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 resourceReference
<|> g
<|> fmap Terminal literalValue
compileRegexp :: T.Text -> Parser CompRegex
compileRegexp p = case compile' compBlank execBlank (T.encodeUtf8 p) of
Right r -> return $ CompRegex p r
Left ms -> fail ("Can't parse regexp /" ++ T.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 = chainl1 checkLookup (return (flip (.)))
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
v <- variableReference
void $ symbolic '='
e <- expression
when (T.all isDigit v) (fail "Can't assign fully numeric variables")
pe <- getPosition
return (VarAssignDecl v e (p :!: pe))
nodeDecl :: Parser [NodeDecl]
nodeDecl = do
p <- getPosition
reserved "node"
let toString (UString s) = s
toString (UNumber n) = scientific2text n
toString _ = error "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 (V.Vector (Pair T.Text (S.Maybe Expression)))
puppetClassParameters = V.fromList <$> parens (sepComma var)
where
toStrictMaybe (Just x) = S.Just x
toStrictMaybe Nothing = S.Nothing
var :: Parser (Pair T.Text (S.Maybe Expression))
var = (:!:)
<$> variableReference
<*> (toStrictMaybe <$> optional (symbolic '=' *> expression))
puppetIfStyleCondition :: Parser (Pair Expression (V.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 = do
reg <- termRegexp
void $ symbolic ':'
stmts <- braces statementList
return [ (Terminal (URegexp reg), stmts) ]
defaultCase = do
try (reserved "default")
void $ symbolic ':'
stmts <- braces statementList
return [ (Terminal (UBoolean True), stmts) ]
puppetCase = do
compares <- expression `sepBy1` comma
void $ symbolic ':'
stmts <- braces statementList
return $ map (,stmts) compares
condsToExpression e (x, stmts) = f x :!: stmts
where f = case x of
(Terminal (UBoolean _))-> id
(Terminal (URegexp _)) -> RegexMatch e
_ -> Equal e
p <- getPosition
reserved "case"
expr1 <- expression
condlist <- braces (some (puppetRegexpCase <|> defaultCase <|> puppetCase))
pe <- getPosition
return (ConditionalDecl (V.fromList (map (condsToExpression expr1) (concat condlist))) (p :!: pe) )
data OperatorChain a = OperatorChain a LinkType (OperatorChain a)
| EndOfChain a
instance F.Foldable OperatorChain where
foldMap f (EndOfChain x) = f x
foldMap f (OperatorChain a _ nx) = f a <> F.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 isAsciiLower) (satisfy acceptable) <?> "Assignment key"
acceptable x = isAsciiLower x || isAsciiUpper x || 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 -> T.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 -> [(T.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 = token stringExpression
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"
statementList :: Parser (V.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)
lambParams :: Parser LambdaParameters
lambParams = between (symbolic '|') (symbolic '|') hp
where
acceptablePart = T.pack <$> identifier
hp = do
vars <- (char '$' *> acceptablePart) `sepBy1` comma
case vars of
[a] -> return (BPSingle a)
[a,b] -> return (BPPair a b)
_ -> fail "Invalid number of variables between the pipes"