module Bricks.Parsing
(
parse'expression
, parse'expression'paren
, parse'expression'dictKey
, parse'expressionList
, parse'expressionList'1
, parse'expressionList'1'noDot
, parse'strUnquoted
, parse'strStatic
, parse'strStatic'quoted
, parse'strStatic'unquoted
, parse'strDynamic'quoted
, parse'strDynamic'normalQ
, parse'strDynamic'indentedQ
, parse'str'within'normalQ
, parse'str'escape'normalQ
, parse'inStr
, parse'inStr'1
, parse'list
, parse'dict
, parse'dict'rec
, parse'dict'noRec
, parse'dictBinding
, parse'dictBinding'inherit
, parse'dictBinding'eq
, parse'dot'rhs'chain
, parse'lambda
, parse'param
, parse'param'var
, parse'param'noVar
, parse'dictPattern
, parse'dictPattern'start
, parse'let
, parse'letBinding
, parse'letBinding'eq
, parse'letBinding'inherit
, parse'with
, parse'inherit
, parse'spaces
, parse'comment
, parse'comment'inline
, parse'comment'block
, parse'keyword
, parse'antiquote
) where
import Bricks.Expression
import Bricks.IndentedString
import Bricks.Keyword
import Bricks.UnquotedString
import Bricks.Internal.Prelude
import Bricks.Internal.Seq (Seq, (|>))
import qualified Bricks.Internal.Seq as Seq
import Bricks.Internal.Text (Text)
import qualified Bricks.Internal.Text as Text
import Text.Parsec ((<?>))
import qualified Text.Parsec as P
import Text.Parsec.Text (Parser)
import Control.Monad (fail)
import Prelude (succ)
parse'spaces :: Parser ()
parse'spaces =
(void $ P.many (void (P.space <?> "") <|> parse'comment))
parse'comment :: Parser ()
parse'comment =
parse'comment'inline <|> parse'comment'block
parse'comment'inline :: Parser ()
parse'comment'inline =
void $ P.try (P.string "--" <?> "") *> P.manyTill P.anyChar (P.char '\n')
parse'comment'block :: Parser ()
parse'comment'block =
start <* P.manyTill middle end
where
start = void $ P.try (P.string "{-" <?> "")
middle = parse'comment'block <|> void P.anyChar
end = P.try (P.string "-}")
parse'keyword :: Keyword -> Parser ()
parse'keyword k =
P.try $ do
_ <- P.string (keywordString k)
_ <- P.notFollowedBy (P.satisfy char'canRenderUnquoted)
_ <- parse'spaces
pure ()
parse'strUnquoted :: Parser Str'Unquoted
parse'strUnquoted =
do
a <- Text.pack <$> P.many1 (P.satisfy char'canRenderUnquoted)
case str'tryUnquoted a of
Nothing -> P.parserZero
Just b -> parse'spaces $> b
parse'strStatic :: Parser Str'Static
parse'strStatic =
(parse'strStatic'quoted <|> parse'strStatic'unquoted) <?> "static string"
parse'strStatic'quoted :: Parser Str'Static
parse'strStatic'quoted =
P.char '"' *> parse'str'within'normalQ <* asum
[ P.char '"' *> parse'spaces
, P.string "${" *> fail "antiquotation is not allowed in this context"
]
parse'strStatic'unquoted :: Parser Str'Static
parse'strStatic'unquoted =
parse'strUnquoted <&> str'unquotedToStatic
parse'strDynamic'quoted :: Parser Str'Dynamic
parse'strDynamic'quoted =
parse'strDynamic'normalQ <|> parse'strDynamic'indentedQ
parse'strDynamic'normalQ :: Parser Str'Dynamic
parse'strDynamic'normalQ =
P.char '"' *> go Seq.empty
where
go :: Seq Str'1 -> Parser Str'Dynamic
go previousParts =
asum
[ end $> Str'Dynamic previousParts
, asum
[ parse'str'within'normalQ <&> Str'1'Literal
, anti
]
>>= \x -> go $ previousParts |> x
]
end = P.char '"' *> parse'spaces
anti = fmap Str'1'Antiquote $
P.try (P.string "${") *> parse'spaces *> parse'expression <* P.char '}'
parse'str'within'normalQ :: Parser Text
parse'str'within'normalQ = do
fmap Text.concat $ P.many1 $ asum
[ P.satisfy (\c -> c /= '$' && c /= '"' && c /= '\\') <&> Text.singleton
, P.try $ P.char '$' <* P.notFollowedBy (P.char '{') <&> Text.singleton
, parse'str'escape'normalQ
]
parse'str'escape'normalQ :: Parser Text
parse'str'escape'normalQ =
P.char '\\' *> asum
[ P.char '\\' $> "\\"
, P.char '"' $> "\""
, P.char 'n' $> "\n"
, P.char 'r' $> "\r"
, P.char 't' $> "\t"
, P.string "${" $> "${"
]
parse'strDynamic'indentedQ :: Parser Str'Dynamic
parse'strDynamic'indentedQ =
inStr'join . inStr'dedent . inStr'trim <$> parse'inStr
parse'inStr :: Parser InStr
parse'inStr =
P.string "''" *> go Seq.empty
where
go :: Seq InStr'1 -> Parser InStr
go previousLines =
do
line <- parse'inStr'1
let newLines = previousLines |> line
asum
[ P.string "''" *> parse'spaces $> InStr newLines
, P.char '\n' *> go newLines
]
parse'inStr'1 :: Parser InStr'1
parse'inStr'1 =
do
a <- parse'count (P.char ' ')
b <- go Seq.empty
pure $ InStr'1 a b
where
go :: Seq Str'1 -> Parser Str'Dynamic
go previousParts =
asum
[ end $> Str'Dynamic previousParts
, chars >>= \x -> go (previousParts |> x)
, parse'antiquote >>= \(Str'Dynamic xs) -> go (previousParts <> xs)
]
end = P.lookAhead $ asum
[ void $ P.char '\n'
, void $ P.try (P.string "''")
]
chars = fmap (Str'1'Literal . Text.pack) $ P.many1 $ asum
[ P.satisfy (\c -> c /= '$' && c /= '\'' && c /= '\n')
, P.try $ P.char '$' <* P.notFollowedBy (P.char '{')
, P.try $ P.char '\'' <* P.notFollowedBy (P.char '\'')
]
parse'antiquote :: Parser Str'Dynamic
parse'antiquote =
(P.try (P.string "${") *> parse'spaces *> parse'expression <* P.char '}')
<&> \case
Expr'Str x -> x
x -> strDynamic'singleton (Str'1'Antiquote x)
parse'param :: Parser Param
parse'param =
parse'param'var <|> parse'param'noVar
parse'param'var :: Parser Param
parse'param'var = do
(a, b) <- P.try $ do
a <- parse'strUnquoted <* parse'spaces
b <- ((P.char ':' $> False) <|> (P.char '@' $> True)) <* parse'spaces
pure (a, b)
if b
then parse'dictPattern <* P.char ':' <* parse'spaces <&> Param'Both a
else pure $ Param'Name a
parse'param'noVar :: Parser Param
parse'param'noVar = Param'DictPattern <$> do
_ <- P.try . P.lookAhead $ parse'dictPattern'start
parse'dictPattern <* P.char ':' <* parse'spaces
parse'dictPattern :: Parser DictPattern
parse'dictPattern =
P.char '{' *> parse'spaces *> go Seq.empty
where
go :: Seq DictPattern'1 -> Parser DictPattern
go previousItems =
asum
[ end $> DictPattern previousItems False
, ellipsis $> DictPattern previousItems True
, do
newItems <- item <&> \x -> previousItems |> x
asum
[ P.char ',' *> parse'spaces *> go newItems
, end $> DictPattern newItems False
]
]
item = DictPattern'1 <$> parse'strUnquoted <*> P.optionMaybe def
ellipsis = P.string "..." *> parse'spaces *> end
def = P.char '?' *> parse'spaces *> parse'expression
end = P.char '}' *> parse'spaces
parse'dictPattern'start :: Parser ()
parse'dictPattern'start =
P.char '{' *> parse'spaces *> asum
[ void $ P.string "..."
, void $ P.char '}' *> parse'spaces *> P.char ':'
, void $ parse'strUnquoted *> (P.char ',' <|> P.char '?' <|> P.char '}')
]
parse'lambda :: Parser Lambda
parse'lambda =
Lambda <$> parse'param <*> parse'expression
parse'list :: Parser List
parse'list =
(start *> parse'expressionList <* end) <&> List . Seq.fromList
where
start = P.char '[' *> parse'spaces
end = P.char ']' <* parse'spaces
parse'dict :: Parser Dict
parse'dict =
asum
[ parse'dict'noRec <&> Dict False
, parse'dict'rec <&> Dict True
]
parse'dict'rec :: Parser (Seq DictBinding)
parse'dict'rec =
parse'keyword keyword'rec *> parse'dict'noRec
parse'dict'noRec :: Parser (Seq DictBinding)
parse'dict'noRec =
P.char '{' *> parse'spaces *> go Seq.empty
where
go :: Seq DictBinding -> Parser (Seq DictBinding)
go previousBindings = asum
[ P.char '}' *> parse'spaces $> previousBindings
, parse'dictBinding >>= \a -> go (previousBindings |> a)
]
parse'dot'rhs'chain :: Parser [Expression]
parse'dot'rhs'chain =
P.many $
P.char '.' *> parse'spaces *> parse'expression'dictKey <* parse'spaces
parse'let :: Parser Let
parse'let =
parse'keyword keyword'let *> go Seq.empty
where
go :: Seq LetBinding -> Parser Let
go previousBindings =
asum
[ end <&> Let previousBindings
, parse'letBinding >>= \a -> go (previousBindings |> a)
]
end = parse'keyword keyword'in *> parse'expression
parse'with :: Parser With
parse'with =
With
<$> (parse'keyword keyword'with *> parse'expression)
<*> (P.char ';' *> parse'spaces *> parse'expression)
parse'dictBinding :: Parser DictBinding
parse'dictBinding =
parse'dictBinding'inherit <|> parse'dictBinding'eq
parse'dictBinding'inherit :: Parser DictBinding
parse'dictBinding'inherit =
DictBinding'Inherit <$> parse'inherit
parse'dictBinding'eq :: Parser DictBinding
parse'dictBinding'eq =
DictBinding'Eq
<$> (parse'expression'dictKey <* parse'spaces <* P.char '=' <* parse'spaces)
<*> (parse'expression <* parse'spaces <* P.char ';' <* parse'spaces)
parse'letBinding :: Parser LetBinding
parse'letBinding =
parse'letBinding'inherit <|> parse'letBinding'eq
parse'letBinding'eq :: Parser LetBinding
parse'letBinding'eq =
LetBinding'Eq
<$> (parse'strStatic <* parse'spaces <* P.char '=' <* parse'spaces)
<*> (parse'expression <* parse'spaces <* P.char ';' <* parse'spaces)
parse'letBinding'inherit :: Parser LetBinding
parse'letBinding'inherit =
LetBinding'Inherit <$> parse'inherit
parse'inherit :: Parser Inherit
parse'inherit =
Inherit
<$> (parse'keyword keyword'inherit *> P.optionMaybe parse'expression'paren)
<*> go Seq.empty
where
go :: Seq Str'Static -> Parser (Seq Str'Static)
go previousList =
asum
[ P.char ';' *> parse'spaces $> previousList
, parse'strStatic >>= \x -> go (previousList |> x)
]
parse'expression :: Parser Expression
parse'expression =
p <?> "expression"
where
p = asum
[ parse'let <&> Expr'Let
, parse'with <&> Expr'With
, parse'lambda <&> Expr'Lambda
, parse'expressionList >>= \case
[] -> P.parserZero
f : args -> pure $ expression'applyArgs f args
]
parse'expressionList :: Parser [Expression]
parse'expressionList =
P.many parse'expressionList'1 <?> "expression list"
parse'expressionList'1 :: Parser Expression
parse'expressionList'1 =
expression'applyDots
<$> parse'expressionList'1'noDot
<*> parse'dot'rhs'chain
<?> "expression list item"
parse'expressionList'1'noDot :: Parser Expression
parse'expressionList'1'noDot =
asum
[ parse'strDynamic'quoted <&> Expr'Str
, parse'list <&> Expr'List
, parse'dict <&> Expr'Dict
, parse'strUnquoted <&> Expr'Var
, parse'expression'paren
]
<?> "expression list item without a dot"
parse'expression'paren :: Parser Expression
parse'expression'paren =
P.char '(' *> parse'spaces *> parse'expression <* P.char ')' <* parse'spaces
parse'expression'dictKey :: Parser Expression
parse'expression'dictKey =
asum
[ parse'strDynamic'quoted <&> Expr'Str
, P.string "${" *> parse'spaces *> parse'expression
<* P.char '}' <* parse'spaces
, parse'strUnquoted <&> Expr'Str . str'unquotedToDynamic
]
parse'count :: Parser a -> Parser Natural
parse'count p = go 0
where
go :: Natural -> Parser Natural
go n = (p *> go (succ n)) <|> pure n