{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Unison.Syntax.Parser
  ( Annotated (..),
    Err,
    Error (..),
    -- FIXME: Don’t export the data constructor
    Input (..),
    P,
    ParsingEnv (..),
    UniqueName (..),
    anyToken,
    blank,
    bytesToken,
    chainl1,
    chainr1,
    chainl1Accum,
    character,
    closeBlock,
    optionalCloseBlock,
    doc,
    failCommitted,
    failureIf,
    hqInfixId,
    hqPrefixId,
    importSymbolyId,
    importWordyId,
    label,
    matchToken,
    mkAnn,
    numeric,
    openBlock,
    openBlockWith,
    peekAny,
    positionalVar,
    prefixDefinitionName,
    prefixTermName,
    queryToken,
    reserved,
    resolveUniqueTypeGuid,
    root,
    rootFile,
    run',
    run,
    semi,
    Unison.Syntax.Parser.seq,
    Unison.Syntax.Parser.seq',
    sepBy,
    sepBy1,
    string,
    symbolyDefinitionName,
    tok,
    tokenToPair,
    tupleOrParenthesized,
    uniqueBase32Namegen,
    uniqueName,
    wordyDefinitionName,
    wordyPatternName,
  )
where

import Control.Monad.Reader (ReaderT (..), ask)
import Control.Monad.Reader.Class (asks)
import Crypto.Random qualified as Random
import Data.Bool (bool)
import Data.Bytes.Put (runPutS)
import Data.Bytes.Serial (serialize)
import Data.Bytes.VarInt (VarInt (..))
import Data.Char qualified as Char
import Data.Kind (Type)
import Data.List.NonEmpty qualified as Nel
import Data.Set qualified as Set
import Data.Text qualified as Text
import Text.Megaparsec (runParserT)
import Text.Megaparsec qualified as P
import U.Codebase.Reference (ReferenceType (..))
import U.Util.Base32Hex qualified as Base32Hex
import Unison.ABT qualified as ABT
import Unison.DataDeclaration (Modifier (Unique))
import Unison.Hash qualified as Hash
import Unison.HashQualified qualified as HQ
import Unison.HashQualifiedPrime qualified as HQ'
import Unison.Hashable qualified as Hashable
import Unison.Name as Name
import Unison.NameSegment (NameSegment)
import Unison.NameSegment qualified as NameSegment
import Unison.Names (Names)
import Unison.Names.ResolutionResult qualified as Names
import Unison.Parser.Ann (Ann (..), Annotated (..))
import Unison.Pattern (Pattern)
import Unison.Pattern qualified as Pattern
import Unison.Prelude
import Unison.Reference (Reference)
import Unison.Referent (Referent)
import Unison.Syntax.Lexer.Unison qualified as L
import Unison.Syntax.Name qualified as Name (toVar, unsafeParseVar)
import Unison.Syntax.Parser.Doc qualified as Doc
import Unison.Syntax.Parser.Doc.Data qualified as Doc
import Unison.Syntax.Var qualified as Var
import Unison.Term (MatchCase (..))
import Unison.UnisonFile.Error qualified as UF
import Unison.Util.Bytes (Bytes)
import Unison.Var (Var)
import Unison.Var qualified as Var

debug :: Bool
debug :: Bool
debug = Bool
False

type P v m = P.ParsecT (Error v) Input (ReaderT (ParsingEnv m) m)

type Err v = P.ParseError Input (Error v)

data ParsingEnv (m :: Type -> Type) = ParsingEnv
  { forall (m :: * -> *). ParsingEnv m -> UniqueName
uniqueNames :: UniqueName,
    -- | Return a GUID to reuse for a unique type of the given name, if any.
    --
    -- This callback is called for every `unique type` declaration that does not explicitly specify a GUID.
    --
    -- The name (e.g. `Foo` in `unique type Foo`) is passed in, and if the function returns a Just, that GUID is used;
    -- otherwise, a random one is generated from `uniqueNames`.
    forall (m :: * -> *). ParsingEnv m -> Name -> m (Maybe Text)
uniqueTypeGuid :: Name -> m (Maybe Text),
    forall (m :: * -> *). ParsingEnv m -> Names
names :: Names,
    -- The namespace block we are currently parsing under, and the file-bound namespace-prefixed type and constructor
    -- names in scope (we've already parsed all type declarations by the time we need this, in the term parser).
    --
    -- Ideally these ought to have no affect on parsing: "applying" a namespace should be a pre-processing pass. All
    -- bindings are prefixed with the namespace (easy), and all free variables that match a binding are prefixed (also
    -- easy).
    --
    -- ... but our "parser" is also doing parse-time name resolution for hash-qualified names, type references,
    -- constructors in patterns, and term/type links.
    --
    -- For constructors in patterns, when parsing a pattern `Foo.Bar` in a namespace `baz`, if `baz.Foo.Bar` is among
    -- the file-bound namespace-prefixed constructor names in scope, then resolve to that constructor. Otherwise,
    -- proceed as normal to look for `Foo.Bar` in the names environment.
    --
    -- For type links, similar deal: we (only because we parse and hash all types before terms) could conceivably
    -- properly handle code like
    --
    --   namespace foo
    --   type Bar = ...
    --   baz = ... typeLink Bar ...
    --
    -- And for term links we are certainly out of luck: we can't look up a resolved file-bound term by hash *during
    -- parsing*. That's an issue with term links in general, unrelated to namespaces, but perhaps complicated by
    -- namespaces nonetheless.
    --
    -- New development: this namespace is now also used during decl parsing, because in order to accurately reuse a
    -- unique type guid we need to look up by namespaced name.
    forall (m :: * -> *). ParsingEnv m -> Maybe Name
maybeNamespace :: Maybe Name,
    forall (m :: * -> *). ParsingEnv m -> Names
localNamespacePrefixedTypesAndConstructors :: Names
  }

newtype UniqueName = UniqueName (L.Pos -> Int -> Maybe Text)

instance Semigroup UniqueName where
  UniqueName Pos -> Int -> Maybe Text
f <> :: UniqueName -> UniqueName -> UniqueName
<> UniqueName Pos -> Int -> Maybe Text
g =
    (Pos -> Int -> Maybe Text) -> UniqueName
UniqueName \Pos
pos Int
len -> Pos -> Int -> Maybe Text
f Pos
pos Int
len Maybe Text -> Maybe Text -> Maybe Text
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Pos -> Int -> Maybe Text
g Pos
pos Int
len

instance Monoid UniqueName where
  mempty :: UniqueName
mempty = (Pos -> Int -> Maybe Text) -> UniqueName
UniqueName (\Pos
_ Int
_ -> Maybe Text
forall a. Maybe a
Nothing)

uniqueBase32Namegen :: forall gen. (Random.DRG gen) => gen -> UniqueName
uniqueBase32Namegen :: forall gen. DRG gen => gen -> UniqueName
uniqueBase32Namegen gen
rng =
  (Pos -> Int -> Maybe Text) -> UniqueName
UniqueName \Pos
pos Int
lenInBase32Hex -> Pos -> Int -> gen -> Maybe Text
go Pos
pos Int
lenInBase32Hex gen
rng
  where
    -- if the identifier starts with a number, try again, since
    -- we want the name to work as a valid wordyId
    go :: L.Pos -> Int -> gen -> Maybe Text
    go :: Pos -> Int -> gen -> Maybe Text
go Pos
pos Int
lenInBase32Hex gen
rng0 =
      let (ByteString
bytes, gen
rng) = Int -> gen -> (ByteString, gen)
forall gen byteArray.
(DRG gen, ByteArray byteArray) =>
Int -> gen -> (byteArray, gen)
forall byteArray.
ByteArray byteArray =>
Int -> gen -> (byteArray, gen)
Random.randomBytesGenerate Int
32 gen
rng0
          posBytes :: ByteString
posBytes = Put -> ByteString
runPutS do
            VarInt Int -> Put
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
forall (m :: * -> *). MonadPut m => VarInt Int -> m ()
serialize (VarInt Int -> Put) -> VarInt Int -> Put
forall a b. (a -> b) -> a -> b
$ Int -> VarInt Int
forall n. n -> VarInt n
VarInt (Pos -> Int
L.line Pos
pos)
            VarInt Int -> Put
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
forall (m :: * -> *). MonadPut m => VarInt Int -> m ()
serialize (VarInt Int -> Put) -> VarInt Int -> Put
forall a b. (a -> b) -> a -> b
$ Int -> VarInt Int
forall n. n -> VarInt n
VarInt (Pos -> Int
L.column Pos
pos)
          h :: Hash
h = ByteString -> Hash
forall h t. (Accumulate h, Hashable t) => t -> h
Hashable.accumulate' (ByteString -> Hash) -> ByteString -> Hash
forall a b. (a -> b) -> a -> b
$ ByteString
bytes ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
posBytes
          b58 :: Text
b58 = Hash -> Text
Hash.toBase32HexText Hash
h
       in if Char -> Bool
Char.isDigit (HasCallStack => Text -> Char
Text -> Char
Text.head Text
b58)
            then Pos -> Int -> gen -> Maybe Text
go Pos
pos Int
lenInBase32Hex gen
rng
            else Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> (Text -> Text) -> Text -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
Text.take Int
lenInBase32Hex (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
b58

uniqueName :: (Monad m, Var v) => Int -> P v m Text
uniqueName :: forall (m :: * -> *) v. (Monad m, Var v) => Int -> P v m Text
uniqueName Int
lenInBase32Hex = do
  UniqueName Pos -> Int -> Maybe Text
mkName <- (ParsingEnv m -> UniqueName)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) UniqueName
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ParsingEnv m -> UniqueName
forall (m :: * -> *). ParsingEnv m -> UniqueName
uniqueNames
  Pos
pos <- Token Lexeme -> Pos
forall a. Token a -> Pos
L.start (Token Lexeme -> Pos)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token Lexeme)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) Pos
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token Lexeme)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token Lexeme)
forall a.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.lookAhead ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token Lexeme)
forall v (m :: * -> *). Ord v => P v m (Token Lexeme)
anyToken
  let none :: Text
none = Base32Hex -> Text
Base32Hex.toText (Base32Hex -> Text) -> (String -> Base32Hex) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Base32Hex
Base32Hex.fromByteString (ByteString -> Base32Hex)
-> (String -> ByteString) -> String -> Base32Hex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Pos -> String
forall a. Show a => a -> String
show Pos
pos
  Text -> P v m Text
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> P v m Text)
-> (Maybe Text -> Text) -> Maybe Text -> P v m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
none (Maybe Text -> P v m Text) -> Maybe Text -> P v m Text
forall a b. (a -> b) -> a -> b
$ Pos -> Int -> Maybe Text
mkName Pos
pos Int
lenInBase32Hex

resolveUniqueTypeGuid :: (Monad m, Var v) => v -> P v m Modifier
resolveUniqueTypeGuid :: forall (m :: * -> *) v. (Monad m, Var v) => v -> P v m Modifier
resolveUniqueTypeGuid v
name0 = do
  ParsingEnv {Maybe Name
$sel:maybeNamespace:ParsingEnv :: forall (m :: * -> *). ParsingEnv m -> Maybe Name
maybeNamespace :: Maybe Name
maybeNamespace, Name -> m (Maybe Text)
$sel:uniqueTypeGuid:ParsingEnv :: forall (m :: * -> *). ParsingEnv m -> Name -> m (Maybe Text)
uniqueTypeGuid :: Name -> m (Maybe Text)
uniqueTypeGuid} <- ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (ParsingEnv m)
forall r (m :: * -> *). MonadReader r m => m r
ask
  let name :: Name
name = v -> Name
forall v. Var v => v -> Name
Name.unsafeParseVar ((v -> v) -> (Name -> v -> v) -> Maybe Name -> v -> v
forall b a. b -> (a -> b) -> Maybe a -> b
maybe v -> v
forall a. a -> a
id (v -> v -> v
forall v. Var v => v -> v -> v
Var.namespaced2 (v -> v -> v) -> (Name -> v) -> Name -> v -> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> v
forall v. Var v => Name -> v
Name.toVar) Maybe Name
maybeNamespace v
name0)
  Text
guid <-
    ReaderT (ParsingEnv m) m (Maybe Text)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Maybe Text)
forall (m :: * -> *) a.
Monad m =>
m a -> ParsecT (Error v) Input m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe Text) -> ReaderT (ParsingEnv m) m (Maybe Text)
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (ParsingEnv m) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Name -> m (Maybe Text)
uniqueTypeGuid Name
name)) ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Maybe Text)
-> (Maybe Text
    -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) Text)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) Text
forall a b.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> (a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) b)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe Text
Nothing -> Int -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) Text
forall (m :: * -> *) v. (Monad m, Var v) => Int -> P v m Text
uniqueName Int
32
      Just Text
guid -> Text -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) Text
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
guid
  pure (Text -> Modifier
Unique Text
guid)

data Error v
  = SignatureNeedsAccompanyingBody (L.Token v)
  | DisallowedAbsoluteName (L.Token Name)
  | EmptyBlock (L.Token String)
  | UnknownTerm (L.Token (HQ.HashQualified Name)) (Set Referent)
  | UnknownType (L.Token (HQ.HashQualified Name)) (Set Reference)
  | UnknownId (L.Token (HQ.HashQualified Name)) (Set Referent) (Set Reference)
  | ExpectedBlockOpen String (L.Token L.Lexeme)
  | EmptyWatch Ann
  | UseInvalidPrefixSuffix (Either (L.Token Name) (L.Token Name)) (Maybe [L.Token Name])
  | UseEmpty (L.Token String) -- an empty `use` statement
  | DidntExpectExpression (L.Token L.Lexeme) (Maybe (L.Token L.Lexeme))
  | TypeDeclarationErrors [UF.Error v Ann]
  | -- | MissingTypeModifier (type|ability) name
    MissingTypeModifier (L.Token String) (L.Token v)
  | -- | A type was found in a position that requires a term
    TypeNotAllowed (L.Token (HQ.HashQualified Name))
  | ResolutionFailures [Names.ResolutionFailure Ann]
  | DuplicateTypeNames [(v, [Ann])]
  | DuplicateTermNames [(v, [Ann])]
  | -- | PatternArityMismatch expectedArity actualArity location
    PatternArityMismatch Int Int Ann
  | FloatPattern Ann
  deriving (Int -> Error v -> ShowS
[Error v] -> ShowS
Error v -> String
(Int -> Error v -> ShowS)
-> (Error v -> String) -> ([Error v] -> ShowS) -> Show (Error v)
forall v. Show v => Int -> Error v -> ShowS
forall v. Show v => [Error v] -> ShowS
forall v. Show v => Error v -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall v. Show v => Int -> Error v -> ShowS
showsPrec :: Int -> Error v -> ShowS
$cshow :: forall v. Show v => Error v -> String
show :: Error v -> String
$cshowList :: forall v. Show v => [Error v] -> ShowS
showList :: [Error v] -> ShowS
Show, Error v -> Error v -> Bool
(Error v -> Error v -> Bool)
-> (Error v -> Error v -> Bool) -> Eq (Error v)
forall v. Eq v => Error v -> Error v -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall v. Eq v => Error v -> Error v -> Bool
== :: Error v -> Error v -> Bool
$c/= :: forall v. Eq v => Error v -> Error v -> Bool
/= :: Error v -> Error v -> Bool
Eq, Eq (Error v)
Eq (Error v) =>
(Error v -> Error v -> Ordering)
-> (Error v -> Error v -> Bool)
-> (Error v -> Error v -> Bool)
-> (Error v -> Error v -> Bool)
-> (Error v -> Error v -> Bool)
-> (Error v -> Error v -> Error v)
-> (Error v -> Error v -> Error v)
-> Ord (Error v)
Error v -> Error v -> Bool
Error v -> Error v -> Ordering
Error v -> Error v -> Error v
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
forall v. Ord v => Eq (Error v)
forall v. Ord v => Error v -> Error v -> Bool
forall v. Ord v => Error v -> Error v -> Ordering
forall v. Ord v => Error v -> Error v -> Error v
$ccompare :: forall v. Ord v => Error v -> Error v -> Ordering
compare :: Error v -> Error v -> Ordering
$c< :: forall v. Ord v => Error v -> Error v -> Bool
< :: Error v -> Error v -> Bool
$c<= :: forall v. Ord v => Error v -> Error v -> Bool
<= :: Error v -> Error v -> Bool
$c> :: forall v. Ord v => Error v -> Error v -> Bool
> :: Error v -> Error v -> Bool
$c>= :: forall v. Ord v => Error v -> Error v -> Bool
>= :: Error v -> Error v -> Bool
$cmax :: forall v. Ord v => Error v -> Error v -> Error v
max :: Error v -> Error v -> Error v
$cmin :: forall v. Ord v => Error v -> Error v -> Error v
min :: Error v -> Error v -> Error v
Ord)

tokenToPair :: L.Token a -> (Ann, a)
tokenToPair :: forall a. Token a -> (Ann, a)
tokenToPair Token a
t = (Token a -> Ann
forall a. Annotated a => a -> Ann
ann Token a
t, Token a -> a
forall a. Token a -> a
L.payload Token a
t)

newtype Input = Input {Input -> [Token Lexeme]
inputStream :: [L.Token L.Lexeme]}
  deriving stock (Input -> Input -> Bool
(Input -> Input -> Bool) -> (Input -> Input -> Bool) -> Eq Input
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Input -> Input -> Bool
== :: Input -> Input -> Bool
$c/= :: Input -> Input -> Bool
/= :: Input -> Input -> Bool
Eq, Eq Input
Eq Input =>
(Input -> Input -> Ordering)
-> (Input -> Input -> Bool)
-> (Input -> Input -> Bool)
-> (Input -> Input -> Bool)
-> (Input -> Input -> Bool)
-> (Input -> Input -> Input)
-> (Input -> Input -> Input)
-> Ord Input
Input -> Input -> Bool
Input -> Input -> Ordering
Input -> Input -> Input
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
$ccompare :: Input -> Input -> Ordering
compare :: Input -> Input -> Ordering
$c< :: Input -> Input -> Bool
< :: Input -> Input -> Bool
$c<= :: Input -> Input -> Bool
<= :: Input -> Input -> Bool
$c> :: Input -> Input -> Bool
> :: Input -> Input -> Bool
$c>= :: Input -> Input -> Bool
>= :: Input -> Input -> Bool
$cmax :: Input -> Input -> Input
max :: Input -> Input -> Input
$cmin :: Input -> Input -> Input
min :: Input -> Input -> Input
Ord, Int -> Input -> ShowS
[Input] -> ShowS
Input -> String
(Int -> Input -> ShowS)
-> (Input -> String) -> ([Input] -> ShowS) -> Show Input
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Input -> ShowS
showsPrec :: Int -> Input -> ShowS
$cshow :: Input -> String
show :: Input -> String
$cshowList :: [Input] -> ShowS
showList :: [Input] -> ShowS
Show)
  deriving newtype (Ord (Token Input)
Ord (Tokens Input)
(Ord (Token Input), Ord (Tokens Input)) =>
(Proxy Input -> Token Input -> Tokens Input)
-> (Proxy Input -> [Token Input] -> Tokens Input)
-> (Proxy Input -> Tokens Input -> [Token Input])
-> (Proxy Input -> Tokens Input -> Int)
-> (Proxy Input -> Tokens Input -> Bool)
-> (Input -> Maybe (Token Input, Input))
-> (Int -> Input -> Maybe (Tokens Input, Input))
-> ((Token Input -> Bool) -> Input -> (Tokens Input, Input))
-> Stream Input
Int -> Input -> Maybe (Tokens Input, Input)
Proxy Input -> [Token Input] -> Tokens Input
Proxy Input -> Token Input -> Tokens Input
Proxy Input -> Tokens Input -> Bool
Proxy Input -> Tokens Input -> Int
Proxy Input -> Tokens Input -> [Token Input]
Input -> Maybe (Token Input, Input)
(Token Input -> Bool) -> Input -> (Tokens Input, Input)
forall s.
(Ord (Token s), Ord (Tokens s)) =>
(Proxy s -> Token s -> Tokens s)
-> (Proxy s -> [Token s] -> Tokens s)
-> (Proxy s -> Tokens s -> [Token s])
-> (Proxy s -> Tokens s -> Int)
-> (Proxy s -> Tokens s -> Bool)
-> (s -> Maybe (Token s, s))
-> (Int -> s -> Maybe (Tokens s, s))
-> ((Token s -> Bool) -> s -> (Tokens s, s))
-> Stream s
$ctokenToChunk :: Proxy Input -> Token Input -> Tokens Input
tokenToChunk :: Proxy Input -> Token Input -> Tokens Input
$ctokensToChunk :: Proxy Input -> [Token Input] -> Tokens Input
tokensToChunk :: Proxy Input -> [Token Input] -> Tokens Input
$cchunkToTokens :: Proxy Input -> Tokens Input -> [Token Input]
chunkToTokens :: Proxy Input -> Tokens Input -> [Token Input]
$cchunkLength :: Proxy Input -> Tokens Input -> Int
chunkLength :: Proxy Input -> Tokens Input -> Int
$cchunkEmpty :: Proxy Input -> Tokens Input -> Bool
chunkEmpty :: Proxy Input -> Tokens Input -> Bool
$ctake1_ :: Input -> Maybe (Token Input, Input)
take1_ :: Input -> Maybe (Token Input, Input)
$ctakeN_ :: Int -> Input -> Maybe (Tokens Input, Input)
takeN_ :: Int -> Input -> Maybe (Tokens Input, Input)
$ctakeWhile_ :: (Token Input -> Bool) -> Input -> (Tokens Input, Input)
takeWhile_ :: (Token Input -> Bool) -> Input -> (Tokens Input, Input)
P.Stream, Stream Input
Proxy Input -> NonEmpty (Token Input) -> Int
Proxy Input -> NonEmpty (Token Input) -> String
Stream Input =>
(Proxy Input -> NonEmpty (Token Input) -> String)
-> (Proxy Input -> NonEmpty (Token Input) -> Int)
-> VisualStream Input
forall s.
Stream s =>
(Proxy s -> NonEmpty (Token s) -> String)
-> (Proxy s -> NonEmpty (Token s) -> Int) -> VisualStream s
$cshowTokens :: Proxy Input -> NonEmpty (Token Input) -> String
showTokens :: Proxy Input -> NonEmpty (Token Input) -> String
$ctokensLength :: Proxy Input -> NonEmpty (Token Input) -> Int
tokensLength :: Proxy Input -> NonEmpty (Token Input) -> Int
P.VisualStream)

instance (Annotated a) => Annotated (ABT.Term f v a) where
  ann :: Term f v a -> Ann
ann = a -> Ann
forall a. Annotated a => a -> Ann
ann (a -> Ann) -> (Term f v a -> a) -> Term f v a -> Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term f v a -> a
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation

instance (Annotated a) => Annotated (Pattern a) where
  ann :: Pattern a -> Ann
ann = a -> Ann
forall a. Annotated a => a -> Ann
ann (a -> Ann) -> (Pattern a -> a) -> Pattern a -> Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern a -> a
forall loc. Pattern loc -> loc
Pattern.loc

instance (Annotated a, Annotated b) => Annotated (MatchCase a b) where
  ann :: MatchCase a b -> Ann
ann (MatchCase Pattern a
p Maybe b
_ b
b) = Pattern a -> Ann
forall a. Annotated a => a -> Ann
ann Pattern a
p Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
<> b -> Ann
forall a. Annotated a => a -> Ann
ann b
b

label :: (Ord v, Show a) => String -> P v m a -> P v m a
label :: forall v a (m :: * -> *).
(Ord v, Show a) =>
String -> P v m a -> P v m a
label = String
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall a.
String
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
P.label

-- label = P.dbg

traceRemainingTokens :: (Ord v) => String -> P v m ()
traceRemainingTokens :: forall v (m :: * -> *). Ord v => String -> P v m ()
traceRemainingTokens String
label = do
  [Token Lexeme]
remainingTokens <- P v m [Token Lexeme] -> P v m [Token Lexeme]
forall v (m :: * -> *) a. Ord v => P v m a -> P v m a
lookAhead (P v m [Token Lexeme] -> P v m [Token Lexeme])
-> P v m [Token Lexeme] -> P v m [Token Lexeme]
forall a b. (a -> b) -> a -> b
$ ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token Lexeme)
-> P v m [Token Lexeme]
forall a.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token Lexeme)
forall v (m :: * -> *). Ord v => P v m (Token Lexeme)
anyToken
  let ()
_ = String -> () -> ()
forall a. String -> a -> a
trace (String
"REMAINDER " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
label String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ BlockTree (Token Lexeme) -> String
L.debugPreParse ([Token Lexeme] -> BlockTree (Token Lexeme)
L.preParse [Token Lexeme]
remainingTokens)) ()
  () -> P v m ()
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

mkAnn :: (Annotated a, Annotated b) => a -> b -> Ann
mkAnn :: forall a b. (Annotated a, Annotated b) => a -> b -> Ann
mkAnn a
x b
y = a -> Ann
forall a. Annotated a => a -> Ann
ann a
x Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
<> b -> Ann
forall a. Annotated a => a -> Ann
ann b
y

tok :: (Ann -> a -> b) -> L.Token a -> b
tok :: forall a b. (Ann -> a -> b) -> Token a -> b
tok Ann -> a -> b
f (L.Token a
a Pos
start Pos
end) = Ann -> a -> b
f (Pos -> Pos -> Ann
Ann Pos
start Pos
end) a
a

peekAny :: (Ord v) => P v m (L.Token L.Lexeme)
peekAny :: forall v (m :: * -> *). Ord v => P v m (Token Lexeme)
peekAny = ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token Lexeme)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token Lexeme)
forall a.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.lookAhead ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token Input)
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token Lexeme)
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
P.anySingle

lookAhead :: (Ord v) => P v m a -> P v m a
lookAhead :: forall v (m :: * -> *) a. Ord v => P v m a -> P v m a
lookAhead = ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall a.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.lookAhead

anyToken :: (Ord v) => P v m (L.Token L.Lexeme)
anyToken :: forall v (m :: * -> *). Ord v => P v m (Token Lexeme)
anyToken = ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token Input)
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token Lexeme)
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
P.anySingle

failCommitted :: (Ord v) => Error v -> P v m x
failCommitted :: forall v (m :: * -> *) x. Ord v => Error v -> P v m x
failCommitted Error v
e = do
  ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token Lexeme)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token Lexeme)
forall v (m :: * -> *). Ord v => P v m (Token Lexeme)
anyToken ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ()
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ()
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ()
forall a.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ()
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
P.eof
  Error v -> P v m x
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
P.customFailure Error v
e

root :: (Ord v) => P v m a -> P v m a
root :: forall v (m :: * -> *) a. Ord v => P v m a -> P v m a
root P v m a
p = (P v m (Token String)
forall v (m :: * -> *). Ord v => P v m (Token String)
openBlock P v m (Token String) -> P v m a -> P v m a
forall a b.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) b
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P v m a
p) P v m a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token ())
-> P v m a
forall a b.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) b
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token ())
forall v (m :: * -> *). Ord v => P v m (Token ())
closeBlock P v m a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) () -> P v m a
forall a b.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) b
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
P.eof

rootFile :: (Ord v) => P v m a -> P v m a
rootFile :: forall v (m :: * -> *) a. Ord v => P v m a -> P v m a
rootFile P v m a
p = P v m a
p P v m a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) () -> P v m a
forall a b.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) b
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
P.eof

run' :: (Monad m, Ord v) => P v m a -> String -> String -> ParsingEnv m -> m (Either (Err v) a)
run' :: forall (m :: * -> *) v a.
(Monad m, Ord v) =>
P v m a -> String -> String -> ParsingEnv m -> m (Either (Err v) a)
run' P v m a
p String
s String
name ParsingEnv m
env =
  let lex :: BlockTree (Token Lexeme)
lex = (BlockTree (Token Lexeme) -> BlockTree (Token Lexeme))
-> (BlockTree (Token Lexeme) -> BlockTree (Token Lexeme))
-> Bool
-> BlockTree (Token Lexeme)
-> BlockTree (Token Lexeme)
forall a. a -> a -> Bool -> a
bool BlockTree (Token Lexeme) -> BlockTree (Token Lexeme)
forall a. a -> a
id ((BlockTree (Token Lexeme) -> String)
-> BlockTree (Token Lexeme) -> BlockTree (Token Lexeme)
forall a. (a -> String) -> a -> a
traceWith BlockTree (Token Lexeme) -> String
L.debugPreParse) Bool
debug (BlockTree (Token Lexeme) -> BlockTree (Token Lexeme))
-> ([Token Lexeme] -> BlockTree (Token Lexeme))
-> [Token Lexeme]
-> BlockTree (Token Lexeme)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token Lexeme] -> BlockTree (Token Lexeme)
L.preParse ([Token Lexeme] -> BlockTree (Token Lexeme))
-> [Token Lexeme] -> BlockTree (Token Lexeme)
forall a b. (a -> b) -> a -> b
$ String -> String -> [Token Lexeme]
L.lexer String
name String
s
      pTraced :: P v m a
pTraced = String -> P v m ()
forall v (m :: * -> *). Ord v => String -> P v m ()
traceRemainingTokens String
"parser receives" P v m () -> P v m a -> P v m a
forall a b.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) b
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P v m a
p
   in ReaderT
  (ParsingEnv m) m (Either (ParseErrorBundle Input (Error v)) a)
-> ParsingEnv m -> m (Either (ParseErrorBundle Input (Error v)) a)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (P v m a
-> String
-> Input
-> ReaderT
     (ParsingEnv m) m (Either (ParseErrorBundle Input (Error v)) a)
forall (m :: * -> *) e s a.
Monad m =>
ParsecT e s m a
-> String -> s -> m (Either (ParseErrorBundle s e) a)
runParserT P v m a
pTraced String
name (Input
 -> ReaderT
      (ParsingEnv m) m (Either (ParseErrorBundle Input (Error v)) a))
-> ([Token Lexeme] -> Input)
-> [Token Lexeme]
-> ReaderT
     (ParsingEnv m) m (Either (ParseErrorBundle Input (Error v)) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token Lexeme] -> Input
Input ([Token Lexeme]
 -> ReaderT
      (ParsingEnv m) m (Either (ParseErrorBundle Input (Error v)) a))
-> [Token Lexeme]
-> ReaderT
     (ParsingEnv m) m (Either (ParseErrorBundle Input (Error v)) a)
forall a b. (a -> b) -> a -> b
$ BlockTree (Token Lexeme) -> [Token Lexeme]
forall a. BlockTree a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList BlockTree (Token Lexeme)
lex) ParsingEnv m
env m (Either (ParseErrorBundle Input (Error v)) a)
-> (Either (ParseErrorBundle Input (Error v)) a
    -> Either (Err v) a)
-> m (Either (Err v) a)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
        Left ParseErrorBundle Input (Error v)
err -> Err v -> Either (Err v) a
forall a b. a -> Either a b
Left (NonEmpty (Err v) -> Err v
forall a. NonEmpty a -> a
Nel.head (ParseErrorBundle Input (Error v) -> NonEmpty (Err v)
forall s e. ParseErrorBundle s e -> NonEmpty (ParseError s e)
P.bundleErrors ParseErrorBundle Input (Error v)
err))
        Right a
x -> a -> Either (Err v) a
forall a b. b -> Either a b
Right a
x

run :: (Monad m, Ord v) => P v m a -> String -> ParsingEnv m -> m (Either (Err v) a)
run :: forall (m :: * -> *) v a.
(Monad m, Ord v) =>
P v m a -> String -> ParsingEnv m -> m (Either (Err v) a)
run P v m a
p String
s = P v m a -> String -> String -> ParsingEnv m -> m (Either (Err v) a)
forall (m :: * -> *) v a.
(Monad m, Ord v) =>
P v m a -> String -> String -> ParsingEnv m -> m (Either (Err v) a)
run' P v m a
p String
s String
""

-- | Virtual pattern match on a lexeme.
queryToken :: (Ord v) => (L.Lexeme -> Maybe a) -> P v m (L.Token a)
queryToken :: forall v a (m :: * -> *).
Ord v =>
(Lexeme -> Maybe a) -> P v m (Token a)
queryToken Lexeme -> Maybe a
f = (Token Input -> Maybe (Token a))
-> Set (ErrorItem (Token Input))
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token a)
forall a.
(Token Input -> Maybe a)
-> Set (ErrorItem (Token Input))
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
(Token s -> Maybe a) -> Set (ErrorItem (Token s)) -> m a
P.token ((Lexeme -> Maybe a) -> Token Lexeme -> Maybe (Token a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Token a -> f (Token b)
traverse Lexeme -> Maybe a
f) Set (ErrorItem (Token Input))
Set (ErrorItem (Token Lexeme))
forall a. Set a
Set.empty

-- | Consume a block opening and return the string that opens the block.
openBlock :: (Ord v) => P v m (L.Token String)
openBlock :: forall v (m :: * -> *). Ord v => P v m (Token String)
openBlock = (Lexeme -> Maybe String) -> P v m (Token String)
forall v a (m :: * -> *).
Ord v =>
(Lexeme -> Maybe a) -> P v m (Token a)
queryToken Lexeme -> Maybe String
getOpen
  where
    getOpen :: Lexeme -> Maybe String
getOpen (L.Open String
s) = String -> Maybe String
forall a. a -> Maybe a
Just String
s
    getOpen Lexeme
_ = Maybe String
forall a. Maybe a
Nothing

openBlockWith :: (Ord v) => String -> P v m (L.Token ())
openBlockWith :: forall v (m :: * -> *). Ord v => String -> P v m (Token ())
openBlockWith String
s = Token Lexeme -> Token ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Token Lexeme -> Token ())
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token Lexeme)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Token Input -> Bool)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token Input)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
P.satisfy ((String -> Lexeme
L.Open String
s Lexeme -> Lexeme -> Bool
forall a. Eq a => a -> a -> Bool
==) (Lexeme -> Bool)
-> (Token Lexeme -> Lexeme) -> Token Lexeme -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token Lexeme -> Lexeme
forall a. Token a -> a
L.payload)

-- | Match a particular lexeme exactly, and consume it.
matchToken :: (Ord v) => L.Lexeme -> P v m (L.Token L.Lexeme)
matchToken :: forall v (m :: * -> *). Ord v => Lexeme -> P v m (Token Lexeme)
matchToken Lexeme
x = (Token Input -> Bool)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token Input)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
P.satisfy (Lexeme -> Lexeme -> Bool
forall a. Eq a => a -> a -> Bool
(==) Lexeme
x (Lexeme -> Bool)
-> (Token Lexeme -> Lexeme) -> Token Lexeme -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token Lexeme -> Lexeme
forall a. Token a -> a
L.payload)

-- | Consume a virtual semicolon
semi :: (Ord v) => P v m (L.Token ())
semi :: forall v (m :: * -> *). Ord v => P v m (Token ())
semi = String -> P v m (Token ()) -> P v m (Token ())
forall v a (m :: * -> *).
(Ord v, Show a) =>
String -> P v m a -> P v m a
label String
"newline or semicolon" (P v m (Token ()) -> P v m (Token ()))
-> P v m (Token ()) -> P v m (Token ())
forall a b. (a -> b) -> a -> b
$ (Lexeme -> Maybe ()) -> P v m (Token ())
forall v a (m :: * -> *).
Ord v =>
(Lexeme -> Maybe a) -> P v m (Token a)
queryToken Lexeme -> Maybe ()
go
  where
    go :: Lexeme -> Maybe ()
go (L.Semi Bool
_) = () -> Maybe ()
forall a. a -> Maybe a
Just ()
    go Lexeme
_ = Maybe ()
forall a. Maybe a
Nothing

-- | Consume the end of a block
closeBlock :: (Ord v) => P v m (L.Token ())
closeBlock :: forall v (m :: * -> *). Ord v => P v m (Token ())
closeBlock = Token Lexeme -> Token ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Token Lexeme -> Token ())
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token Lexeme)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lexeme
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token Lexeme)
forall v (m :: * -> *). Ord v => Lexeme -> P v m (Token Lexeme)
matchToken Lexeme
L.Close

-- | With layout, blocks might “close” without an explicit outdent (e.g., not even a newline at the end of a
--  `Doc.Transclude`). This allows those blocks to be closed by EOF.
optionalCloseBlock :: (Ord v) => P v m (L.Token ())
optionalCloseBlock :: forall v (m :: * -> *). Ord v => P v m (Token ())
optionalCloseBlock = P v m (Token ())
forall v (m :: * -> *). Ord v => P v m (Token ())
closeBlock P v m (Token ()) -> P v m (Token ()) -> P v m (Token ())
forall a.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (\() -> () -> Pos -> Pos -> Token ()
forall a. a -> Pos -> Pos -> Token a
L.Token () Pos
forall a. Monoid a => a
mempty Pos
forall a. Monoid a => a
mempty) (() -> Token ())
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ()
-> P v m (Token ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
P.eof

-- | A `Name` is blank when it is unqualified and begins with a `_` (also implying that it is wordy)
isBlank :: Name -> Bool
isBlank :: Name -> Bool
isBlank Name
n = Name -> Bool
isUnqualified Name
n Bool -> Bool -> Bool
&& Text -> Text -> Bool
Text.isPrefixOf Text
"_" (NameSegment -> Text
NameSegment.toUnescapedText (NameSegment -> Text) -> NameSegment -> Text
forall a b. (a -> b) -> a -> b
$ Name -> NameSegment
lastSegment Name
n)

-- | A HQ Name is blank when its Name is blank and it has no hash.
isBlank' :: HQ'.HashQualified Name -> Bool
isBlank' :: HashQualified Name -> Bool
isBlank' = \case
  HQ'.NameOnly Name
n -> Name -> Bool
isBlank Name
n
  HQ'.HashQualified Name
_ ShortHash
_ -> Bool
False

wordyPatternName :: (Var v) => P v m (L.Token v)
wordyPatternName :: forall v (m :: * -> *). Var v => P v m (Token v)
wordyPatternName = (Lexeme -> Maybe v) -> P v m (Token v)
forall v a (m :: * -> *).
Ord v =>
(Lexeme -> Maybe a) -> P v m (Token a)
queryToken \case
  L.WordyId (HQ'.NameOnly Name
n) -> if Name -> Bool
isBlank Name
n then Maybe v
forall a. Maybe a
Nothing else v -> Maybe v
forall a. a -> Maybe a
Just (v -> Maybe v) -> v -> Maybe v
forall a b. (a -> b) -> a -> b
$ Name -> v
forall v. Var v => Name -> v
Name.toVar Name
n
  Lexeme
_ -> Maybe v
forall a. Maybe a
Nothing

-- | Parse a prefix identifier e.g. Foo or (+), discarding any hash
prefixDefinitionName :: (Var v) => P v m (L.Token v)
prefixDefinitionName :: forall v (m :: * -> *). Var v => P v m (Token v)
prefixDefinitionName =
  P v m (Token v)
forall v (m :: * -> *). Var v => P v m (Token v)
wordyDefinitionName P v m (Token v) -> P v m (Token v) -> P v m (Token v)
forall a.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P v m (Token v) -> P v m (Token v)
forall v (m :: * -> *) a.
Ord v =>
P v m (Token a) -> P v m (Token a)
parenthesize P v m (Token v)
forall v (m :: * -> *). Var v => P v m (Token v)
symbolyDefinitionName

-- | Parse a prefix identifier e.g. Foo or (+), rejecting any hash
--   This is useful for term declarations, where type signatures and term names should not have hashes.
prefixTermName :: (Var v) => P v m (L.Token v)
prefixTermName :: forall v (m :: * -> *). Var v => P v m (Token v)
prefixTermName = P v m (Token v)
forall {m :: * -> *}. P v m (Token v)
wordyTermName P v m (Token v) -> P v m (Token v) -> P v m (Token v)
forall a.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P v m (Token v) -> P v m (Token v)
forall v (m :: * -> *) a.
Ord v =>
P v m (Token a) -> P v m (Token a)
parenthesize P v m (Token v)
forall {m :: * -> *}. P v m (Token v)
symbolyTermName
  where
    wordyTermName :: P v m (Token v)
wordyTermName = (Lexeme -> Maybe v) -> P v m (Token v)
forall v a (m :: * -> *).
Ord v =>
(Lexeme -> Maybe a) -> P v m (Token a)
queryToken \case
      L.WordyId (HQ'.NameOnly Name
n) -> v -> Maybe v
forall a. a -> Maybe a
Just (v -> Maybe v) -> v -> Maybe v
forall a b. (a -> b) -> a -> b
$ Name -> v
forall v. Var v => Name -> v
Name.toVar Name
n
      Lexeme
_ -> Maybe v
forall a. Maybe a
Nothing
    symbolyTermName :: P v m (Token v)
symbolyTermName = (Lexeme -> Maybe v) -> P v m (Token v)
forall v a (m :: * -> *).
Ord v =>
(Lexeme -> Maybe a) -> P v m (Token a)
queryToken \case
      L.SymbolyId (HQ'.NameOnly Name
n) -> v -> Maybe v
forall a. a -> Maybe a
Just (v -> Maybe v) -> v -> Maybe v
forall a b. (a -> b) -> a -> b
$ Name -> v
forall v. Var v => Name -> v
Name.toVar Name
n
      Lexeme
_ -> Maybe v
forall a. Maybe a
Nothing

-- | Parse a wordy identifier e.g. Foo, discarding any hash
wordyDefinitionName :: (Var v) => P v m (L.Token v)
wordyDefinitionName :: forall v (m :: * -> *). Var v => P v m (Token v)
wordyDefinitionName = (Lexeme -> Maybe v) -> P v m (Token v)
forall v a (m :: * -> *).
Ord v =>
(Lexeme -> Maybe a) -> P v m (Token a)
queryToken \case
  L.WordyId HashQualified Name
n -> v -> Maybe v
forall a. a -> Maybe a
Just (v -> Maybe v) -> v -> Maybe v
forall a b. (a -> b) -> a -> b
$ Name -> v
forall v. Var v => Name -> v
Name.toVar (HashQualified Name -> Name
forall n. HashQualified n -> n
HQ'.toName HashQualified Name
n)
  Lexeme
_ -> Maybe v
forall a. Maybe a
Nothing

-- | Parse a wordyId as a Name, rejecting any hash
importWordyId :: (Ord v) => P v m (L.Token Name)
importWordyId :: forall v (m :: * -> *). Ord v => P v m (Token Name)
importWordyId = (Lexeme -> Maybe Name) -> P v m (Token Name)
forall v a (m :: * -> *).
Ord v =>
(Lexeme -> Maybe a) -> P v m (Token a)
queryToken \case
  L.WordyId (HQ'.NameOnly Name
n) -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
  Lexeme
_ -> Maybe Name
forall a. Maybe a
Nothing

-- | The `+` in: use Foo.bar + as a Name
importSymbolyId :: (Ord v) => P v m (L.Token Name)
importSymbolyId :: forall v (m :: * -> *). Ord v => P v m (Token Name)
importSymbolyId = (Lexeme -> Maybe Name) -> P v m (Token Name)
forall v a (m :: * -> *).
Ord v =>
(Lexeme -> Maybe a) -> P v m (Token a)
queryToken \case
  L.SymbolyId (HQ'.NameOnly Name
n) -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
  Lexeme
_ -> Maybe Name
forall a. Maybe a
Nothing

-- | Parse a symboly ID like >>= or &&, discarding any hash
symbolyDefinitionName :: (Var v) => P v m (L.Token v)
symbolyDefinitionName :: forall v (m :: * -> *). Var v => P v m (Token v)
symbolyDefinitionName = (Lexeme -> Maybe v) -> P v m (Token v)
forall v a (m :: * -> *).
Ord v =>
(Lexeme -> Maybe a) -> P v m (Token a)
queryToken ((Lexeme -> Maybe v) -> P v m (Token v))
-> (Lexeme -> Maybe v) -> P v m (Token v)
forall a b. (a -> b) -> a -> b
$ \case
  L.SymbolyId HashQualified Name
n -> v -> Maybe v
forall a. a -> Maybe a
Just (v -> Maybe v) -> v -> Maybe v
forall a b. (a -> b) -> a -> b
$ Name -> v
forall v. Var v => Name -> v
Name.toVar (HashQualified Name -> Name
forall n. HashQualified n -> n
HQ'.toName HashQualified Name
n)
  Lexeme
_ -> Maybe v
forall a. Maybe a
Nothing

-- | Expect parentheses around a token, includes the parentheses within the start/end
--   annotations of the resulting token.
parenthesize :: (Ord v) => P v m (L.Token a) -> P v m (L.Token a)
parenthesize :: forall v (m :: * -> *) a.
Ord v =>
P v m (Token a) -> P v m (Token a)
parenthesize P v m (Token a)
p = do
  (Pos
start, Token a
a) <- ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pos, Token a)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Pos, Token a)
forall a.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try do
    Pos
start <- Token () -> Pos
forall a. Token a -> Pos
L.start (Token () -> Pos)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token ())
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) Pos
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token ())
forall v (m :: * -> *). Ord v => String -> P v m (Token ())
openBlockWith String
"("
    Token a
a <- P v m (Token a)
p
    pure (Pos
start, Token a
a)
  Pos
end <- Token () -> Pos
forall a. Token a -> Pos
L.end (Token () -> Pos)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token ())
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) Pos
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token ())
forall v (m :: * -> *). Ord v => P v m (Token ())
closeBlock
  pure (L.Token {$sel:payload:Token :: a
payload = Token a -> a
forall a. Token a -> a
L.payload Token a
a, Pos
$sel:start:Token :: Pos
start :: Pos
start, Pos
end :: Pos
$sel:end:Token :: Pos
end})

hqPrefixId, hqInfixId :: (Ord v) => P v m (L.Token (HQ.HashQualified Name))
hqPrefixId :: forall v (m :: * -> *). Ord v => P v m (Token (HashQualified Name))
hqPrefixId = P v m (Token (HashQualified Name))
forall v (m :: * -> *). Ord v => P v m (Token (HashQualified Name))
hqWordyId_ P v m (Token (HashQualified Name))
-> P v m (Token (HashQualified Name))
-> P v m (Token (HashQualified Name))
forall a.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P v m (Token (HashQualified Name))
-> P v m (Token (HashQualified Name))
forall v (m :: * -> *) a.
Ord v =>
P v m (Token a) -> P v m (Token a)
parenthesize P v m (Token (HashQualified Name))
forall v (m :: * -> *). Ord v => P v m (Token (HashQualified Name))
hqSymbolyId_
hqInfixId :: forall v (m :: * -> *). Ord v => P v m (Token (HashQualified Name))
hqInfixId = P v m (Token (HashQualified Name))
forall v (m :: * -> *). Ord v => P v m (Token (HashQualified Name))
hqSymbolyId_

-- | Parse a hash-qualified alphanumeric identifier
hqWordyId_ :: (Ord v) => P v m (L.Token (HQ.HashQualified Name))
hqWordyId_ :: forall v (m :: * -> *). Ord v => P v m (Token (HashQualified Name))
hqWordyId_ = (Lexeme -> Maybe (HashQualified Name))
-> P v m (Token (HashQualified Name))
forall v a (m :: * -> *).
Ord v =>
(Lexeme -> Maybe a) -> P v m (Token a)
queryToken \case
  L.WordyId HashQualified Name
n -> HashQualified Name -> Maybe (HashQualified Name)
forall a. a -> Maybe a
Just (HashQualified Name -> Maybe (HashQualified Name))
-> HashQualified Name -> Maybe (HashQualified Name)
forall a b. (a -> b) -> a -> b
$ HashQualified Name -> HashQualified Name
forall n. HashQualified n -> HashQualified n
HQ'.toHQ HashQualified Name
n
  L.Hash ShortHash
h -> HashQualified Name -> Maybe (HashQualified Name)
forall a. a -> Maybe a
Just (HashQualified Name -> Maybe (HashQualified Name))
-> HashQualified Name -> Maybe (HashQualified Name)
forall a b. (a -> b) -> a -> b
$ ShortHash -> HashQualified Name
forall n. ShortHash -> HashQualified n
HQ.HashOnly ShortHash
h
  Lexeme
_ -> Maybe (HashQualified Name)
forall a. Maybe a
Nothing

-- | Parse a hash-qualified symboly ID like >>=#foo or &&
hqSymbolyId_ :: (Ord v) => P v m (L.Token (HQ.HashQualified Name))
hqSymbolyId_ :: forall v (m :: * -> *). Ord v => P v m (Token (HashQualified Name))
hqSymbolyId_ = (Lexeme -> Maybe (HashQualified Name))
-> P v m (Token (HashQualified Name))
forall v a (m :: * -> *).
Ord v =>
(Lexeme -> Maybe a) -> P v m (Token a)
queryToken \case
  L.SymbolyId HashQualified Name
n -> HashQualified Name -> Maybe (HashQualified Name)
forall a. a -> Maybe a
Just (HashQualified Name -> HashQualified Name
forall n. HashQualified n -> HashQualified n
HQ'.toHQ HashQualified Name
n)
  Lexeme
_ -> Maybe (HashQualified Name)
forall a. Maybe a
Nothing

-- | Parse a reserved word
reserved :: (Ord v) => String -> P v m (L.Token String)
reserved :: forall v (m :: * -> *). Ord v => String -> P v m (Token String)
reserved String
w = String -> P v m (Token String) -> P v m (Token String)
forall v a (m :: * -> *).
(Ord v, Show a) =>
String -> P v m a -> P v m a
label String
w (P v m (Token String) -> P v m (Token String))
-> P v m (Token String) -> P v m (Token String)
forall a b. (a -> b) -> a -> b
$ (Lexeme -> Maybe String) -> P v m (Token String)
forall v a (m :: * -> *).
Ord v =>
(Lexeme -> Maybe a) -> P v m (Token a)
queryToken Lexeme -> Maybe String
getReserved
  where
    getReserved :: Lexeme -> Maybe String
getReserved (L.Reserved String
w') | String
w String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
w' = String -> Maybe String
forall a. a -> Maybe a
Just String
w
    getReserved Lexeme
_ = Maybe String
forall a. Maybe a
Nothing

-- | Parse a placeholder or typed hole
blank :: (Ord v) => P v m (L.Token NameSegment)
blank :: forall v (m :: * -> *). Ord v => P v m (Token NameSegment)
blank = String -> P v m (Token NameSegment) -> P v m (Token NameSegment)
forall v a (m :: * -> *).
(Ord v, Show a) =>
String -> P v m a -> P v m a
label String
"blank" (P v m (Token NameSegment) -> P v m (Token NameSegment))
-> P v m (Token NameSegment) -> P v m (Token NameSegment)
forall a b. (a -> b) -> a -> b
$ (Lexeme -> Maybe NameSegment) -> P v m (Token NameSegment)
forall v a (m :: * -> *).
Ord v =>
(Lexeme -> Maybe a) -> P v m (Token a)
queryToken Lexeme -> Maybe NameSegment
getBlank
  where
    getBlank :: Lexeme -> Maybe NameSegment
getBlank (L.WordyId HashQualified Name
n) = if HashQualified Name -> Bool
isBlank' HashQualified Name
n then NameSegment -> Maybe NameSegment
forall a. a -> Maybe a
Just (Name -> NameSegment
Name.lastSegment (Name -> NameSegment) -> Name -> NameSegment
forall a b. (a -> b) -> a -> b
$ HashQualified Name -> Name
forall n. HashQualified n -> n
HQ'.toName HashQualified Name
n) else Maybe NameSegment
forall a. Maybe a
Nothing
    getBlank Lexeme
_ = Maybe NameSegment
forall a. Maybe a
Nothing

numeric :: (Ord v) => P v m (L.Token String)
numeric :: forall v (m :: * -> *). Ord v => P v m (Token String)
numeric = (Lexeme -> Maybe String) -> P v m (Token String)
forall v a (m :: * -> *).
Ord v =>
(Lexeme -> Maybe a) -> P v m (Token a)
queryToken Lexeme -> Maybe String
getNumeric
  where
    getNumeric :: Lexeme -> Maybe String
getNumeric (L.Numeric String
s) = String -> Maybe String
forall a. a -> Maybe a
Just String
s
    getNumeric Lexeme
_ = Maybe String
forall a. Maybe a
Nothing

bytesToken :: (Ord v) => P v m (L.Token Bytes)
bytesToken :: forall v (m :: * -> *). Ord v => P v m (Token Bytes)
bytesToken = (Lexeme -> Maybe Bytes) -> P v m (Token Bytes)
forall v a (m :: * -> *).
Ord v =>
(Lexeme -> Maybe a) -> P v m (Token a)
queryToken Lexeme -> Maybe Bytes
getBytes
  where
    getBytes :: Lexeme -> Maybe Bytes
getBytes (L.Bytes Bytes
bs) = Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just Bytes
bs
    getBytes Lexeme
_ = Maybe Bytes
forall a. Maybe a
Nothing

sepBy :: (Ord v) => P v m a -> P v m b -> P v m [b]
sepBy :: forall v (m :: * -> *) a b.
Ord v =>
P v m a -> P v m b -> P v m [b]
sepBy P v m a
sep P v m b
pb = P v m b
-> P v m a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) [b]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
P.sepBy P v m b
pb P v m a
sep

sepBy1 :: (Ord v) => P v m a -> P v m b -> P v m [b]
sepBy1 :: forall v (m :: * -> *) a b.
Ord v =>
P v m a -> P v m b -> P v m [b]
sepBy1 P v m a
sep P v m b
pb = P v m b
-> P v m a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) [b]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
P.sepBy1 P v m b
pb P v m a
sep

sepEndBy :: (Ord v) => P v m a -> P v m b -> P v m [b]
sepEndBy :: forall v (m :: * -> *) a b.
Ord v =>
P v m a -> P v m b -> P v m [b]
sepEndBy P v m a
sep P v m b
pb = P v m b
-> P v m a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) [b]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
P.sepEndBy P v m b
pb P v m a
sep

character :: (Ord v) => P v m (L.Token Char)
character :: forall v (m :: * -> *). Ord v => P v m (Token Char)
character = (Lexeme -> Maybe Char) -> P v m (Token Char)
forall v a (m :: * -> *).
Ord v =>
(Lexeme -> Maybe a) -> P v m (Token a)
queryToken Lexeme -> Maybe Char
getChar
  where
    getChar :: Lexeme -> Maybe Char
getChar (L.Character Char
c) = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
c
    getChar Lexeme
_ = Maybe Char
forall a. Maybe a
Nothing

string :: (Ord v) => P v m (L.Token Text)
string :: forall v (m :: * -> *). Ord v => P v m (Token Text)
string = (Lexeme -> Maybe Text) -> P v m (Token Text)
forall v a (m :: * -> *).
Ord v =>
(Lexeme -> Maybe a) -> P v m (Token a)
queryToken Lexeme -> Maybe Text
getString
  where
    getString :: Lexeme -> Maybe Text
getString (L.Textual String
s) = Text -> Maybe Text
forall a. a -> Maybe a
Just (String -> Text
Text.pack String
s)
    getString Lexeme
_ = Maybe Text
forall a. Maybe a
Nothing

doc ::
  (Ord v) =>
  P v m (L.Token (Doc.UntitledSection (Doc.Tree (L.Token (ReferenceType, HQ'.HashQualified Name)) [L.Token L.Lexeme])))
doc :: forall v (m :: * -> *).
Ord v =>
P v
  m
  (Token
     (UntitledSection
        (Tree (Token (ReferenceType, HashQualified Name)) [Token Lexeme])))
doc = (Lexeme
 -> Maybe
      (UntitledSection
         (Tree (Token (ReferenceType, HashQualified Name)) [Token Lexeme])))
-> P v
     m
     (Token
        (UntitledSection
           (Tree (Token (ReferenceType, HashQualified Name)) [Token Lexeme])))
forall v a (m :: * -> *).
Ord v =>
(Lexeme -> Maybe a) -> P v m (Token a)
queryToken \case
  L.Doc UntitledSection
  (Tree (Token (ReferenceType, HashQualified Name)) [Token Lexeme])
d -> UntitledSection
  (Tree (Token (ReferenceType, HashQualified Name)) [Token Lexeme])
-> Maybe
     (UntitledSection
        (Tree (Token (ReferenceType, HashQualified Name)) [Token Lexeme]))
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UntitledSection
  (Tree (Token (ReferenceType, HashQualified Name)) [Token Lexeme])
d
  Lexeme
_ -> Maybe
  (UntitledSection
     (Tree (Token (ReferenceType, HashQualified Name)) [Token Lexeme]))
forall a. Maybe a
Nothing

-- | Parses a tuple of 'a's, or a single parenthesized 'a'
--
-- returns the result of combining elements with 'pair', alongside the annotation containing
-- the full parenthesized expression.
tupleOrParenthesized :: (Ord v) => P v m a -> (Ann -> a) -> (a -> a -> a) -> P v m (Ann {- spanAnn -}, a)
tupleOrParenthesized :: forall v (m :: * -> *) a.
Ord v =>
P v m a -> (Ann -> a) -> (a -> a -> a) -> P v m (Ann, a)
tupleOrParenthesized P v m a
p Ann -> a
unit a -> a -> a
pair = do
  String -> (Ann -> [a] -> (Ann, a)) -> P v m a -> P v m (Ann, a)
forall v a b (m :: * -> *).
Ord v =>
String -> (Ann -> [a] -> b) -> P v m a -> P v m b
seq' String
"(" Ann -> [a] -> (Ann, a)
go P v m a
p
  where
    go :: Ann -> [a] -> (Ann, a)
go Ann
ann [a
t] = (Ann
ann, a
t)
    go Ann
ann (a
t : [a]
ts) = (Ann
ann, (a -> a -> a) -> a -> NonEmpty a -> a
forall a b. (a -> b -> b) -> b -> NonEmpty a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> a -> a
pair (Ann -> a
unit Ann
forall a. Monoid a => a
mempty) (a
t a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
Nel.:| [a]
ts))
    go Ann
ann [] = (Ann
ann, Ann -> a
unit Ann
ann)

seq :: (Ord v) => (Ann -> [a] -> a) -> P v m a -> P v m a
seq :: forall v a (m :: * -> *).
Ord v =>
(Ann -> [a] -> a) -> P v m a -> P v m a
seq = String -> (Ann -> [a] -> a) -> P v m a -> P v m a
forall v a b (m :: * -> *).
Ord v =>
String -> (Ann -> [a] -> b) -> P v m a -> P v m b
seq' String
"["

seq' :: (Ord v) => String -> (Ann -> [a] -> b) -> P v m a -> P v m b
seq' :: forall v a b (m :: * -> *).
Ord v =>
String -> (Ann -> [a] -> b) -> P v m a -> P v m b
seq' String
openStr Ann -> [a] -> b
f P v m a
p = do
  Token ()
open <- String -> P v m (Token ())
forall v (m :: * -> *). Ord v => String -> P v m (Token ())
openBlockWith String
openStr P v m (Token ())
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ()
-> P v m (Token ())
forall a b.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) b
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ()
forall {m :: * -> *}.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ()
redundant
  [a]
es <- P v m (Token String) -> P v m a -> P v m [a]
forall v (m :: * -> *) a b.
Ord v =>
P v m a -> P v m b -> P v m [b]
sepEndBy (P v m (Token String) -> P v m (Token String)
forall a.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try (P v m (Token String) -> P v m (Token String))
-> P v m (Token String) -> P v m (Token String)
forall a b. (a -> b) -> a -> b
$ P v m (Token ())
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Maybe (Token ()))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional P v m (Token ())
forall v (m :: * -> *). Ord v => P v m (Token ())
semi ParsecT
  (Error v) Input (ReaderT (ParsingEnv m) m) (Maybe (Token ()))
-> P v m (Token String) -> P v m (Token String)
forall a b.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) b
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> String -> P v m (Token String)
forall v (m :: * -> *). Ord v => String -> P v m (Token String)
reserved String
"," P v m (Token String)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ()
-> P v m (Token String)
forall a b.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) b
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ()
forall {m :: * -> *}.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ()
redundant) P v m a
p
  Token ()
close <- ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ()
forall {m :: * -> *}.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ()
redundant ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ()
-> P v m (Token ()) -> P v m (Token ())
forall a b.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) b
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> P v m (Token ())
forall v (m :: * -> *). Ord v => P v m (Token ())
closeBlock
  pure (Ann -> [a] -> b
f (Token () -> Ann
forall a. Annotated a => a -> Ann
ann Token ()
open Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
<> Token () -> Ann
forall a. Annotated a => a -> Ann
ann Token ()
close) [a]
es)
  where
    redundant :: ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ()
redundant = ParsecT
  (Error v)
  Input
  (ReaderT (ParsingEnv m) m)
  (Either (Token String) (Token ()))
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ()
forall (m :: * -> *) a. MonadPlus m => m a -> m ()
P.skipMany (ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token String)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token ())
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (Either (Token String) (Token ()))
forall (m :: * -> *) a b.
Alternative m =>
m a -> m b -> m (Either a b)
P.eitherP (String
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token String)
forall v (m :: * -> *). Ord v => String -> P v m (Token String)
reserved String
",") ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token ())
forall v (m :: * -> *). Ord v => P v m (Token ())
semi)

chainr1 :: (Ord v) => P v m a -> P v m (a -> a -> a) -> P v m a
chainr1 :: forall v (m :: * -> *) a.
Ord v =>
P v m a -> P v m (a -> a -> a) -> P v m a
chainr1 P v m a
p P v m (a -> a -> a)
op = P v m a
go1
  where
    go1 :: P v m a
go1 = P v m a
p P v m a -> (a -> P v m a) -> P v m a
forall a b.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> (a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) b)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> P v m a
go2
    go2 :: a -> P v m a
go2 a
hd = do { a -> a -> a
op <- P v m (a -> a -> a)
op; a -> a -> a
op a
hd (a -> a) -> P v m a -> P v m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P v m a
go1 } P v m a -> P v m a -> P v m a
forall a.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> a -> P v m a
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
hd

-- | Parse `p` 1+ times, combining with `op`
chainl1 :: (Ord v) => P v m a -> P v m (a -> a -> a) -> P v m a
chainl1 :: forall v (m :: * -> *) a.
Ord v =>
P v m a -> P v m (a -> a -> a) -> P v m a
chainl1 P v m a
p P v m (a -> a -> a)
op = (a -> (a -> a) -> a) -> a -> [a -> a] -> a
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (((a -> a) -> a -> a) -> a -> (a -> a) -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
($)) (a -> [a -> a] -> a)
-> P v m a
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) ([a -> a] -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P v m a
p ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ([a -> a] -> a)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) [a -> a]
-> P v m a
forall a b.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (a -> b)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (a -> a)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) [a -> a]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.many ((a -> a -> a) -> a -> a -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((a -> a -> a) -> a -> a -> a)
-> P v m (a -> a -> a) -> P v m (a -> a -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P v m (a -> a -> a)
op P v m (a -> a -> a)
-> P v m a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (a -> a)
forall a b.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (a -> b)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> P v m a
p)

-- chainl1Accum is like chainl1, but it accumulates intermediate results
-- instead of applying them immediately. It's used to implement infix
-- operators that may or may not have precedence rules.
chainl1Accum ::
  (P.Stream u, Ord s) =>
  P.ParsecT s u m a ->
  P.ParsecT s u m (a -> a -> a) ->
  P.ParsecT s u m (a, [a -> a])
chainl1Accum :: forall u s (m :: * -> *) a.
(Stream u, Ord s) =>
ParsecT s u m a
-> ParsecT s u m (a -> a -> a) -> ParsecT s u m (a, [a -> a])
chainl1Accum ParsecT s u m a
p ParsecT s u m (a -> a -> a)
op = do
  a
x <- ParsecT s u m a
p
  [a -> a]
fs <- [a -> a] -> ParsecT s u m [a -> a]
rest []
  pure (a
x, [a -> a]
fs)
  where
    rest :: [a -> a] -> ParsecT s u m [a -> a]
rest [a -> a]
fs =
      ( do
          a -> a -> a
f <- ParsecT s u m (a -> a -> a)
op
          a
y <- ParsecT s u m a
p
          [a -> a] -> ParsecT s u m [a -> a]
rest ([a -> a]
fs [a -> a] -> [a -> a] -> [a -> a]
forall a. [a] -> [a] -> [a]
++ [(a -> a -> a) -> a -> a -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> a -> a
f a
y])
      )
        ParsecT s u m [a -> a]
-> ParsecT s u m [a -> a] -> ParsecT s u m [a -> a]
forall a. ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [a -> a] -> ParsecT s u m [a -> a]
forall a. a -> ParsecT s u m a
forall (m :: * -> *) a. Monad m => a -> m a
return [a -> a]
fs

-- | If `p` would succeed, this fails uncommitted.
--   Otherwise, `failIfOk` used to produce the output
failureIf :: (Ord v) => P v m (P v m b) -> P v m a -> P v m b
failureIf :: forall v (m :: * -> *) b a.
Ord v =>
P v m (P v m b) -> P v m a -> P v m b
failureIf P v m (P v m b)
failIfOk P v m a
p = do
  P v m b
dontwant <- P v m (P v m b) -> P v m (P v m b)
forall a.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try (P v m (P v m b) -> P v m (P v m b))
-> (P v m (P v m b) -> P v m (P v m b))
-> P v m (P v m b)
-> P v m (P v m b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. P v m (P v m b) -> P v m (P v m b)
forall a.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.lookAhead (P v m (P v m b) -> P v m (P v m b))
-> P v m (P v m b) -> P v m (P v m b)
forall a b. (a -> b) -> a -> b
$ P v m (P v m b)
failIfOk
  Maybe a
p <- ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Maybe a)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Maybe a)
forall a.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try (ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Maybe a)
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Maybe a))
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Maybe a)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Maybe a)
forall a b. (a -> b) -> a -> b
$ ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Maybe a)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Maybe a)
forall a.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.lookAhead (P v m a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Maybe a)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional P v m a
p)
  Bool
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ()
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe a -> Bool
forall a. Maybe a -> Bool
isJust Maybe a
p) (ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ()
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ())
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ()
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ()
forall a b. (a -> b) -> a -> b
$ String -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ()
forall a.
String -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"failureIf"
  P v m b
dontwant

-- | Gives this var an id based on its position - a useful trick to
--   obtain a variable whose id won't match any other id in the file
--  `positionalVar a Var.missingResult`
positionalVar :: (Annotated a, Var v) => a -> v -> v
positionalVar :: forall a v. (Annotated a, Var v) => a -> v -> v
positionalVar a
a v
v =
  let s :: Pos
s = Ann -> Pos
start (a -> Ann
forall a. Annotated a => a -> Ann
ann a
a)
      line :: Word64
line = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Int -> Word64
forall a b. (a -> b) -> a -> b
$ Pos -> Int
L.line Pos
s
      col :: Word64
col = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Int -> Word64
forall a b. (a -> b) -> a -> b
$ Pos -> Int
L.column Pos
s
   in -- this works as long as no lines more than 50k characters
      Word64 -> v -> v
forall v. Var v => Word64 -> v -> v
Var.freshenId (Word64
line Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
50000 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
col) v
v