{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
module Swarm.Language.Parse (
reservedWords,
Parser,
parsePolytype,
parseType,
parseTerm,
binOps,
unOps,
runParser,
runParserTH,
readTerm,
readTerm',
showShortError,
showErrorPos,
getLocRange,
unTuple,
) where
import Control.Lens (view, (^.))
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
"void"
, Text
"unit"
, Text
"int"
, Text
"text"
, Text
"dir"
, Text
"bool"
, Text
"actor"
, 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 Var
identifier :: Parser Text
identifier = LocVar -> Text
lvVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser LocVar
locIdentifier
locIdentifier :: Parser LocVar
locIdentifier :: Parser LocVar
locIdentifier = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry SrcLoc -> Text -> LocVar
LV forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> Parser (SrcLoc, a)
parseLocG ((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
TyVoid forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser ()
reserved Text
"void"
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> 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
TyActor forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser ()
reserved Text
"actor"
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 (SrcLoc, a)
parseLocG :: forall a. Parser a -> Parser (SrcLoc, 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 -> SrcLoc
SrcLoc 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 SrcLoc -> Term' () -> Syntax' ()
Syntax forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> Parser (SrcLoc, a)
parseLocG Parser (Term' ())
pterm
parseTermAtom :: Parser Syntax
parseTermAtom :: Parser (Syntax' ())
parseTermAtom =
Parser (Term' ()) -> Parser (Syntax' ())
parseLoc
( forall ty. Term' ty
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
<|> forall ty. Const -> Term' ty
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
<|> forall ty. Text -> Term' ty
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
<|> forall ty. Direction -> Term' ty
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
<|> forall ty. Integer -> Term' ty
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
<|> forall ty. Text -> Term' ty
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
<|> forall ty. Bool -> Term' ty
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
*> ( ( forall ty. Text -> Term' ty
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
<|> ( forall ty. Int -> Text -> Term' ty
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
<|> forall ty. LocVar -> Maybe Type -> Syntax' ty -> Term' ty
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 LocVar
locIdentifier)
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
<|> LocVar -> 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 LocVar
locIdentifier)
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
<|> LocVar -> 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 LocVar
locIdentifier)
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 (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall ty. Lens' (Syntax' ty) (Term' ty)
sTerm forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Syntax' ()] -> Syntax' ()
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 (forall ty. Const -> Term' ty
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 (forall ty. DelayType -> Syntax' ty -> Term' ty
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] -> Syntax
mkTuple :: [Syntax' ()] -> Syntax' ()
mkTuple [] = SrcLoc -> Term' () -> Syntax' ()
Syntax SrcLoc
NoLoc forall ty. Term' ty
TUnit
mkTuple [Syntax' ()
x] = Syntax' ()
x
mkTuple (Syntax' ()
x : [Syntax' ()]
xs) = let r :: Syntax' ()
r = [Syntax' ()] -> Syntax' ()
mkTuple [Syntax' ()]
xs in forall {ty} {ty}.
Syntax' ty -> Syntax' ty -> Term' () -> Syntax' ()
loc Syntax' ()
x Syntax' ()
r forall a b. (a -> b) -> a -> b
$ forall ty. Syntax' ty -> Syntax' ty -> Term' ty
SPair Syntax' ()
x Syntax' ()
r
where
loc :: Syntax' ty -> Syntax' ty -> Term' () -> Syntax' ()
loc Syntax' ty
a Syntax' ty
b = SrcLoc -> Term' () -> Syntax' ()
Syntax forall a b. (a -> b) -> a -> b
$ (Syntax' ty
a forall s a. s -> Getting a s a -> a
^. forall ty. Lens' (Syntax' ty) SrcLoc
sLoc) forall a. Semigroup a => a -> a -> a
<> (Syntax' ty
b forall s a. s -> Getting a s a -> a
^. forall ty. Lens' (Syntax' ty) SrcLoc
sLoc)
unTuple :: Syntax' ty -> [Syntax' ty]
unTuple :: forall ty. Syntax' ty -> [Syntax' ty]
unTuple = \case
Syntax' SrcLoc
_ (SPair Syntax' ty
s1 Syntax' ty
s2) ty
_ -> Syntax' ty
s1 forall a. a -> [a] -> [a]
: forall ty. Syntax' ty -> [Syntax' ty]
unTuple Syntax' ty
s2
Syntax' ty
s -> [Syntax' ty
s]
sLet :: LocVar -> Maybe Polytype -> Syntax -> Syntax -> Term
sLet :: LocVar -> Maybe Polytype -> Syntax' () -> Syntax' () -> Term' ()
sLet LocVar
x Maybe Polytype
ty Syntax' ()
t1 = forall ty.
Bool
-> LocVar -> Maybe Polytype -> Syntax' ty -> Syntax' ty -> Term' ty
SLet (LocVar -> Text
lvVar LocVar
x forall a. Ord a => a -> Set a -> Bool
`S.member` forall a s. Getting (Set a) s a -> s -> Set a
setOf forall ty. Traversal' (Syntax' ty) Text
freeVarsV Syntax' ()
t1) LocVar
x Maybe Polytype
ty Syntax' ()
t1
sDef :: LocVar -> Maybe Polytype -> Syntax -> Term
sDef :: LocVar -> Maybe Polytype -> Syntax' () -> Term' ()
sDef LocVar
x Maybe Polytype
ty Syntax' ()
t = forall ty.
Bool -> LocVar -> Maybe Polytype -> Syntax' ty -> Term' ty
SDef (LocVar -> Text
lvVar LocVar
x forall a. Ord a => a -> Set a -> Bool
`S.member` forall a s. Getting (Set a) s a -> s -> Set a
setOf forall ty. Traversal' (Syntax' ty) Text
freeVarsV Syntax' ()
t) LocVar
x Maybe Polytype
ty Syntax' ()
t
parseAntiquotation :: Parser Term
parseAntiquotation :: Parser (Term' ())
parseAntiquotation =
forall ty. Text -> Term' ty
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
<|> forall ty. Text -> Term' ty
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 LocVar
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 (forall ty. Const -> Term' ty
TConst Const
Return) (forall ty. Text -> Term' ty
TVar (LocVar -> Text
lvVar LocVar
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 = forall {ty} {ty}.
Maybe LocVar -> Syntax' ty -> Syntax' ty -> Term' () -> Syntax' ()
loc forall a. Maybe a
Nothing Syntax' ()
t1 Syntax' ()
t2 forall a b. (a -> b) -> a -> b
$ forall ty. Maybe LocVar -> Syntax' ty -> Syntax' ty -> Term' ty
SBind forall a. Maybe a
Nothing Syntax' ()
t1 Syntax' ()
t2
mkBind (Binder LocVar
x Syntax' ()
t1) Syntax' ()
t2 = forall {ty} {ty}.
Maybe LocVar -> Syntax' ty -> Syntax' ty -> Term' () -> Syntax' ()
loc (forall a. a -> Maybe a
Just LocVar
x) Syntax' ()
t1 Syntax' ()
t2 forall a b. (a -> b) -> a -> b
$ forall ty. Maybe LocVar -> Syntax' ty -> Syntax' ty -> Term' ty
SBind (forall a. a -> Maybe a
Just LocVar
x) Syntax' ()
t1 Syntax' ()
t2
loc :: Maybe LocVar -> Syntax' ty -> Syntax' ty -> Term' () -> Syntax' ()
loc Maybe LocVar
mx Syntax' ty
a Syntax' ty
b = SrcLoc -> Term' () -> Syntax' ()
Syntax forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe SrcLoc
NoLoc LocVar -> SrcLoc
lvSrcLoc Maybe LocVar
mx forall a. Semigroup a => a -> a -> a
<> (Syntax' ty
a forall s a. s -> Getting a s a -> a
^. forall ty. Lens' (Syntax' ty) SrcLoc
sLoc) forall a. Semigroup a => a -> a -> a
<> (Syntax' ty
b forall s a. s -> Getting a s a -> a
^. forall ty. Lens' (Syntax' ty) SrcLoc
sLoc)
data Stmt
= BareTerm Syntax
| Binder LocVar 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 LocVar -> 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 LocVar
locIdentifier 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 LocVar -> Syntax -> Stmt
mkStmt :: Maybe LocVar -> Syntax' () -> Stmt
mkStmt Maybe LocVar
Nothing = Syntax' () -> Stmt
BareTerm
mkStmt (Just LocVar
x) = LocVar -> Syntax' () -> Stmt
Binder LocVar
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 = SrcLoc -> Term' () -> Syntax' ()
Syntax ((Syntax' ()
t1 forall s a. s -> Getting a s a -> a
^. forall ty. Lens' (Syntax' ty) SrcLoc
sLoc) forall a. Semigroup a => a -> a -> a
<> (Syntax' ()
t2 forall s a. s -> Getting a s a -> a
^. forall ty. Lens' (Syntax' ty) SrcLoc
sLoc)) forall a b. (a -> b) -> a -> b
$ forall ty. Maybe LocVar -> Syntax' ty -> Syntax' ty -> Term' ty
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 SrcLoc
_ SDef {}) -> Syntax' ()
def forall a. a -> [a] -> [a]
: [Syntax' ()]
acc
(Syntax SrcLoc
_ (SApp Syntax' ()
nestedTerm def :: Syntax' ()
def@(Syntax SrcLoc
_ 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
$ forall ty. Syntax' ty -> Syntax' ty -> Term' ty
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
(SrcLoc
l, Syntax' () -> Syntax' () -> Term' ()
f) <- forall a. Parser a -> Parser (SrcLoc, 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 -> SrcLoc -> Term' () -> Syntax' ()
Syntax (SrcLoc
l forall a. Semigroup a => a -> a -> a
<> (Syntax' ()
s1 forall s a. s -> Getting a s a -> a
^. forall ty. Lens' (Syntax' ty) SrcLoc
sLoc) forall a. Semigroup a => a -> a -> a
<> (Syntax' ()
s2 forall s a. s -> Getting a s a -> a
^. forall ty. Lens' (Syntax' ty) SrcLoc
sLoc)) 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
$ forall ty. Syntax' ty -> Syntax' ty -> Term' ty
SApp (Term' () -> Syntax' ()
noLoc forall a b. (a -> b) -> a -> b
$ forall ty. Const -> Term' ty
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
(SrcLoc
l, Syntax' () -> Term' ()
f) <- forall a. Parser a -> Parser (SrcLoc, 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 -> SrcLoc -> Term' () -> Syntax' ()
Syntax (SrcLoc
l forall a. Semigroup a => a -> a -> a
<> Syntax' ()
s forall s a. s -> Getting a s a -> a
^. forall ty. Lens' (Syntax' ty) SrcLoc
sLoc) 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