{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Parser for the Swarm language.  Note, you probably don't want to
-- use this directly, unless there is a good reason to parse a term
-- without also type checking it; use
-- 'Swarm.Language.Pipeline.processTerm' instead, which parses,
-- typechecks, elaborates, and capability checks a term all at once.
module Swarm.Language.Parse (
  -- * Reserved words
  reservedWords,

  -- * Parsers
  Parser,
  parsePolytype,
  parseType,
  parseTerm,
  binOps,
  unOps,

  -- * Utility functions
  runParser,
  runParserTH,
  readTerm,
  readTerm',
  showShortError,
  showErrorPos,
  getLocRange,
  unTuple,
) where

import Control.Lens (view, (^.))
import Control.Monad (guard, join)
import Control.Monad.Combinators.Expr
import Control.Monad.Reader (
  MonadReader (ask),
  ReaderT (runReaderT),
 )
import Data.Bifunctor
import Data.Foldable (asum)
import Data.List (foldl', nub)
import Data.List.NonEmpty qualified (head)
import Data.Map.Strict (Map)
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 Swarm.Util (failT, findDup, squote)
import Swarm.Util.Parse (fully, fullyMaybe)
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

-- Imports for doctests (cabal-docspec needs this)

-- $setup
-- >>> import qualified Data.Map.Strict as Map

-- | When parsing a term using a quasiquoter (i.e. something in the
--   Swarm source code that will be parsed at compile time), we want
--   to allow antiquoting, i.e. writing something like $x to refer to
--   an existing Haskell variable.  But when parsing a term entered by
--   the user at the REPL, we do not want to allow this syntax.
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

--------------------------------------------------
-- Lexer

-- | List of reserved words that cannot be used as variable names.
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 Direction -> Text
directionSyntax [Direction]
allDirs
    forall a. [a] -> [a] -> [a]
++ [ Text
"void"
       , Text
"unit"
       , Text
"int"
       , Text
"text"
       , Text
"dir"
       , Text
"bool"
       , Text
"actor"
       , Text
"key"
       , Text
"cmd"
       , Text
"delay"
       , Text
"let"
       , Text
"def"
       , Text
"end"
       , Text
"in"
       , Text
"true"
       , Text
"false"
       , Text
"forall"
       , Text
"require"
       , Text
"requirements"
       ]

-- | Skip spaces and comments.
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 =>
Tokens s -> Tokens s -> m ()
L.skipBlockComment Tokens Text
"/*" Tokens Text
"*/")

-- | In general, we follow the convention that every token parser
--   assumes no leading whitespace and consumes all trailing
--   whitespace.  Concretely, we achieve this by wrapping every token
--   parser using 'lexeme'.
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

-- | A lexeme consisting of a literal string.
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

-- | Parse a case-insensitive reserved word, making sure it is not a
--   prefix of a longer variable name, and allowing the parser to
--   backtrack if it fails.
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
'_')

-- | Parse an identifier, i.e. any non-reserved string containing
--   alphanumeric characters and underscores and not starting with a
--   number.
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

-- | Parse an identifier together with its source location info.
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 {source} {m :: * -> *}.
(From source Text, MonadFail m) =>
source -> 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 :: source -> m Text
check (forall target source. From source target => source -> target
into @Text -> Text
t)
    | Text -> Text
toLower Text
t forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
reservedWords =
        forall (m :: * -> *) a. MonadFail m => [Text] -> m a
failT [Text
"reserved word", Text -> Text
squote Text
t, Text
"cannot be used as variable name"]
    | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return Text
t

-- | Parse a text literal (including escape sequences) in double quotes.
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
'"'))

-- | Parse a positive integer literal token, in decimal, binary,
--   octal, or hexadecimal notation.  Note that negation is handled as
--   a separate operator.
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
")")

brackets :: Parser a -> Parser a
brackets :: forall a. Parser a -> Parser a
brackets = 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
"]")

--------------------------------------------------
-- Parser

-- | Parse a Swarm language polytype, which starts with an optional
--   quanitifation (@forall@ followed by one or more variables and a
--   period) followed by a type.  Note that anything accepted by
--   'parseType' is also accepted by 'parsePolytype'.
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
    -- Iplicitly quantify over free type variables if the user didn't write a forall
    | 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
    -- Otherwise, require all variables to be explicitly quantified
    | 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

-- | Parse a Swarm language (mono)type.
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
TyKey forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser ()
reserved Text
"key"
    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
<|> Map Text Type -> Type
TyRcd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> Parser a
brackets (forall a. Parser a -> Parser (Map Text a)
parseRecord (Text -> Parser Text
symbol Text
":" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Type
parseType))
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. Parser a -> Parser a
parens Parser Type
parseType

parseRecord :: Parser a -> Parser (Map Var a)
parseRecord :: forall a. Parser a -> Parser (Map Text a)
parseRecord Parser a
p = (ReaderT Antiquoting (Parsec Void Text) (Text, a)
parseBinding forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
`sepBy` Text -> Parser Text
symbol Text
",") forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {m :: * -> *} {a}.
MonadFail m =>
[(Text, a)] -> m (Map Text a)
fromListUnique
 where
  parseBinding :: ReaderT Antiquoting (Parsec Void Text) (Text, a)
parseBinding = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
identifier forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser a
p
  fromListUnique :: [(Text, a)] -> m (Map Text a)
fromListUnique [(Text, a)]
kvs = case forall a. Ord a => [a] -> Maybe a
findDup (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Text, a)]
kvs) of
    Maybe Text
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, a)]
kvs
    Just Text
x -> forall (m :: * -> *) a. MonadFail m => [Text] -> m a
failT [Text
"duplicate field name", Text -> Text
squote Text
x, Text
"in record literal"]

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
. Direction -> Text
directionSyntax) Direction
d

-- | Parse Const as reserved words (e.g. @Fail <$ reserved "fail"@)
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)

-- | Add 'SrcLoc' to a parser
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)

-- | Add 'SrcLoc' to a 'Term' parser
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

-- | Parse an atomic term, optionally trailed by record projections like @t.x.y.z@.
--   Record projection binds more tightly than function application.
parseTermAtom :: Parser Syntax
parseTermAtom :: Parser (Syntax' ())
parseTermAtom = do
  Syntax' ()
s1 <- Parser (Syntax' ())
parseTermAtom2
  [(SrcLoc, Text)]
ps <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (Text -> Parser Text
symbol Text
"." forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. Parser a -> Parser (SrcLoc, a)
parseLocG Parser Text
identifier)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\(Syntax SrcLoc
l1 Term' ()
t) (SrcLoc
l2, Text
x) -> SrcLoc -> Term' () -> Syntax' ()
Syntax (SrcLoc
l1 forall a. Semigroup a => a -> a -> a
<> SrcLoc
l2) (Term' () -> Text -> Term' ()
TProj Term' ()
t Text
x)) Syntax' ()
s1 [(SrcLoc, Text)]
ps

-- | Parse an atomic term.
parseTermAtom2 :: Parser Syntax
parseTermAtom2 :: Parser (Syntax' ())
parseTermAtom2 =
  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 a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall ty. Text -> Syntax' ty -> Term' ty
SRequirements forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Parser ()
reserved Text
"requirements" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> m (Tokens s, a)
match Parser (Syntax' ())
parseTerm)
        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 ty. Map Text (Maybe (Syntax' ty)) -> Term' ty
SRcd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> Parser a
brackets (forall a. Parser a -> Parser (Map Text a)
parseRecord (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 (Syntax' ())
parseTerm)))
        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
","))
    )
    -- Potential syntax for explicitly requesting memoized delay.
    -- Perhaps we will not need this in the end; see the discussion at
    -- https://github.com/swarm-game/swarm/issues/150 .
    -- <|> parseLoc (TDelay SimpleDelay (TConst Noop) <$ try (symbol "{{" *> symbol "}}"))
    -- <|> parseLoc (SDelay MemoizedDelay <$> dbraces parseTerm)

    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 -- should never happen
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]

-- | Construct an 'SLet', automatically filling in the Boolean field
--   indicating whether it is recursive.
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

-- | Construct an 'SDef', automatically filling in the Boolean field
--   indicating whether it is recursive.
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)

-- | Parse a Swarm language term.
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

-- | When semicolons are missing between definitions, for example:
--     def a = 1 end def b = 2 end def c = 3 end
--   The makeExprParser produces:
--     App (App (TDef a) (TDef b)) (TDef x)
--   This function fix that by converting the Apps into Binds, so that it results in:
--     Bind a (Bind b (Bind c))
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)
    -- Otherwise returns an empty list to keep the term unchanged
    Syntax' ()
_ -> []

parseExpr :: Parser Syntax
parseExpr :: Parser (Syntax' ())
parseExpr =
  Parser (Term' ()) -> Parser (Syntax' ())
parseLoc forall a b. (a -> b) -> a -> b
$ Syntax' () -> Maybe Polytype -> Term' ()
ascribe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Syntax' ())
parseExpr' 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)
 where
  ascribe :: Syntax -> Maybe Polytype -> Term
  ascribe :: Syntax' () -> Maybe Polytype -> Term' ()
ascribe Syntax' ()
s Maybe Polytype
Nothing = Syntax' ()
s forall s a. s -> Getting a s a -> a
^. forall ty. Lens' (Syntax' ty) (Term' ty)
sTerm
  ascribe Syntax' ()
s (Just Polytype
ty) = forall ty. Syntax' ty -> Polytype -> Term' ty
SAnnotate Syntax' ()
s Polytype
ty

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
      ]

  -- add location for ExprParser by combining all
  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

-- | Precedences and parsers of binary operators.
--
-- >>> Map.map length binOps
-- fromList [(0,1),(2,1),(3,1),(4,6),(6,3),(7,2),(8,1)]
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))]

-- | Precedences and parsers of unary operators (currently only 'Neg').
--
-- >>> Map.map length unOps
-- fromList [(7,1)]
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))]

  -- combine location for ExprParser
  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

--------------------------------------------------
-- Utilities

-- | Run a parser on some input text, returning either the result or a
--   pretty-printed parse error message.
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)

-- | A utility for running a parser in an arbitrary 'MonadFail' (which
--   is going to be the TemplateHaskell 'Language.Haskell.TH.Q' monad --- see
--   "Swarm.Language.Parse.QQ"), with a specified source position.
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 e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
fully Parser ()
sc 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
  -- This is annoying --- megaparsec does not export its function to
  -- construct an initial parser state, so we can't just use that
  -- and then change the one field we need to be different (the
  -- 'pstateSourcePos'). We have to copy-paste the whole thing.
  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 = []
      }

-- | Parse some input 'Text' completely as a 'Term', consuming leading
--   whitespace and ensuring the parsing extends all the way to the
--   end of the input 'Text'.  Returns either the resulting 'Term' (or
--   'Nothing' if the input was only whitespace) or a pretty-printed
--   parse error message.
readTerm :: Text -> Either Text (Maybe Syntax)
readTerm :: Text -> Either Text (Maybe (Syntax' ()))
readTerm = forall a. Parser a -> Text -> Either Text a
runParser (forall e s (f :: * -> *) a.
MonadParsec e s f =>
f () -> f a -> f (Maybe a)
fullyMaybe Parser ()
sc Parser (Syntax' ())
parseTerm)

-- | A lower-level `readTerm` which returns the megaparsec bundle error
--   for precise error reporting.
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 e s (f :: * -> *) a.
MonadParsec e s f =>
f () -> f a -> f (Maybe a)
fullyMaybe Parser ()
sc Parser (Syntax' ())
parseTerm) Antiquoting
DisallowAntiquoting) String
""

-- | A utility for converting a ParserError into a one line message:
--   @<line-nr>: <error-msg>@
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

-- | A utility for converting a ParseError into a range and error message.
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
  -- convert megaparsec source pos to starts at 0
  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)

  -- get the first error position (ps) and line content (str)
  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

  -- extract the error starting position
  start :: (Int, Int)
start@(Int
line, Int
col) = forall a. PosState a -> (Int, Int)
getLineCol PosState Text
ps

  -- compute the ending position based on the word at starting position
  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

-- | A utility for converting a SrcLoc into a range
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)

  -- remove trailing whitespace that got included by the lexer
  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 =
    -- Megaparsec offset needs to be (-1) to start at 0
    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']

  -- using megaparsec offset facility, compute the line/col
  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