{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
module Swarm.Language.Parse (
reservedWords,
Parser,
parsePolytype,
parseType,
parseTerm,
binOps,
unOps,
runParser,
runParserTH,
readTerm,
readTerm',
showShortError,
showErrorPos,
getLocRange,
) where
import Control.Monad.Combinators.Expr
import Control.Monad.Reader
import Data.Bifunctor
import Data.Foldable (asum)
import Data.List (nub)
import Data.List.NonEmpty qualified (head)
import Data.Map.Strict qualified as Map
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Set qualified as S
import Data.Set.Lens (setOf)
import Data.Text (Text, index, toLower)
import Data.Text qualified as T
import Data.Void
import Swarm.Language.Syntax
import Swarm.Language.Types
import Text.Megaparsec hiding (runParser)
import Text.Megaparsec.Char
import Text.Megaparsec.Char.Lexer qualified as L
import Text.Megaparsec.Pos qualified as Pos
import Witch
data Antiquoting = AllowAntiquoting | DisallowAntiquoting
deriving (Antiquoting -> Antiquoting -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Antiquoting -> Antiquoting -> Bool
$c/= :: Antiquoting -> Antiquoting -> Bool
== :: Antiquoting -> Antiquoting -> Bool
$c== :: Antiquoting -> Antiquoting -> Bool
Eq, Eq Antiquoting
Antiquoting -> Antiquoting -> Bool
Antiquoting -> Antiquoting -> Ordering
Antiquoting -> Antiquoting -> Antiquoting
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Antiquoting -> Antiquoting -> Antiquoting
$cmin :: Antiquoting -> Antiquoting -> Antiquoting
max :: Antiquoting -> Antiquoting -> Antiquoting
$cmax :: Antiquoting -> Antiquoting -> Antiquoting
>= :: Antiquoting -> Antiquoting -> Bool
$c>= :: Antiquoting -> Antiquoting -> Bool
> :: Antiquoting -> Antiquoting -> Bool
$c> :: Antiquoting -> Antiquoting -> Bool
<= :: Antiquoting -> Antiquoting -> Bool
$c<= :: Antiquoting -> Antiquoting -> Bool
< :: Antiquoting -> Antiquoting -> Bool
$c< :: Antiquoting -> Antiquoting -> Bool
compare :: Antiquoting -> Antiquoting -> Ordering
$ccompare :: Antiquoting -> Antiquoting -> Ordering
Ord, Int -> Antiquoting -> ShowS
[Antiquoting] -> ShowS
Antiquoting -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Antiquoting] -> ShowS
$cshowList :: [Antiquoting] -> ShowS
show :: Antiquoting -> String
$cshow :: Antiquoting -> String
showsPrec :: Int -> Antiquoting -> ShowS
$cshowsPrec :: Int -> Antiquoting -> ShowS
Show)
type Parser = ReaderT Antiquoting (Parsec Void Text)
type ParserError = ParseErrorBundle Text Void
reservedWords :: [Text]
reservedWords :: [Text]
reservedWords =
forall a b. (a -> b) -> [a] -> [b]
map (ConstInfo -> Text
syntax forall b c a. (b -> c) -> (a -> b) -> a -> c
. Const -> ConstInfo
constInfo) (forall a. (a -> Bool) -> [a] -> [a]
filter Const -> Bool
isUserFunc [Const]
allConst)
forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (DirInfo -> Text
dirSyntax forall b c a. (b -> c) -> (a -> b) -> a -> c
. Direction -> DirInfo
dirInfo) [Direction]
allDirs
forall a. [a] -> [a] -> [a]
++ [ Text
"unit"
, Text
"int"
, Text
"text"
, Text
"dir"
, Text
"bool"
, Text
"robot"
, Text
"cmd"
, Text
"delay"
, Text
"let"
, Text
"def"
, Text
"end"
, Text
"in"
, Text
"true"
, Text
"false"
, Text
"forall"
, Text
"require"
]
sc :: Parser ()
sc :: Parser ()
sc =
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
L.space
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space1
(forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> m ()
L.skipLineComment Tokens Text
"//")
(forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> Tokens s -> m ()
L.skipBlockComment Tokens Text
"/*" Tokens Text
"*/")
lexeme :: Parser a -> Parser a
lexeme :: forall a. Parser a -> Parser a
lexeme = forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme Parser ()
sc
symbol :: Text -> Parser Text
symbol :: Text -> Parser Text
symbol = forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> Tokens s -> m (Tokens s)
L.symbol Parser ()
sc
reserved :: Text -> Parser ()
reserved :: Text -> Parser ()
reserved Text
w = (forall a. Parser a -> Parser a
lexeme forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try) forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Text
w forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'_')
identifier :: Parser Text
identifier :: Parser Text
identifier = (forall a. Parser a -> Parser a
lexeme forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try) (ReaderT Antiquoting (Parsec Void Text) [Token Text]
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {m :: * -> *}. MonadFail m => String -> m Text
check) forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"variable name"
where
p :: ReaderT Antiquoting (Parsec Void Text) [Token Text]
p = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
letterChar forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'_') forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'_' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'\'')
check :: String -> m Text
check String
s
| Text -> Text
toLower Text
t forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
reservedWords =
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"reserved word '" forall a. [a] -> [a] -> [a]
++ String
s forall a. [a] -> [a] -> [a]
++ String
"' cannot be used as variable name"
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return Text
t
where
t :: Text
t = forall target source. From source target => source -> target
into @Text String
s
textLiteral :: Parser Text
textLiteral :: Parser Text
textLiteral = forall target source. From source target => source -> target
into forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> Parser a
lexeme (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'"' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Char
L.charLiteral (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'"'))
integer :: Parser Integer
integer :: Parser Integer
integer =
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"integer literal" forall a b. (a -> b) -> a -> b
$
forall a. Parser a -> Parser a
lexeme forall a b. (a -> b) -> a -> b
$ do
Integer
n <-
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"0b" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
L.binary
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"0o" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
L.octal
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"0x" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
L.hexadecimal
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
L.decimal
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
n
braces :: Parser a -> Parser a
braces :: forall a. Parser a -> Parser a
braces = forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Text -> Parser Text
symbol Text
"{") (Text -> Parser Text
symbol Text
"}")
parens :: Parser a -> Parser a
parens :: forall a. Parser a -> Parser a
parens = forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Text -> Parser Text
symbol Text
"(") (Text -> Parser Text
symbol Text
")")
parsePolytype :: Parser Polytype
parsePolytype :: Parser Polytype
parsePolytype =
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$
[Text] -> Type -> Parser Polytype
quantify
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. a -> Maybe a -> a
fromMaybe [] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Text -> Parser ()
reserved Text
"forall" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some Parser Text
identifier forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> Parser Text
symbol Text
"."))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Type
parseType
where
quantify :: [Var] -> Type -> Parser Polytype
quantify :: [Text] -> Type -> Parser Polytype
quantify [Text]
xs Type
ty
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
xs = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall t. [Text] -> t -> Poly t
Forall (forall a. Set a -> [a]
S.toList Set Text
free) Type
ty
| forall a. Set a -> Bool
S.null Set Text
free = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall t. [Text] -> t -> Poly t
Forall [Text]
xs Type
ty
| Bool
otherwise =
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
[String] -> String
unlines
[ String
" Type contains free variable(s): " forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords (forall a b. (a -> b) -> [a] -> [b]
map forall source target. From source target => source -> target
from (forall a. Set a -> [a]
S.toList Set Text
free))
, String
" Try adding them to the 'forall'."
]
where
free :: Set Text
free = Type -> Set Text
tyVars Type
ty forall a. Ord a => Set a -> Set a -> Set a
`S.difference` forall a. Ord a => [a] -> Set a
S.fromList [Text]
xs
parseType :: Parser Type
parseType :: Parser Type
parseType = forall (m :: * -> *) a.
MonadPlus m =>
m a -> [[Operator m a]] -> m a
makeExprParser Parser Type
parseTypeAtom [[Operator (ReaderT Antiquoting (Parsec Void Text)) Type]]
table
where
table :: [[Operator (ReaderT Antiquoting (Parsec Void Text)) Type]]
table =
[ [forall (m :: * -> *) a. m (a -> a -> a) -> Operator m a
InfixR (Type -> Type -> Type
(:*:) forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
symbol Text
"*")]
, [forall (m :: * -> *) a. m (a -> a -> a) -> Operator m a
InfixR (Type -> Type -> Type
(:+:) forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
symbol Text
"+")]
, [forall (m :: * -> *) a. m (a -> a -> a) -> Operator m a
InfixR (Type -> Type -> Type
(:->:) forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
symbol Text
"->")]
]
parseTypeAtom :: Parser Type
parseTypeAtom :: Parser Type
parseTypeAtom =
Type
TyUnit forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser ()
reserved Text
"unit"
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Type
TyVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
identifier
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Type
TyInt forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser ()
reserved Text
"int"
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Type
TyText forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser ()
reserved Text
"text"
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Type
TyDir forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser ()
reserved Text
"dir"
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Type
TyBool forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser ()
reserved Text
"bool"
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Type
TyRobot forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser ()
reserved Text
"robot"
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Type -> Type
TyCmd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Parser ()
reserved Text
"cmd" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Type
parseTypeAtom)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Type -> Type
TyDelay forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> Parser a
braces Parser Type
parseType
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. Parser a -> Parser a
parens Parser Type
parseType
parseDirection :: Parser Direction
parseDirection :: Parser Direction
parseDirection = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum (forall a b. (a -> b) -> [a] -> [b]
map Direction -> Parser Direction
alternative [Direction]
allDirs) forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"direction constant"
where
alternative :: Direction -> Parser Direction
alternative Direction
d = Direction
d forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Text -> Parser ()
reserved forall b c a. (b -> c) -> (a -> b) -> a -> c
. DirInfo -> Text
dirSyntax forall b c a. (b -> c) -> (a -> b) -> a -> c
. Direction -> DirInfo
dirInfo) Direction
d
parseConst :: Parser Const
parseConst :: Parser Const
parseConst = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum (forall a b. (a -> b) -> [a] -> [b]
map Const -> Parser Const
alternative [Const]
consts) forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"built-in user function"
where
consts :: [Const]
consts = forall a. (a -> Bool) -> [a] -> [a]
filter Const -> Bool
isUserFunc [Const]
allConst
alternative :: Const -> Parser Const
alternative Const
c = Const
c forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser ()
reserved (ConstInfo -> Text
syntax forall a b. (a -> b) -> a -> b
$ Const -> ConstInfo
constInfo Const
c)
parseLocG :: Parser a -> Parser (Location, a)
parseLocG :: forall a. Parser a -> Parser (Location, a)
parseLocG Parser a
pa = do
Int
start <- forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
a
a <- Parser a
pa
Int
end <- forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Int -> Location
Location Int
start Int
end, a
a)
parseLoc :: Parser Term -> Parser Syntax
parseLoc :: Parser Term -> Parser Syntax
parseLoc Parser Term
pterm = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Location -> Term -> Syntax
Syntax forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> Parser (Location, a)
parseLocG Parser Term
pterm
parseTermAtom :: Parser Syntax
parseTermAtom :: Parser Syntax
parseTermAtom =
Parser Term -> Parser Syntax
parseLoc
( Term
TUnit forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
symbol Text
"()"
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Const -> Term
TConst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Const
parseConst
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Term
TVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
identifier
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Direction -> Term
TDir forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Direction
parseDirection
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Integer -> Term
TInt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Integer
integer
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Term
TText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
textLiteral
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Term
TBool forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Bool
True forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser ()
reserved Text
"true") forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Bool
False forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser ()
reserved Text
"false"))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser ()
reserved Text
"require"
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ( ( Text -> Term
TRequireDevice
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser Text
textLiteral forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"device name in double quotes")
)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ( Int -> Text -> Term
TRequire forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Integer
integer)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser Text
textLiteral forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"entity name in double quotes")
)
)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Maybe Type -> Syntax -> Term
SLam forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Parser Text
symbol Text
"\\" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
identifier)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Text -> Parser Text
symbol Text
":" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Type
parseType)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> Parser Text
symbol Text
"." forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Syntax
parseTerm)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Maybe Polytype -> Syntax -> Syntax -> Term
sLet forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Parser ()
reserved Text
"let" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
identifier)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Text -> Parser Text
symbol Text
":" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Polytype
parsePolytype)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> Parser Text
symbol Text
"=" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Syntax
parseTerm)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> Parser ()
reserved Text
"in" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Syntax
parseTerm)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Maybe Polytype -> Syntax -> Term
sDef forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Parser ()
reserved Text
"def" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
identifier)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Text -> Parser Text
symbol Text
":" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Polytype
parsePolytype)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> Parser Text
symbol Text
"=" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Syntax
parseTerm forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> Parser ()
reserved Text
"end")
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. Parser a -> Parser a
parens ([Syntax] -> Term
mkTuple forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser Syntax
parseTerm forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
`sepBy` Text -> Parser Text
symbol Text
","))
)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Term -> Parser Syntax
parseLoc (DelayType -> Term -> Term
TDelay DelayType
SimpleDelay (Const -> Term
TConst Const
Noop) forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Text -> Parser Text
symbol Text
"{" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser Text
symbol Text
"}"))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Term -> Parser Syntax
parseLoc (DelayType -> Syntax -> Term
SDelay DelayType
SimpleDelay forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> Parser a
braces Parser Syntax
parseTerm)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Term -> Parser Syntax
parseLoc (forall r (m :: * -> *). MonadReader r m => m r
ask forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Eq a => a -> a -> Bool
== Antiquoting
AllowAntiquoting)) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Term
parseAntiquotation)
mkTuple :: [Syntax] -> Term
mkTuple :: [Syntax] -> Term
mkTuple [] = Term
TUnit
mkTuple [STerm Term
x] = Term
x
mkTuple (Syntax
x : [Syntax]
xs) = Syntax -> Syntax -> Term
SPair Syntax
x (Term -> Syntax
STerm ([Syntax] -> Term
mkTuple [Syntax]
xs))
sLet :: Var -> Maybe Polytype -> Syntax -> Syntax -> Term
sLet :: Text -> Maybe Polytype -> Syntax -> Syntax -> Term
sLet Text
x Maybe Polytype
ty Syntax
t1 = Bool -> Text -> Maybe Polytype -> Syntax -> Syntax -> Term
SLet (Text
x forall a. Ord a => a -> Set a -> Bool
`S.member` forall a s. Getting (Set a) s a -> s -> Set a
setOf Traversal' Term Text
fv (Syntax -> Term
sTerm Syntax
t1)) Text
x Maybe Polytype
ty Syntax
t1
sDef :: Var -> Maybe Polytype -> Syntax -> Term
sDef :: Text -> Maybe Polytype -> Syntax -> Term
sDef Text
x Maybe Polytype
ty Syntax
t = Bool -> Text -> Maybe Polytype -> Syntax -> Term
SDef (Text
x forall a. Ord a => a -> Set a -> Bool
`S.member` forall a s. Getting (Set a) s a -> s -> Set a
setOf Traversal' Term Text
fv (Syntax -> Term
sTerm Syntax
t)) Text
x Maybe Polytype
ty Syntax
t
parseAntiquotation :: Parser Term
parseAntiquotation :: Parser Term
parseAntiquotation =
Text -> Term
TAntiText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Parser a -> Parser a
lexeme forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try) (Text -> Parser Text
symbol Text
"$str:" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
identifier)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Term
TAntiInt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Parser a -> Parser a
lexeme forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try) (Text -> Parser Text
symbol Text
"$int:" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
identifier)
parseTerm :: Parser Syntax
parseTerm :: Parser Syntax
parseTerm = forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
sepEndBy1 Parser Stmt
parseStmt (Text -> Parser Text
symbol Text
";") forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Stmt] -> Parser Syntax
mkBindChain
mkBindChain :: [Stmt] -> Parser Syntax
mkBindChain :: [Stmt] -> Parser Syntax
mkBindChain [Stmt]
stmts = case forall a. [a] -> a
last [Stmt]
stmts of
Binder Text
x Syntax
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Stmt -> Syntax -> Syntax
mkBind (Term -> Syntax
STerm (Term -> Term -> Term
TApp (Const -> Term
TConst Const
Return) (Text -> Term
TVar Text
x))) [Stmt]
stmts
BareTerm Syntax
t -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Stmt -> Syntax -> Syntax
mkBind Syntax
t (forall a. [a] -> [a]
init [Stmt]
stmts)
where
mkBind :: Stmt -> Syntax -> Syntax
mkBind (BareTerm Syntax
t1) Syntax
t2 = Syntax -> Syntax -> Term -> Syntax
loc Syntax
t1 Syntax
t2 forall a b. (a -> b) -> a -> b
$ Maybe Text -> Syntax -> Syntax -> Term
SBind forall a. Maybe a
Nothing Syntax
t1 Syntax
t2
mkBind (Binder Text
x Syntax
t1) Syntax
t2 = Syntax -> Syntax -> Term -> Syntax
loc Syntax
t1 Syntax
t2 forall a b. (a -> b) -> a -> b
$ Maybe Text -> Syntax -> Syntax -> Term
SBind (forall a. a -> Maybe a
Just Text
x) Syntax
t1 Syntax
t2
loc :: Syntax -> Syntax -> Term -> Syntax
loc Syntax
a Syntax
b = Location -> Term -> Syntax
Syntax forall a b. (a -> b) -> a -> b
$ Syntax -> Location
sLoc Syntax
a forall a. Semigroup a => a -> a -> a
<> Syntax -> Location
sLoc Syntax
b
data Stmt
= BareTerm Syntax
| Binder Text Syntax
deriving (Int -> Stmt -> ShowS
[Stmt] -> ShowS
Stmt -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Stmt] -> ShowS
$cshowList :: [Stmt] -> ShowS
show :: Stmt -> String
$cshow :: Stmt -> String
showsPrec :: Int -> Stmt -> ShowS
$cshowsPrec :: Int -> Stmt -> ShowS
Show)
parseStmt :: Parser Stmt
parseStmt :: Parser Stmt
parseStmt =
Maybe Text -> Syntax -> Stmt
mkStmt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser Text
identifier forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> Parser Text
symbol Text
"<-")) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Syntax
parseExpr
mkStmt :: Maybe Text -> Syntax -> Stmt
mkStmt :: Maybe Text -> Syntax -> Stmt
mkStmt Maybe Text
Nothing = Syntax -> Stmt
BareTerm
mkStmt (Just Text
x) = Text -> Syntax -> Stmt
Binder Text
x
fixDefMissingSemis :: Syntax -> Syntax
fixDefMissingSemis :: Syntax -> Syntax
fixDefMissingSemis Syntax
term =
case Syntax -> [Syntax] -> [Syntax]
nestedDefs Syntax
term [] of
[] -> Syntax
term
[Syntax]
defs -> forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Syntax -> Syntax -> Syntax
mkBind [Syntax]
defs
where
mkBind :: Syntax -> Syntax -> Syntax
mkBind Syntax
t1 Syntax
t2 = Location -> Term -> Syntax
Syntax (Syntax -> Location
sLoc Syntax
t1 forall a. Semigroup a => a -> a -> a
<> Syntax -> Location
sLoc Syntax
t2) forall a b. (a -> b) -> a -> b
$ Maybe Text -> Syntax -> Syntax -> Term
SBind forall a. Maybe a
Nothing Syntax
t1 Syntax
t2
nestedDefs :: Syntax -> [Syntax] -> [Syntax]
nestedDefs Syntax
term' [Syntax]
acc = case Syntax
term' of
def :: Syntax
def@(Syntax Location
_ SDef {}) -> Syntax
def forall a. a -> [a] -> [a]
: [Syntax]
acc
(Syntax Location
_ (SApp Syntax
nestedTerm def :: Syntax
def@(Syntax Location
_ SDef {}))) -> Syntax -> [Syntax] -> [Syntax]
nestedDefs Syntax
nestedTerm (Syntax
def forall a. a -> [a] -> [a]
: [Syntax]
acc)
Syntax
_ -> []
parseExpr :: Parser Syntax
parseExpr :: Parser Syntax
parseExpr = Syntax -> Syntax
fixDefMissingSemis forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
MonadPlus m =>
m a -> [[Operator m a]] -> m a
makeExprParser Parser Syntax
parseTermAtom [[Operator (ReaderT Antiquoting (Parsec Void Text)) Syntax]]
table
where
table :: [[Operator (ReaderT Antiquoting (Parsec Void Text)) Syntax]]
table = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [(k, a)]
Map.toDescList Map Int [Operator (ReaderT Antiquoting (Parsec Void Text)) Syntax]
tableMap
tableMap :: Map Int [Operator (ReaderT Antiquoting (Parsec Void Text)) Syntax]
tableMap =
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith
forall a. [a] -> [a] -> [a]
(++)
[ forall k a. k -> a -> Map k a
Map.singleton Int
9 [forall (m :: * -> *) a. m (a -> a -> a) -> Operator m a
InfixL (ReaderT Antiquoting (Parsec Void Text) (Syntax -> Syntax -> Term)
-> Parser (Syntax -> Syntax -> Syntax)
exprLoc2 forall a b. (a -> b) -> a -> b
$ Syntax -> Syntax -> Term
SApp forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"")]
, Map Int [Operator (ReaderT Antiquoting (Parsec Void Text)) Syntax]
binOps
, Map Int [Operator (ReaderT Antiquoting (Parsec Void Text)) Syntax]
unOps
]
exprLoc2 :: Parser (Syntax -> Syntax -> Term) -> Parser (Syntax -> Syntax -> Syntax)
exprLoc2 :: ReaderT Antiquoting (Parsec Void Text) (Syntax -> Syntax -> Term)
-> Parser (Syntax -> Syntax -> Syntax)
exprLoc2 ReaderT Antiquoting (Parsec Void Text) (Syntax -> Syntax -> Term)
p = do
(Location
l, Syntax -> Syntax -> Term
f) <- forall a. Parser a -> Parser (Location, a)
parseLocG ReaderT Antiquoting (Parsec Void Text) (Syntax -> Syntax -> Term)
p
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ \Syntax
s1 Syntax
s2 -> Location -> Term -> Syntax
Syntax (Location
l forall a. Semigroup a => a -> a -> a
<> Syntax -> Location
sLoc Syntax
s1 forall a. Semigroup a => a -> a -> a
<> Syntax -> Location
sLoc Syntax
s2) forall a b. (a -> b) -> a -> b
$ Syntax -> Syntax -> Term
f Syntax
s1 Syntax
s2
binOps :: Map.Map Int [Operator Parser Syntax]
binOps :: Map Int [Operator (ReaderT Antiquoting (Parsec Void Text)) Syntax]
binOps = forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {m :: * -> *}.
MonadFail m =>
Const
-> m (Map
Int [Operator (ReaderT Antiquoting (Parsec Void Text)) Syntax])
binOpToTuple [Const]
allConst
where
binOpToTuple :: Const
-> m (Map
Int [Operator (ReaderT Antiquoting (Parsec Void Text)) Syntax])
binOpToTuple Const
c = do
let ci :: ConstInfo
ci = Const -> ConstInfo
constInfo Const
c
ConstMBinOp MBinAssoc
assoc <- forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConstInfo -> ConstMeta
constMeta ConstInfo
ci)
let assI :: Parser (Syntax -> Syntax -> Syntax)
-> Operator (ReaderT Antiquoting (Parsec Void Text)) Syntax
assI = case MBinAssoc
assoc of
MBinAssoc
L -> forall (m :: * -> *) a. m (a -> a -> a) -> Operator m a
InfixL
MBinAssoc
N -> forall (m :: * -> *) a. m (a -> a -> a) -> Operator m a
InfixN
MBinAssoc
R -> forall (m :: * -> *) a. m (a -> a -> a) -> Operator m a
InfixR
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
forall k a. k -> a -> Map k a
Map.singleton
(ConstInfo -> Int
fixity ConstInfo
ci)
[Parser (Syntax -> Syntax -> Syntax)
-> Operator (ReaderT Antiquoting (Parsec Void Text)) Syntax
assI (Const -> Syntax -> Syntax -> Syntax
mkOp Const
c forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
operatorString (ConstInfo -> Text
syntax ConstInfo
ci))]
unOps :: Map.Map Int [Operator Parser Syntax]
unOps :: Map Int [Operator (ReaderT Antiquoting (Parsec Void Text)) Syntax]
unOps = forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {m :: * -> *}.
MonadFail m =>
Const
-> m (Map
Int [Operator (ReaderT Antiquoting (Parsec Void Text)) Syntax])
unOpToTuple [Const]
allConst
where
unOpToTuple :: Const
-> m (Map
Int [Operator (ReaderT Antiquoting (Parsec Void Text)) Syntax])
unOpToTuple Const
c = do
let ci :: ConstInfo
ci = Const -> ConstInfo
constInfo Const
c
ConstMUnOp MUnAssoc
assoc <- forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConstInfo -> ConstMeta
constMeta ConstInfo
ci)
let assI :: ReaderT Antiquoting (Parsec Void Text) (Syntax -> Syntax)
-> Operator (ReaderT Antiquoting (Parsec Void Text)) Syntax
assI = case MUnAssoc
assoc of
MUnAssoc
P -> forall (m :: * -> *) a. m (a -> a) -> Operator m a
Prefix
MUnAssoc
S -> forall (m :: * -> *) a. m (a -> a) -> Operator m a
Postfix
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
forall k a. k -> a -> Map k a
Map.singleton
(ConstInfo -> Int
fixity ConstInfo
ci)
[ReaderT Antiquoting (Parsec Void Text) (Syntax -> Syntax)
-> Operator (ReaderT Antiquoting (Parsec Void Text)) Syntax
assI (ReaderT Antiquoting (Parsec Void Text) (Syntax -> Term)
-> ReaderT Antiquoting (Parsec Void Text) (Syntax -> Syntax)
exprLoc1 forall a b. (a -> b) -> a -> b
$ Syntax -> Syntax -> Term
SApp (Term -> Syntax
noLoc forall a b. (a -> b) -> a -> b
$ Const -> Term
TConst Const
c) forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
operatorString (ConstInfo -> Text
syntax ConstInfo
ci))]
exprLoc1 :: Parser (Syntax -> Term) -> Parser (Syntax -> Syntax)
exprLoc1 :: ReaderT Antiquoting (Parsec Void Text) (Syntax -> Term)
-> ReaderT Antiquoting (Parsec Void Text) (Syntax -> Syntax)
exprLoc1 ReaderT Antiquoting (Parsec Void Text) (Syntax -> Term)
p = do
(Location
l, Syntax -> Term
f) <- forall a. Parser a -> Parser (Location, a)
parseLocG ReaderT Antiquoting (Parsec Void Text) (Syntax -> Term)
p
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ \Syntax
s -> Location -> Term -> Syntax
Syntax (Location
l forall a. Semigroup a => a -> a -> a
<> Syntax -> Location
sLoc Syntax
s) forall a b. (a -> b) -> a -> b
$ Syntax -> Term
f Syntax
s
operatorString :: Text -> Parser Text
operatorString :: Text -> Parser Text
operatorString Text
n = (forall a. Parser a -> Parser a
lexeme forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try) (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Text
n forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy Parser Text
operatorSymbol)
operatorSymbol :: Parser Text
operatorSymbol :: Parser Text
operatorSymbol = Char -> Text
T.singleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf [Token Text]
opChars
where
isOp :: ConstInfo -> Bool
isOp = \case { ConstMFunc {} -> Bool
False; ConstMeta
_ -> Bool
True } forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstInfo -> ConstMeta
constMeta
opChars :: [Token Text]
opChars = forall a. Eq a => [a] -> [a]
nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall source target. From source target => source -> target
from forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstInfo -> Text
syntax) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ConstInfo -> Bool
isOp forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Const -> ConstInfo
constInfo [Const]
allConst
runParser :: Parser a -> Text -> Either Text a
runParser :: forall a. Parser a -> Text -> Either Text a
runParser Parser a
p Text
t = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall source target. From source target => source -> target
from forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty) (forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Parser a
p Antiquoting
DisallowAntiquoting) String
"" Text
t)
runParserTH :: (Monad m, MonadFail m) => (String, Int, Int) -> Parser a -> String -> m a
runParserTH :: forall (m :: * -> *) a.
(Monad m, MonadFail m) =>
(String, Int, Int) -> Parser a -> String -> m a
runParserTH (String
file, Int
line, Int
col) Parser a
p String
s =
case forall a b. (a, b) -> b
snd (forall e s a.
Parsec e s a
-> State s e -> (State s e, Either (ParseErrorBundle s e) a)
runParser' (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall a. Parser a -> Parser a
fully Parser a
p) Antiquoting
AllowAntiquoting) State Text Void
initState) of
Left ParseErrorBundle Text Void
err -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty ParseErrorBundle Text Void
err
Right a
e -> forall (m :: * -> *) a. Monad m => a -> m a
return a
e
where
initState :: State Text Void
initState :: State Text Void
initState =
State
{ stateInput :: Text
stateInput = forall source target. From source target => source -> target
from String
s
, stateOffset :: Int
stateOffset = Int
0
, statePosState :: PosState Text
statePosState =
PosState
{ pstateInput :: Text
pstateInput = forall source target. From source target => source -> target
from String
s
, pstateOffset :: Int
pstateOffset = Int
0
, pstateSourcePos :: SourcePos
pstateSourcePos = String -> Pos -> Pos -> SourcePos
SourcePos String
file (Int -> Pos
mkPos Int
line) (Int -> Pos
mkPos Int
col)
, pstateTabWidth :: Pos
pstateTabWidth = Pos
defaultTabWidth
, pstateLinePrefix :: String
pstateLinePrefix = String
""
}
, stateParseErrors :: [ParseError Text Void]
stateParseErrors = []
}
fully :: Parser a -> Parser a
fully :: forall a. Parser a -> Parser a
fully Parser a
p = Parser ()
sc forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser a
p forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
fullyMaybe :: Parser a -> Parser (Maybe a)
fullyMaybe :: forall a. Parser a -> Parser (Maybe a)
fullyMaybe = forall a. Parser a -> Parser a
fully forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional
readTerm :: Text -> Either Text (Maybe Syntax)
readTerm :: Text -> Either Text (Maybe Syntax)
readTerm = forall a. Parser a -> Text -> Either Text a
runParser (forall a. Parser a -> Parser (Maybe a)
fullyMaybe Parser Syntax
parseTerm)
readTerm' :: Text -> Either ParserError (Maybe Syntax)
readTerm' :: Text -> Either (ParseErrorBundle Text Void) (Maybe Syntax)
readTerm' = forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall a. Parser a -> Parser (Maybe a)
fullyMaybe Parser Syntax
parseTerm) Antiquoting
DisallowAntiquoting) String
""
showShortError :: ParserError -> String
showShortError :: ParseErrorBundle Text Void -> String
showShortError ParseErrorBundle Text Void
pe = forall a. Show a => a -> String
show (Int
line forall a. Num a => a -> a -> a
+ Int
1) forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> forall source target. From source target => source -> target
from Text
msg
where
((Int
line, Int
_), (Int, Int)
_, Text
msg) = ParseErrorBundle Text Void -> ((Int, Int), (Int, Int), Text)
showErrorPos ParseErrorBundle Text Void
pe
showErrorPos :: ParserError -> ((Int, Int), (Int, Int), Text)
showErrorPos :: ParseErrorBundle Text Void -> ((Int, Int), (Int, Int), Text)
showErrorPos (ParseErrorBundle NonEmpty (ParseError Text Void)
errs PosState Text
sourcePS) = (forall {a} {b}. (Num a, Num b) => (a, b) -> (a, b)
minusOne (Int, Int)
start, forall {a} {b}. (Num a, Num b) => (a, b) -> (a, b)
minusOne (Int, Int)
end, forall source target. From source target => source -> target
from String
msg)
where
minusOne :: (a, b) -> (a, b)
minusOne (a
x, b
y) = (a
x forall a. Num a => a -> a -> a
- a
1, b
y forall a. Num a => a -> a -> a
- b
1)
err :: ParseError Text Void
err = forall a. NonEmpty a -> a
Data.List.NonEmpty.head NonEmpty (ParseError Text Void)
errs
offset :: Int
offset = case ParseError Text Void
err of
TrivialError Int
x Maybe (ErrorItem (Token Text))
_ Set (ErrorItem (Token Text))
_ -> Int
x
FancyError Int
x Set (ErrorFancy Void)
_ -> Int
x
(Maybe String
str, PosState Text
ps) = forall s.
TraversableStream s =>
Int -> PosState s -> (Maybe String, PosState s)
reachOffset Int
offset PosState Text
sourcePS
msg :: String
msg = forall s e.
(VisualStream s, ShowErrorComponent e) =>
ParseError s e -> String
parseErrorTextPretty ParseError Text Void
err
start :: (Int, Int)
start@(Int
line, Int
col) = forall a. PosState a -> (Int, Int)
getLineCol PosState Text
ps
wordlength :: Int
wordlength = case forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
' ') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
col forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
str of
Just (String
word, String
_) -> forall (t :: * -> *) a. Foldable t => t a -> Int
length String
word forall a. Num a => a -> a -> a
+ Int
1
Maybe (String, String)
_ -> Int
0
end :: (Int, Int)
end = (Int
line, Int
col forall a. Num a => a -> a -> a
+ Int
wordlength)
getLineCol :: PosState a -> (Int, Int)
getLineCol :: forall a. PosState a -> (Int, Int)
getLineCol PosState a
ps = (Int
line, Int
col)
where
line :: Int
line = Pos -> Int
unPos forall a b. (a -> b) -> a -> b
$ SourcePos -> Pos
sourceLine forall a b. (a -> b) -> a -> b
$ forall s. PosState s -> SourcePos
pstateSourcePos PosState a
ps
col :: Int
col = Pos -> Int
unPos forall a b. (a -> b) -> a -> b
$ SourcePos -> Pos
sourceColumn forall a b. (a -> b) -> a -> b
$ forall s. PosState s -> SourcePos
pstateSourcePos PosState a
ps
getLocRange :: Text -> (Int, Int) -> ((Int, Int), (Int, Int))
getLocRange :: Text -> (Int, Int) -> ((Int, Int), (Int, Int))
getLocRange Text
code (Int
locStart, Int
locEnd) = ((Int, Int)
start, (Int, Int)
end)
where
start :: (Int, Int)
start = Int -> (Int, Int)
getLocPos Int
locStart
end :: (Int, Int)
end = Int -> (Int, Int)
getLocPos (Int -> Int
dropWhiteSpace Int
locEnd)
dropWhiteSpace :: Int -> Int
dropWhiteSpace Int
offset
| Int -> Bool
isWhiteSpace Int
offset = Int -> Int
dropWhiteSpace (Int
offset forall a. Num a => a -> a -> a
- Int
1)
| Bool
otherwise = Int
offset
isWhiteSpace :: Int -> Bool
isWhiteSpace Int
offset =
Text -> Int -> Char
Data.Text.index Text
code (Int
offset forall a. Num a => a -> a -> a
- Int
1) forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
' ', Char
'\n', Char
'\r', Char
'\t']
getLocPos :: Int -> (Int, Int)
getLocPos Int
offset =
let sourcePS :: PosState Text
sourcePS =
PosState
{ pstateInput :: Text
pstateInput = Text
code
, pstateOffset :: Int
pstateOffset = Int
0
, pstateSourcePos :: SourcePos
pstateSourcePos = String -> SourcePos
Pos.initialPos String
""
, pstateTabWidth :: Pos
pstateTabWidth = Pos
Pos.defaultTabWidth
, pstateLinePrefix :: String
pstateLinePrefix = String
""
}
(Maybe String
_, PosState Text
ps) = forall s.
TraversableStream s =>
Int -> PosState s -> (Maybe String, PosState s)
reachOffset Int
offset PosState Text
sourcePS
in forall a. PosState a -> (Int, Int)
getLineCol PosState Text
ps