module Dhall.LSP.Backend.Parsing
( getImportLink
, getImportHash
, getLetInner
, getLetAnnot
, getLetIdentifier
, getLamIdentifier
, getForallIdentifier
, binderExprFromText
, holeExpr
)
where
import Data.Text (Text)
import Dhall.Core (Binding(..), Expr(..), Import, Var(..))
import Dhall.Src (Src(..))
import Dhall.Parser
import Dhall.Parser.Token hiding (text)
import Dhall.Parser.Expression (getSourcePos, importType_, importHash_, localOnly)
import Text.Megaparsec (try, skipManyTill, lookAhead, anySingle,
notFollowedBy, eof, takeRest)
import Control.Applicative (optional, (<|>))
import qualified Text.Megaparsec as Megaparsec
import Text.Megaparsec (SourcePos(..))
getLetInner :: Src -> Maybe Src
getLetInner (Src left _ text) = Megaparsec.parseMaybe (unParser parseLetInnerOffset) text
where parseLetInnerOffset = do
setSourcePos left
_let
nonemptyWhitespace
_ <- label
whitespace
_ <- optional (do
_ <- _colon
nonemptyWhitespace
_ <- expr
whitespace)
_equal
whitespace
_ <- expr
whitespace
_ <- optional _in
whitespace
begin <- getSourcePos
tokens <- Megaparsec.takeRest
end <- getSourcePos
return (Src begin end tokens)
getLetAnnot :: Src -> Maybe Src
getLetAnnot (Src left _ text) = Megaparsec.parseMaybe (unParser parseLetAnnot) text
where parseLetAnnot = do
setSourcePos left
_let
nonemptyWhitespace
_ <- label
whitespace
begin <- getSourcePos
(tokens, _) <- Megaparsec.match $ optional (do
_ <- _colon
nonemptyWhitespace
_ <- expr
whitespace)
end <- getSourcePos
_ <- Megaparsec.takeRest
return (Src begin end tokens)
getLetIdentifier :: Src -> Src
getLetIdentifier src@(Src left _ text) =
case Megaparsec.parseMaybe (unParser parseLetIdentifier) text of
Just src' -> src'
Nothing -> src
where parseLetIdentifier = do
setSourcePos left
_let
nonemptyWhitespace
begin <- getSourcePos
(tokens, _) <- Megaparsec.match label
end <- getSourcePos
_ <- Megaparsec.takeRest
return (Src begin end tokens)
getLamIdentifier :: Src -> Maybe Src
getLamIdentifier (Src left _ text) =
Megaparsec.parseMaybe (unParser parseLetIdentifier) text
where parseLetIdentifier = do
setSourcePos left
_lambda
whitespace
_openParens
whitespace
begin <- getSourcePos
(tokens, _) <- Megaparsec.match label
end <- getSourcePos
_ <- Megaparsec.takeRest
return (Src begin end tokens)
getForallIdentifier :: Src -> Maybe Src
getForallIdentifier (Src left _ text) =
Megaparsec.parseMaybe (unParser parseLetIdentifier) text
where parseLetIdentifier = do
setSourcePos left
_forall
whitespace
_openParens
whitespace
begin <- getSourcePos
(tokens, _) <- Megaparsec.match label
end <- getSourcePos
_ <- Megaparsec.takeRest
return (Src begin end tokens)
getImportHash :: Src -> Maybe Src
getImportHash (Src left _ text) =
Megaparsec.parseMaybe (unParser parseImportHashPosition) text
where parseImportHashPosition = do
setSourcePos left
_ <- importType_
whitespace
begin <- getSourcePos
(tokens, _) <- Megaparsec.match $ optional importHash_
end <- getSourcePos
_ <- Megaparsec.takeRest
return (Src begin end tokens)
setSourcePos :: SourcePos -> Parser ()
setSourcePos src =
Megaparsec.updateParserState $ \state ->
let posState = (Megaparsec.statePosState state) { Megaparsec.pstateSourcePos = src }
in state { Megaparsec.statePosState = posState }
getImportLink :: Src -> Src
getImportLink src@(Src left _ text) =
case Megaparsec.parseMaybe (unParser parseImportLink) text of
Just src' -> src'
Nothing -> src
where
parseImportLink = do
setSourcePos left
begin <- getSourcePos
(tokens, _) <-
Megaparsec.match $ (localOnly *> return ()) <|> (httpRaw *> return ())
end <- getSourcePos
_ <- Megaparsec.takeRest
return (Src begin end tokens)
holeExpr :: Expr s a
holeExpr = Var (V "" 0)
binderExprFromText :: Text -> Expr Src Import
binderExprFromText txt =
case Megaparsec.parseMaybe (unParser parseBinderExpr) (txt <> " ") of
Just e -> e
Nothing -> holeExpr
where
boundary = _let <|> _forall <|> _lambda
closedBinder = closedLet <|> closedLambda <|> closedPi
closedLet = do
_let
nonemptyWhitespace
_ <- label
whitespace
_ <- optional (do
_colon
nonemptyWhitespace
expr)
_equal
whitespace
_ <- expr
whitespace
(do
_in
nonemptyWhitespace
_ <- expr
return ())
<|> closedLet
closedLambda = do
_lambda
whitespace
_openParens
whitespace
_ <- label
whitespace
_colon
nonemptyWhitespace
_ <- expr
whitespace
_closeParens
whitespace
_arrow
whitespace
_ <- expr
return ()
closedPi = do
_forall
whitespace
_openParens
whitespace
_ <- label
whitespace
_colon
nonemptyWhitespace
_ <- expr
whitespace
_closeParens
whitespace
_arrow
whitespace
_ <- expr
return ()
parseBinderExpr = do
try (do
skipManyTill anySingle (lookAhead boundary)
try (do
closedBinder
notFollowedBy eof
parseBinderExpr)
<|> try (letBinder <|> lambdaBinder <|> forallBinder)
<|> (do
boundary
parseBinderExpr))
<|> (do
_ <- takeRest
return holeExpr)
letBinder = do
_let
nonemptyWhitespace
name <- label
whitespace
mType <- optional (do _colon; nonemptyWhitespace; _type <- expr; whitespace; return (Nothing, _type))
value <- try (do _equal; whitespace; expr <* whitespace)
<|> (do skipManyTill anySingle (lookAhead boundary <|> _in); return holeExpr)
inner <- parseBinderExpr
return (Let (Binding Nothing name Nothing mType Nothing value) inner)
forallBinder = do
_forall
whitespace
_openParens
whitespace
name <- label
whitespace
_colon
nonemptyWhitespace
typ <- try (do e <- expr; whitespace; _closeParens; whitespace; _arrow; return e)
<|> (do skipManyTill anySingle _arrow; return holeExpr)
whitespace
inner <- parseBinderExpr
return (Pi name typ inner)
lambdaBinder = do
_lambda
whitespace
_openParens
whitespace
name <- label
whitespace
_colon
nonemptyWhitespace
typ <- try (do e <- expr; whitespace; _closeParens; whitespace; _arrow; return e)
<|> (do skipManyTill anySingle _arrow; return holeExpr)
whitespace
inner <- parseBinderExpr
return (Lam name typ inner)