module Bricks.Parsec
(
parse'expression
, parse'expression'paren
, parse'expression'antiquote
, parse'expression'dictKey
, parse'expressionList
, parse'expressionList'1
, parse'expressionList'1'noDot
, parse'var
, parse'strUnquoted
, parse'strStatic
, parse'strStatic'quoted
, parse'strStatic'unquoted
, parse'str'dynamic
, 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'spaces
, parse'comment
, parse'comment'inline
, parse'comment'block
, parse'keyword
) where
import Bricks.Expression
import Bricks.Keyword
import Bricks.Source
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 Data.Set (Set)
import qualified Data.Set as Set
import Control.Monad (fail)
import Prelude (fromIntegral, succ)
parse'position :: Parser SourcePosition
parse'position = do
x <- P.getPosition
pure SourcePosition
{ sourcePosition'line = fromIntegral $ P.sourceLine x
, sourcePosition'column = fromIntegral $ P.sourceColumn x
}
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 (void p)
where
p =
P.string (keywordString k) *>
P.notFollowedBy (P.satisfy char'canBeUnquoted) *>
parse'spaces
parse'strUnquoted :: Parser (UnquotedString, SourceRange)
parse'strUnquoted = do
pos'1 <- parse'position
text <- P.many1 (P.satisfy char'canBeUnquoted) <&> Text.pack
pos'2 <- parse'position
case unquotedString'try text of
Nothing -> P.parserZero
Just b -> do
_ <- parse'spaces
pure (b, SourceRange pos'1 pos'2)
parse'var :: Parser Var
parse'var = do
(a, b) <- parse'strUnquoted
pure $ Var a (Just 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 =
do
pos'1 <- parse'position
_ <- P.char '"'
Str'Static text _ <- parse'str'within'normalQ
_ <- P.char '"' <|> anti
pos'2 <- parse'position
_ <- parse'spaces
let src = Just (SourceRange pos'1 pos'2)
pure $ Str'Static text src
where
anti = do
_ <- P.string "${"
fail "antiquotation is not allowed in this context"
parse'strStatic'unquoted :: Parser Str'Static
parse'strStatic'unquoted = do
(a, b) <- parse'strUnquoted
pure $ Str'Static (unquotedString'text a) (Just b)
parse'str'dynamic :: Parser Str'Dynamic
parse'str'dynamic =
do
pos'1 <- parse'position
_ <- P.char '"'
xs <- go Seq.empty
pos'2 <- parse'position
_ <- parse'spaces
let src = Just (SourceRange pos'1 pos'2)
pure $ Str'Dynamic xs src
where
go :: Seq Str'1 -> Parser (Seq Str'1)
go previousParts =
asum
[ do
_ <- P.char '"'
pure previousParts
, do
x <- lit <|> (parse'expression'antiquote <&> Str'1'Antiquote)
go $ previousParts |> x
]
lit :: Parser Str'1
lit = parse'str'within'normalQ <&> Str'1'Literal
parse'str'within'normalQ :: Parser Str'Static
parse'str'within'normalQ =
do
pos'1 <- parse'position
t <- text
pos'2 <- parse'position
let src = Just (SourceRange pos'1 pos'2)
pure $ Str'Static t src
where
text :: Parser Text
text = P.many1 (char <|> parse'str'escape'normalQ) <&> Text.concat
char :: Parser Text
char = asum
[ P.satisfy (\x -> x /= '$' && x /= '"' && x /= '\\')
, P.try $ P.char '$' <* P.notFollowedBy (P.char '{')
] <&> Text.singleton
parse'str'escape'normalQ :: Parser Text
parse'str'escape'normalQ =
P.char '\\' *> esc
where
esc = asum
[ P.char '\\' $> "\\"
, P.char '"' $> "\""
, P.char 'n' $> "\n"
, P.char 'r' $> "\r"
, P.char 't' $> "\t"
, P.string "${" $> "${"
]
parse'inStr :: Parser InStr
parse'inStr =
do
pos'1 <- parse'position
_ <- P.string "''"
lines <- go Seq.empty
pos'2 <- parse'position
_ <- parse'spaces
let src = Just (SourceRange pos'1 pos'2)
pure $ InStr lines src
where
go :: Seq InStr'1 -> Parser (Seq InStr'1)
go previousLines =
do
x <- parse'inStr'1
let newLines = previousLines |> x
if isJust (inStr'1'lineBreak x)
then go newLines
else P.string "''" $> newLines
parse'inStr'1 :: Parser InStr'1
parse'inStr'1 =
do
pos'1 <- parse'position
n <- parse'count (P.char ' ')
pos'2 <- parse'position
(str, break) <- go Seq.empty
pure InStr'1
{ inStr'1'level = n
, inStr'1'indentSource = Just (SourceRange pos'1 pos'2)
, inStr'1'str = str
, inStr'1'lineBreak = break
}
where
go :: Seq Str'1 -> Parser (Seq Str'1, Maybe Str'Static)
go previousParts =
asum
[ do
break <- end
pure (previousParts, break)
, do
x <- chars
go (previousParts |> x)
, do
x <- parse'expression'antiquote
go (previousParts |> Str'1'Antiquote x)
]
end :: Parser (Maybe Str'Static)
end = asum
[ do
end'pos'1 <- parse'position
s <- P.char '\n'
end'pos'2 <- parse'position
pure $ Just $ Str'Static
{ str'static'text = Text.singleton s
, str'static'source = Just (SourceRange end'pos'1 end'pos'2)
}
, do
_ <- P.lookAhead . P.try $ P.string "''"
pure Nothing
]
chars :: Parser Str'1
chars = do
chars'pos'1 <- parse'position
s <- 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 '\'')
]
chars'pos'2 <- parse'position
pure $ Str'1'Literal $ Str'Static
{ str'static'text = Text.pack s
, str'static'source = Just (SourceRange chars'pos'1 chars'pos'2)
}
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'var <* 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 Set.empty
where
go :: Seq DictPattern'1
-> Set Text
-> Parser DictPattern
go previousItems previousNames =
asum
[ end $> DictPattern previousItems False
, ellipsis $> DictPattern previousItems True
, more
]
where
more :: Parser DictPattern
more = item >>= \newItem ->
let
newName = var'text (dictPattern'1'name newItem)
newItems = previousItems |> newItem
newNames = Set.insert newName previousNames
in
if newName `Set.member` previousNames
then fail $ "Name " <> Text.unpack newName <>
" appears twice in a dict pattern"
else asum
[ P.char ',' *> parse'spaces *> go newItems newNames
, end $> DictPattern newItems False
]
item :: Parser DictPattern'1
item = DictPattern'1 <$> parse'var <*> P.optionMaybe def
def :: Parser Expression
def = P.char '?' *> parse'spaces *> parse'expression
ellipsis :: Parser ()
ellipsis = P.string "..." *> parse'spaces *> end
end :: Parser ()
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 = do
pos'1 <- parse'position
head <- parse'param
body <- parse'expression
let pos'2 = sourceRange'end <$> expression'source body
let src = SourceRange pos'1 <$> pos'2
pure $ Lambda head body src
parse'list :: Parser List
parse'list =
do
pos'1 <- parse'position
_ <- P.char '['
_ <- parse'spaces
x <- parse'expressionList
_ <- P.char ']'
pos'2 <- parse'position
_ <- parse'spaces
let src = (Just (SourceRange pos'1 pos'2))
pure $ List (Seq.fromList x) src
parse'dict :: Parser Dict
parse'dict =
parse'dict'noRec <|> parse'dict'rec
parse'dict'rec :: Parser Dict
parse'dict'rec =
do
pos'1 <- parse'position
_ <- parse'keyword keyword'rec
Dict _ xs src' <- parse'dict'noRec
let src = src' <&> \s -> s{ sourceRange'start = pos'1 }
pure $ Dict True xs src
parse'dict'noRec :: Parser Dict
parse'dict'noRec =
do
pos'1 <- parse'position
_ <- P.char '{'
_ <- parse'spaces
xs <- go Seq.empty
pos'2 <- parse'position
_ <- parse'spaces
let src = Just (SourceRange pos'1 pos'2)
pure $ Dict False xs src
where
go :: Seq DictBinding -> Parser (Seq DictBinding)
go previousBindings =
asum
[ do
_ <- P.char '}'
pure previousBindings
, do
a <- parse'dictBinding
go (previousBindings |> a)
]
parse'dot'rhs'chain :: Parser [Expression]
parse'dot'rhs'chain =
P.many dot
where
dot = do
_ <- P.char '.'
_ <- parse'spaces
x <- parse'expression'dictKey
_ <- parse'spaces
pure x
parse'let :: Parser Let
parse'let =
do
pos'1 <- parse'position
_ <- parse'keyword keyword'let
(xs, e) <- go Seq.empty
let
src = do
pos'2 <- sourceRange'end <$> expression'source e
pure $ SourceRange pos'1 pos'2
pure $ Let xs e src
where
go :: Seq LetBinding -> Parser (Seq LetBinding, Expression)
go previousBindings =
asum
[ do
_ <- parse'keyword keyword'in
e <- parse'expression
pure (previousBindings, e)
, do
a <- parse'letBinding
go (previousBindings |> a)
]
parse'dictBinding :: Parser DictBinding
parse'dictBinding =
parse'dictBinding'inherit <|> parse'dictBinding'eq
parse'dictBinding'inherit :: Parser DictBinding
parse'dictBinding'inherit =
do
_ <- parse'keyword keyword'inherit
asum
[ do
a <- parse'expression'paren
xs <- go'strs Seq.empty
pure $ DictBinding'Inherit'Dict a xs
, do
xs <- go'vars Seq.empty
pure $ DictBinding'Inherit'Var xs
]
where
go'strs :: Seq Str'Static -> Parser (Seq Str'Static)
go'strs previousList =
asum
[ do
_ <- P.char ';'
_ <- parse'spaces
pure previousList
, do
x <- parse'strStatic
go'strs (previousList |> x)
]
go'vars :: Seq Var -> Parser (Seq Var)
go'vars previousList =
asum
[ do
_ <- P.char ';'
_ <- parse'spaces
pure previousList
, do
x <- parse'var
go'vars (previousList |> x)
]
parse'dictBinding'eq :: Parser DictBinding
parse'dictBinding'eq =
do
key <- parse'expression'dictKey
_ <- parse'spaces
_ <- P.char '='
_ <- parse'spaces
val <- parse'expression
_ <- parse'spaces
_ <- P.char ';'
_ <- parse'spaces
pure $ DictBinding'Eq key val
parse'letBinding :: Parser LetBinding
parse'letBinding =
parse'letBinding'inherit <|> parse'letBinding'eq
parse'letBinding'eq :: Parser LetBinding
parse'letBinding'eq =
do
key <- parse'var
_ <- parse'spaces
_ <- P.char '='
_ <- parse'spaces
val <- parse'expression
_ <- parse'spaces
_ <- P.char ';'
_ <- parse'spaces
pure $ LetBinding'Eq key val
parse'letBinding'inherit :: Parser LetBinding
parse'letBinding'inherit =
do
_ <- parse'keyword keyword'inherit
a <- parse'expression'paren
xs <- go Seq.empty
pure $ LetBinding'Inherit a xs
where
go :: Seq Var -> Parser (Seq Var)
go previousList =
asum
[ do
_ <- P.char ';'
_ <- parse'spaces
pure previousList
, do
x <- parse'var
go (previousList |> x)
]
parse'expression :: Parser Expression
parse'expression =
p <?> "expression"
where
p = asum
[ parse'let <&> Expr'Let
, parse'lambda <&> Expr'Lambda
, list
]
list = 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'str'dynamic <&> Expr'Str
, parse'inStr <&> Expr'Str'Indented
, parse'list <&> Expr'List
, parse'dict <&> Expr'Dict
, parse'var <&> 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'antiquote :: Parser Expression
parse'expression'antiquote =
P.try (P.string "${") *> parse'spaces *> parse'expression <* P.char '}'
parse'expression'dictKey :: Parser Expression
parse'expression'dictKey =
quoted <|> antiquoted <|> unquoted
where
quoted :: Parser Expression
quoted = parse'str'dynamic <&> Expr'Str
antiquoted :: Parser Expression
antiquoted = do
_ <- P.string "${"
_ <- parse'spaces
e <- parse'expression
_ <- P.char '}'
_ <- parse'spaces
pure e
unquoted :: Parser Expression
unquoted = do
(x, src) <- parse'strUnquoted
pure $ Expr'Str $ str'static'to'dynamic $
Str'Static (unquotedString'text x) (Just src)
parse'count :: Parser a -> Parser Natural
parse'count p =
go 0
where
go :: Natural -> Parser Natural
go n = (p *> go (succ n)) <|> pure n