module Text.Liquid.Parser where
import Prelude hiding (and, null, or, takeWhile)
import Control.Applicative
import Control.Lens (Prism', prism')
import Data.Attoparsec.Combinator (lookAhead)
import Data.Attoparsec.Text
import Data.Char (isAlpha)
import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
import Data.Scientific (toBoundedInteger)
import Data.Semigroup hiding (option)
import Data.Text (Text)
import qualified Data.Text as T
import Text.Liquid.Helpers
import Text.Liquid.Tokens
import Text.Liquid.Types
between
:: Parser b
-> Parser b
-> Parser a
-> Parser a
between open close p = do
_ <- open
x <- p
(close *> return x) <|> fail "Tag or output statement incomplete"
stripped
:: Parser a
-> Parser a
stripped =
between skipSpace skipSpace
tag
:: Parser a
-> Parser a
tag p =
between tagStart tagEnd (stripped p)
outputTag
:: Parser a
-> Parser a
outputTag p =
between outputStart outputEnd (stripped p)
tagWith
:: Parser a
-> Parser b
-> Parser b
tagWith tg p =
tag $ tg *> skipSpace >> p
mapT
:: Parser [Char]
-> Parser Text
mapT =
fmap T.pack
var :: Parser Text
var = mapT $ many1 $ letter <|> satisfy (inClass "_-")
parseBoxedInt :: Parser Int
parseBoxedInt = do
sc <- between oBr cBr scientific
case toBoundedInteger sc of
Just i -> if i >= 0 then return i else err
Nothing -> err
where err = fail "invalid variable (array) index, expecting a positive integer"
varIndexSection :: Parser (NonEmpty VarIndex)
varIndexSection = do
vs <- sepBy var dot
i <- many parseBoxedInt
brokenChar <- oBr <|> return '~'
let ixs = do obs <- (nonEmpty (ObjectIndex <$> vs))
Just obs <> (nonEmpty (ArrayIndex <$> i))
if brokenChar == '[' then (fail "invalid array index - ill-typed") else case ixs of
Just nel -> return nel
Nothing -> fail "invalid var index section"
variable :: Parser Expr
variable = do
sections <- sepBy1 varIndexSection dot
return . Variable $ foldl1 (<>) sections
rawBodyTag :: Parser Text
-> Parser Text
-> Parser Text
rawBodyTag s e =
s >> skipSpace *> (mapT $ manyTill anyChar (skipSpace >> e))
rawTag :: Parser Expr
rawTag = RawText <$> rawBodyTag (tag rawStart) (tag rawEnd)
commentTag :: Parser Expr
commentTag = rawBodyTag (tag commentStart) (tag commentEnd) *> pure Noop
textPart :: Parser Expr
textPart = RawText <$> (mapT $ manyTill1 (satisfy $ notInClass "{%") terminator)
where terminator = lookAhead $ tagStart <|> outputStart <|> (endOfInput *> pure T.empty)
manyTill1 :: Alternative f => f a -> f b -> f [a]
manyTill1 p e = (:) <$> p <*> s
where s = (e *> pure []) <|> ((:) <$> p <*> s)
ordOperator :: Parser (Expr -> Expr -> Expr)
ordOperator =
stripped $ eq *> pure Equal <|>
neq *> pure NotEqual <|>
gtEq *> pure GtEqual <|>
ltEq *> pure LtEqual <|>
(mapT . some $ gt) *> pure Gt <|>
(mapT . some $ lt) *> pure Lt <|>
contains *> pure Contains
ordCombinator :: Parser (Expr -> Expr -> Expr)
ordCombinator =
stripped $ or *> pure Or <|>
and *> pure And
quoteString :: Parser Expr
quoteString = do
skipSpace
beginTick <- satisfy (inClass "\'\"")
qs <- mapT $ manyTill anyChar (char beginTick)
return $ QuoteString qs
binaryPredicate :: Parser Expr
binaryPredicate = do
lhs <- quoteString <|>
(Num <$> scientific) <|>
Null <$ (stripped null) <|>
Nil <$ (stripped nil) <|>
Falseth <$ (stripped false) <|>
Trueth <$ (stripped true) <|>
variable
op <- ordOperator
rhs <- quoteString <|>
(Num <$> scientific) <|>
Null <$ (stripped null) <|>
Nil <$ (stripped nil) <|>
Falseth <$ (stripped false) <|>
Trueth <$ (stripped true) <|>
variable
return $ op lhs rhs
truthy :: Parser Expr
truthy =
Null <$ (stripped null) <|>
Nil <$ (stripped nil) <|>
Falseth <$ (stripped false) <|>
Trueth <$ (stripped true) <|>
(Truthy . Num <$> stripped scientific) <|>
(Truthy <$> stripped quoteString) <|>
(Truthy <$> stripped variable)
predicate :: Parser Expr
predicate = do
bpl <- stripped binaryPredicate
oc <- ordCombinator
bpr <- stripped binaryPredicate
return $ oc bpl bpr
predicateClause :: Parser Expr
predicateClause =
predicate <|> binaryPredicate <|> truthy
ifClause :: Parser Expr
ifClause = IfClause <$> tagWith ifStart predicateClause
ifKeyClause :: Parser Expr
ifKeyClause = IfKeyClause <$> tagWith ifKeyStart variableOnly
where variableOnly = do res <- eitherP precheck variable
case res of
Left _ -> fail "Only variables as ifkey args allowed"
Right ok -> return ok
precheck = Null <$ (stripped null) <|>
Nil <$ (stripped nil) <|>
Falseth <$ (stripped false) <|>
Trueth <$ (stripped true) <|>
(Truthy . Num <$> stripped scientific) <|>
(Truthy <$> stripped quoteString)
elsifClause :: Parser Expr
elsifClause = ElsIfClause <$> tagWith elsIf predicateClause
elseClause :: Parser Expr
elseClause = (tag els) *> pure Else
endIfClause :: Parser Expr
endIfClause = (tag endIf) *> pure Noop
caseClause :: Parser Expr
caseClause = tagWith caseStart variable
whenClause :: Parser Expr
whenClause = tagWith when (quoteString <|> (Num <$> scientific))
endCaseClause :: Parser Expr
endCaseClause = (tag caseEnd) *> pure Noop
filterName :: Parser Text
filterName = mapT $ skipSpace *> manyTill1 letter terminator
where terminator = colon <|>
(skipSpace *> pipe) <|>
(lookAhead $ satisfy (not . isAlpha))
filterArgs :: Parser [Expr]
filterArgs = skipSpace *> sepBy numOrString comma
where numOrString = skipSpace *> (Num <$> scientific) <|> quoteString
filterCell :: Parser Expr
filterCell = do
fnName <- filterName
args <- filterArgs
typeCheckFilter fnName args
typeCheckFilter :: Text
-> [Expr]
-> Parser Expr
typeCheckFilter "toUpper" [] =
return $ FilterCell "toUpper" []
typeCheckFilter "toUpper" _ =
fail "toUpper filter takes no arguments"
typeCheckFilter "toLower" [] =
return $ FilterCell "toLower" []
typeCheckFilter "toLower" _ =
fail "toLower filter takes no arguments"
typeCheckFilter "toTitle" [] =
return $ FilterCell "toTitle" []
typeCheckFilter "toTitle" _ =
fail "toTitle filter takes no arguments"
typeCheckFilter "replace" a@[QuoteString _, QuoteString _] =
return $ FilterCell "replace" a
typeCheckFilter "replace" _ =
fail "replace filter requires find, replace strings as args"
typeCheckFilter "first" [] =
return $ FilterCell "first" []
typeCheckFilter "first" _ =
fail "first filter takes no arguments"
typeCheckFilter "firstOrDefault" a@(_:_) =
return $ FilterCell "firstOrDefault" a
typeCheckFilter "firstOrDefault" _ =
fail "firstOrDefault requires a single default parameter"
typeCheckFilter "last" [] =
return $ FilterCell "last" []
typeCheckFilter "last" _ =
fail "last filter takes no arguments"
typeCheckFilter "lastOrDefault" a@(_:_) =
return $ FilterCell "lastOrDefault" a
typeCheckFilter "lastOrDefault" _ =
fail "lastOrDefault requires a single default parameter"
typeCheckFilter "countElements" [] =
return $ FilterCell "countElements" []
typeCheckFilter "countElements" _ =
fail "countElements takes no arguments"
typeCheckFilter "renderWithSeparator" a@[QuoteString _] =
return $ FilterCell "renderWithSeparator" a
typeCheckFilter "renderWithSeparator" _ =
fail "renderWithSeparator requires a separator argument with which to intersperse the target array"
typeCheckFilter "toSentenceWithSeparator" a@[QuoteString _, QuoteString _] =
return $ FilterCell "toSentenceWithSeparator" a
typeCheckFilter "toSentenceWithSeparator" _ =
fail "toSentenceWithSeparator requires a separator argument and last element separator"
typeCheckFilter l _ =
fail $ (show l) ++ ": function isn't supported"
filterCells :: Parser [Expr]
filterCells = many ((filterCell <* (skipSpace *> pipe)) <|> filterCell)
filterBlock :: Parser Expr
filterBlock = do
lhs <- (quoteString <|> (skipSpace *> variable)) <* (skipSpace >> pipe)
cells <- filterCells
return $ Filter lhs cells
output :: Parser Expr
output = Output <$> outputTag (filterBlock <|> quoteString <|> variable)
ifLogic :: Parser Expr
ifLogic = do
start <- ifClause <|> ifKeyClause <|> elsifClause <|> elseClause
iftrue <- TrueStatements <$>
manyTill (output <|> textPart)
(lookAhead elsifClause <|>
lookAhead elseClause <|>
lookAhead endIfClause)
let sofar = IfLogic start iftrue
(endIfClause *> pure sofar) <|> (IfLogic sofar <$> ifLogic)
caseLogic :: Parser Expr
caseLogic = do
start <- caseClause
patterns <- many1 whenBlock
_ <- endCaseClause
return $ CaseLogic start patterns
where whenBlock = do
pattern <- whenClause <|> elseClause
iftrue <- TrueStatements <$>
manyTill (output <|> textPart)
(lookAhead whenClause <|>
lookAhead elseClause <|>
lookAhead endCaseClause)
return (pattern, iftrue)
block :: Parser Expr
block = choice [ ifLogic
, caseLogic
, rawTag
, commentTag
, output
, textPart
] <?> "Block Parsing"
templateParser :: Parser [Expr]
templateParser = manyTill1 (block <?> "Syntax Error") endOfInput
parseTemplate :: Text
-> IResult Text [Expr]
parseTemplate t =
feed (parse templateParser t) T.empty
templateP :: Prism' Text [Expr]
templateP = prism' back forw
where forw = maybeResult . parseTemplate
back = mconcat . fmap renderExpr