{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE PartialTypeSignatures #-}

module Unison.Syntax.TermParser
  ( binding,
    blockTerm,
    doc2Block,
    imports,
    lam,
    substImports,
    term,
    verifyRelativeVarName,
  )
where

import Control.Comonad.Trans.Cofree (CofreeF ((:<)))
import Control.Monad.Reader (asks, local)
import Data.Bitraversable (bitraverse)
import Data.Char qualified as Char
import Data.Foldable (foldrM)
import Data.List qualified as List
import Data.List.Extra qualified as List.Extra
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.List.NonEmpty qualified as NonEmpty
import Data.Maybe qualified as Maybe
import Data.Sequence qualified as Sequence
import Data.Set qualified as Set
import Data.Text qualified as Text
import Data.Tuple.Extra qualified as TupleE
import Text.Megaparsec qualified as P
import U.Codebase.Reference (ReferenceType (..))
import U.Core.ABT qualified as ABT
import Unison.ABT qualified as ABT
import Unison.Builtin.Decls qualified as DD
import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..))
import Unison.ConstructorType qualified as CT
import Unison.HashQualified qualified as HQ
import Unison.HashQualifiedPrime qualified as HQ'
import Unison.Name (Name)
import Unison.Name qualified as Name
import Unison.NameSegment qualified as NameSegment
import Unison.Names (Names)
import Unison.Names qualified as Names
import Unison.Names.ResolutionResult (ResolutionError (..), ResolutionFailure (..))
import Unison.NamesWithHistory qualified as Names
import Unison.Parser.Ann (Ann (Ann))
import Unison.Parser.Ann qualified as Ann
import Unison.Pattern (Pattern)
import Unison.Pattern qualified as Pattern
import Unison.Prelude
import Unison.Reference (TypeReference)
import Unison.Referent (Referent)
import Unison.Referent qualified as Referent
import Unison.Syntax.Lexer.Unison qualified as L
import Unison.Syntax.Name qualified as Name (toText, toVar, unsafeParseVar)
import Unison.Syntax.NameSegment qualified as NameSegment
import Unison.Syntax.Parser hiding (seq)
import Unison.Syntax.Parser qualified as Parser (seq, uniqueName)
import Unison.Syntax.Parser.Doc.Data qualified as Doc
import Unison.Syntax.Precedence (operatorPrecedence)
import Unison.Syntax.TypeParser qualified as TypeParser
import Unison.Term (IsTop, Term)
import Unison.Term qualified as Term
import Unison.Type (Type)
import Unison.Type qualified as Type
import Unison.Typechecker.Components qualified as Components
import Unison.Util.Bytes qualified as Bytes
import Unison.Util.List (intercalateMapWith, quenchRuns)
import Unison.Util.Recursion
import Unison.Var (Var)
import Unison.Var qualified as Var
import Prelude hiding (and, or, seq)

{-
Precedence of language constructs is identical to Haskell, except that all
operators (like +, <*>, or any sequence of non-alphanumeric characters) are
left-associative and equal precedence (with a few exceptions), and operators
must have surrounding whitespace (a + b, not a+b) to distinguish from
identifiers that may contain operator characters (like empty? or fold-left).

Sections / partial application of infix operators is not implemented.
-}

type TermP v m = P v m (Term v Ann)

term :: (Monad m, Var v) => TermP v m
term :: forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
term = TermP v m
forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
term2

term2 :: (Monad m, Var v) => TermP v m
term2 :: forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
term2 = TermP v m -> TermP v m
forall v (m :: * -> *). Var v => TermP v m -> TermP v m
lam TermP v m
forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
term2 TermP v m -> TermP v m -> TermP v 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
<|> TermP v m
forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
term3

term3 :: (Monad m, Var v) => TermP v m
term3 :: forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
term3 = do
  Term v Ann
t <- TermP v m
forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
infixAppOrBooleanOp
  Maybe (Type v Ann)
ot <- ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Type v Ann)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Maybe (Type v Ann))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (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) (Type v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Type v Ann)
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
*> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Type v Ann)
forall (m :: * -> *) v. (Monad m, Var v) => TypeP v m
TypeParser.computationType)
  pure case Maybe (Type v Ann)
ot of
    Maybe (Type v Ann)
Nothing -> Term v Ann
t
    Just Type v Ann
y -> Ann -> Term v Ann -> Type v Ann -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Type vt at -> Term2 vt at ap v a
Term.ann (Term v Ann -> Type v Ann -> Ann
forall a b. (Annotated a, Annotated b) => a -> b -> Ann
mkAnn Term v Ann
t Type v Ann
y) Term v Ann
t Type v Ann
y

keywordBlock :: (Monad m, Var v) => TermP v m
keywordBlock :: forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
keywordBlock = TermP v m
forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
letBlock TermP v m -> TermP v m -> TermP v 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
<|> TermP v m
forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
handle TermP v m -> TermP v m -> TermP v 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
<|> TermP v m
forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
ifthen TermP v m -> TermP v m -> TermP v 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
<|> TermP v m
forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
match TermP v m -> TermP v m -> TermP v 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
<|> TermP v m
forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
lamCase TermP v m -> TermP v m -> TermP v 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
<|> TermP v m
forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
rewriteBlock

rewriteBlock :: (Monad m, Var v) => TermP v m
rewriteBlock :: forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
rewriteBlock = do
  Token ()
t <- String -> P v m (Token ())
forall v (m :: * -> *). Ord v => String -> P v m (Token ())
openBlockWith String
"@rewrite"
  [Term2 v Ann Ann v Ann]
elements <- P v m (Token ()) -> TermP v m -> P v m [Term2 v Ann Ann v Ann]
forall v (m :: * -> *) a b.
Ord v =>
P v m a -> P v m b -> P v m [b]
sepBy P v m (Token ())
forall v (m :: * -> *). Ord v => P v m (Token ())
semi (TermP v m
rewriteTerm TermP v m -> TermP v m -> TermP v 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
<|> TermP v m
rewriteCase TermP v m -> TermP v m -> TermP v 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
<|> TermP v m
rewriteType)
  Token ()
b <- P v m (Token ())
forall v (m :: * -> *). Ord v => P v m (Token ())
closeBlock
  pure (Ann -> [Term2 v Ann Ann v Ann] -> Term2 v Ann Ann v Ann
forall v a vt at ap.
(Var v, Monoid a) =>
a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
DD.rewrites (Token () -> Ann
forall a. Annotated a => a -> Ann
ann Token ()
t Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
<> Token () -> Ann
forall a. Annotated a => a -> Ann
ann Token ()
b) [Term2 v Ann Ann v Ann]
elements)
  where
    rewriteTermlike :: Text
-> (Ann -> Term v Ann -> Term v Ann -> b)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) b
rewriteTermlike Text
kw Ann -> Term v Ann -> Term v Ann -> b
mk = do
      Token ()
kw <- Text -> P v m (Token ())
forall v (m :: * -> *). Ord v => Text -> P v m (Token ())
quasikeyword Text
kw
      Term v Ann
lhs <- TermP v m
forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
term
      (Ann
_spanAnn, Term v Ann
rhs) <- String -> P v m (Ann, Term v Ann)
forall (m :: * -> *) v.
(Monad m, Var v) =>
String -> P v m (Ann, Term v Ann)
layoutBlock String
"==>"
      pure (Ann -> Term v Ann -> Term v Ann -> b
mk (Token () -> Ann
forall a. Annotated a => a -> Ann
ann Token ()
kw Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
<> Term v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term v Ann
rhs) Term v Ann
lhs Term v Ann
rhs)
    rewriteTerm :: TermP v m
rewriteTerm = Text
-> (Ann
    -> Term2 v Ann Ann v Ann
    -> Term2 v Ann Ann v Ann
    -> Term2 v Ann Ann v Ann)
-> TermP v m
forall {v} {m :: * -> *} {b}.
(Monad m, Var v) =>
Text
-> (Ann -> Term v Ann -> Term v Ann -> b)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) b
rewriteTermlike Text
"term" Ann
-> Term2 v Ann Ann v Ann
-> Term2 v Ann Ann v Ann
-> Term2 v Ann Ann v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
DD.rewriteTerm
    rewriteCase :: TermP v m
rewriteCase = Text
-> (Ann
    -> Term2 v Ann Ann v Ann
    -> Term2 v Ann Ann v Ann
    -> Term2 v Ann Ann v Ann)
-> TermP v m
forall {v} {m :: * -> *} {b}.
(Monad m, Var v) =>
Text
-> (Ann -> Term v Ann -> Term v Ann -> b)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) b
rewriteTermlike Text
"case" Ann
-> Term2 v Ann Ann v Ann
-> Term2 v Ann Ann v Ann
-> Term2 v Ann Ann v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
DD.rewriteCase
    rewriteType :: TermP v m
rewriteType = do
      Token ()
kw <- Text -> P v m (Token ())
forall v (m :: * -> *). Ord v => Text -> P v m (Token ())
quasikeyword Text
"signature"
      [Token v]
vs <- ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) [Token v]
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) [Token v]
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) (Token v)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) [Token v]
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]
some ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token v)
forall v (m :: * -> *). Var v => P v m (Token v)
prefixDefinitionName ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) [Token v]
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token String)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) [Token v]
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
<* 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 v]
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) [Token v]
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) 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
<|> [Token v]
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) [Token v]
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      Type v Ann
lhs <- TypeP v m
forall (m :: * -> *) v. (Monad m, Var v) => TypeP v m
TypeParser.computationType
      Type v Ann
rhs <- String -> P v m (Token ())
forall v (m :: * -> *). Ord v => String -> P v m (Token ())
openBlockWith String
"==>" P v m (Token ()) -> TypeP v m -> TypeP v m
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
*> TypeP v m
forall (m :: * -> *) v. (Monad m, Var v) => TypeP v m
TypeParser.computationType TypeP v m -> P v m (Token ()) -> TypeP v m
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
<* P v m (Token ())
forall v (m :: * -> *). Ord v => P v m (Token ())
closeBlock
      pure (Ann -> [v] -> Type v Ann -> Type v Ann -> Term2 v Ann Ann v Ann
forall v a.
(Var v, Semigroup a) =>
a -> [v] -> Type v a -> Type v a -> Term2 v a a v a
DD.rewriteType (Token () -> Ann
forall a. Annotated a => a -> Ann
ann Token ()
kw Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
<> Type v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Type v Ann
rhs) (Token v -> v
forall a. Token a -> a
L.payload (Token v -> v) -> [Token v] -> [v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Token v]
vs) Type v Ann
lhs Type v Ann
rhs)

typeLink' :: (Monad m, Var v) => P v m (L.Token TypeReference)
typeLink' :: forall (m :: * -> *) v.
(Monad m, Var v) =>
P v m (Token TypeReference)
typeLink' = Token (HashQualified Name) -> P v m (Token TypeReference)
forall (m :: * -> *) v.
(Monad m, Var v) =>
Token (HashQualified Name) -> P v m (Token TypeReference)
findUniqueType (Token (HashQualified Name) -> P v m (Token TypeReference))
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (Token (HashQualified Name))
-> P v m (Token TypeReference)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ParsecT
  (Error v)
  Input
  (ReaderT (ParsingEnv m) m)
  (Token (HashQualified Name))
forall v (m :: * -> *). Ord v => P v m (Token (HashQualified Name))
hqPrefixId

findUniqueType :: (Monad m, Var v) => L.Token (HQ.HashQualified Name) -> P v m (L.Token TypeReference)
findUniqueType :: forall (m :: * -> *) v.
(Monad m, Var v) =>
Token (HashQualified Name) -> P v m (Token TypeReference)
findUniqueType Token (HashQualified Name)
id =
  Token (HashQualified Name) -> P v m (Maybe TypeReference)
forall (m :: * -> *) v.
(Monad m, Ord v) =>
Token (HashQualified Name) -> P v m (Maybe TypeReference)
resolveToLocalNamespacedType Token (HashQualified Name)
id P v m (Maybe TypeReference)
-> (Maybe TypeReference
    -> ParsecT
         (Error v) Input (ReaderT (ParsingEnv m) m) (Token TypeReference))
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token TypeReference)
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 TypeReference
Nothing -> do
      Names
ns <- (ParsingEnv m -> Names)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) Names
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ParsingEnv m -> Names
forall (m :: * -> *). ParsingEnv m -> Names
names
      case SearchType -> HashQualified Name -> Names -> Set TypeReference
Names.lookupHQType SearchType
Names.IncludeSuffixes (Token (HashQualified Name) -> HashQualified Name
forall a. Token a -> a
L.payload Token (HashQualified Name)
id) Names
ns of
        Set TypeReference
s
          | Set TypeReference -> Int
forall a. Set a -> Int
Set.size Set TypeReference
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> Token TypeReference
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token TypeReference)
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set TypeReference -> TypeReference
forall a. Set a -> a
Set.findMin Set TypeReference
s TypeReference -> Token (HashQualified Name) -> Token TypeReference
forall a b. a -> Token b -> Token a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Token (HashQualified Name)
id)
          | Bool
otherwise -> Error v
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token TypeReference)
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure (Error v
 -> ParsecT
      (Error v) Input (ReaderT (ParsingEnv m) m) (Token TypeReference))
-> Error v
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token TypeReference)
forall a b. (a -> b) -> a -> b
$ Token (HashQualified Name) -> Set TypeReference -> Error v
forall v.
Token (HashQualified Name) -> Set TypeReference -> Error v
UnknownType Token (HashQualified Name)
id Set TypeReference
s
    Just TypeReference
ref -> Token TypeReference
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token TypeReference)
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeReference
ref TypeReference -> Token (HashQualified Name) -> Token TypeReference
forall a b. a -> Token b -> Token a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Token (HashQualified Name)
id)

termLink' :: (Monad m, Var v) => P v m (L.Token Referent)
termLink' :: forall (m :: * -> *) v. (Monad m, Var v) => P v m (Token Referent)
termLink' = do
  Token (HashQualified Name)
id <- P v m (Token (HashQualified Name))
forall v (m :: * -> *). Ord v => P v m (Token (HashQualified Name))
hqPrefixId
  Names
ns <- (ParsingEnv m -> Names)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) Names
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ParsingEnv m -> Names
forall (m :: * -> *). ParsingEnv m -> Names
names
  case SearchType -> HashQualified Name -> Names -> Set Referent
Names.lookupHQTerm SearchType
Names.IncludeSuffixes (Token (HashQualified Name) -> HashQualified Name
forall a. Token a -> a
L.payload Token (HashQualified Name)
id) Names
ns of
    Set Referent
s
      | Set Referent -> Int
forall a. Set a -> Int
Set.size Set Referent
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> Token Referent -> P v m (Token Referent)
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Token Referent -> P v m (Token Referent))
-> Token Referent -> P v m (Token Referent)
forall a b. (a -> b) -> a -> b
$ Referent -> HashQualified Name -> Referent
forall a b. a -> b -> a
const (Set Referent -> Referent
forall a. Set a -> a
Set.findMin Set Referent
s) (HashQualified Name -> Referent)
-> Token (HashQualified Name) -> Token Referent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Token (HashQualified Name)
id
      | Bool
otherwise -> Error v -> P v m (Token Referent)
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure (Error v -> P v m (Token Referent))
-> Error v -> P v m (Token Referent)
forall a b. (a -> b) -> a -> b
$ Token (HashQualified Name) -> Set Referent -> Error v
forall v. Token (HashQualified Name) -> Set Referent -> Error v
UnknownTerm Token (HashQualified Name)
id Set Referent
s

link' :: (Monad m, Var v) => P v m (Either (L.Token TypeReference) (L.Token Referent))
link' :: forall (m :: * -> *) v.
(Monad m, Var v) =>
P v m (Either (Token TypeReference) (Token Referent))
link' = do
  Token (HashQualified Name)
id <- P v m (Token (HashQualified Name))
forall v (m :: * -> *). Ord v => P v m (Token (HashQualified Name))
hqPrefixId
  Names
ns <- (ParsingEnv m -> Names)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) Names
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ParsingEnv m -> Names
forall (m :: * -> *). ParsingEnv m -> Names
names
  let s :: Set Referent
s = SearchType -> HashQualified Name -> Names -> Set Referent
Names.lookupHQTerm SearchType
Names.IncludeSuffixes (Token (HashQualified Name) -> HashQualified Name
forall a. Token a -> a
L.payload Token (HashQualified Name)
id) Names
ns
  let s2 :: Set TypeReference
s2 = SearchType -> HashQualified Name -> Names -> Set TypeReference
Names.lookupHQType SearchType
Names.IncludeSuffixes (Token (HashQualified Name) -> HashQualified Name
forall a. Token a -> a
L.payload Token (HashQualified Name)
id) Names
ns
  if
    | Set Referent -> Int
forall a. Set a -> Int
Set.size Set Referent
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Set TypeReference -> Bool
forall a. Set a -> Bool
Set.null Set TypeReference
s2 -> Either (Token TypeReference) (Token Referent)
-> P v m (Either (Token TypeReference) (Token Referent))
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Token TypeReference) (Token Referent)
 -> P v m (Either (Token TypeReference) (Token Referent)))
-> (Token Referent
    -> Either (Token TypeReference) (Token Referent))
-> Token Referent
-> P v m (Either (Token TypeReference) (Token Referent))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token Referent -> Either (Token TypeReference) (Token Referent)
forall a b. b -> Either a b
Right (Token Referent
 -> P v m (Either (Token TypeReference) (Token Referent)))
-> Token Referent
-> P v m (Either (Token TypeReference) (Token Referent))
forall a b. (a -> b) -> a -> b
$ Set Referent -> Referent
forall a. Set a -> a
Set.findMin Set Referent
s Referent -> Token (HashQualified Name) -> Token Referent
forall a b. a -> Token b -> Token a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Token (HashQualified Name)
id
    | Set TypeReference -> Int
forall a. Set a -> Int
Set.size Set TypeReference
s2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Set Referent -> Bool
forall a. Set a -> Bool
Set.null Set Referent
s -> Either (Token TypeReference) (Token Referent)
-> P v m (Either (Token TypeReference) (Token Referent))
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Token TypeReference) (Token Referent)
 -> P v m (Either (Token TypeReference) (Token Referent)))
-> (Token TypeReference
    -> Either (Token TypeReference) (Token Referent))
-> Token TypeReference
-> P v m (Either (Token TypeReference) (Token Referent))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token TypeReference
-> Either (Token TypeReference) (Token Referent)
forall a b. a -> Either a b
Left (Token TypeReference
 -> P v m (Either (Token TypeReference) (Token Referent)))
-> Token TypeReference
-> P v m (Either (Token TypeReference) (Token Referent))
forall a b. (a -> b) -> a -> b
$ Set TypeReference -> TypeReference
forall a. Set a -> a
Set.findMin Set TypeReference
s2 TypeReference -> Token (HashQualified Name) -> Token TypeReference
forall a b. a -> Token b -> Token a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Token (HashQualified Name)
id
    | Bool
True -> Error v -> P v m (Either (Token TypeReference) (Token Referent))
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure (Error v -> P v m (Either (Token TypeReference) (Token Referent)))
-> Error v -> P v m (Either (Token TypeReference) (Token Referent))
forall a b. (a -> b) -> a -> b
$ Token (HashQualified Name)
-> Set Referent -> Set TypeReference -> Error v
forall v.
Token (HashQualified Name)
-> Set Referent -> Set TypeReference -> Error v
UnknownId Token (HashQualified Name)
id Set Referent
s Set TypeReference
s2

link :: (Monad m, Var v) => TermP v m
link :: forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
link = ParsecT
  (Error v) Input (ReaderT (ParsingEnv m) m) (Term2 v Ann Ann v Ann)
forall {vt} {at} {ap}.
ParsecT
  (Error v) Input (ReaderT (ParsingEnv m) m) (Term2 vt at ap v Ann)
termLink ParsecT
  (Error v) Input (ReaderT (ParsingEnv m) m) (Term2 v Ann Ann v Ann)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Term2 v Ann Ann v Ann)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Term2 v Ann Ann v Ann)
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) (Term2 v Ann Ann v Ann)
forall {vt} {at} {ap}.
ParsecT
  (Error v) Input (ReaderT (ParsingEnv m) m) (Term2 vt at ap v Ann)
typeLink
  where
    typeLink :: ParsecT
  (Error v) Input (ReaderT (ParsingEnv m) m) (Term2 vt at ap v Ann)
typeLink = do
      Token String
_ <- String -> P v m (Token String)
forall v (m :: * -> *). Ord v => String -> P v m (Token String)
reserved String
"typeLink" -- type opens a block, gotta use something else
      Token TypeReference
tok <- P v m (Token TypeReference)
forall (m :: * -> *) v.
(Monad m, Var v) =>
P v m (Token TypeReference)
typeLink'
      pure $ Ann -> TypeReference -> Term2 vt at ap v Ann
forall v a vt at ap.
Ord v =>
a -> TypeReference -> Term2 vt at ap v a
Term.typeLink (Token TypeReference -> Ann
forall a. Annotated a => a -> Ann
ann Token TypeReference
tok) (Token TypeReference -> TypeReference
forall a. Token a -> a
L.payload Token TypeReference
tok)
    termLink :: ParsecT
  (Error v) Input (ReaderT (ParsingEnv m) m) (Term2 vt at ap v Ann)
termLink = do
      Token String
_ <- String -> P v m (Token String)
forall v (m :: * -> *). Ord v => String -> P v m (Token String)
reserved String
"termLink"
      Token Referent
tok <- P v m (Token Referent)
forall (m :: * -> *) v. (Monad m, Var v) => P v m (Token Referent)
termLink'
      pure $ Ann -> Referent -> Term2 vt at ap v Ann
forall v a vt at ap. Ord v => a -> Referent -> Term2 vt at ap v a
Term.termLink (Token Referent -> Ann
forall a. Annotated a => a -> Ann
ann Token Referent
tok) (Token Referent -> Referent
forall a. Token a -> a
L.payload Token Referent
tok)

resolveToLocalNamespacedType :: (Monad m, Ord v) => L.Token (HQ.HashQualified Name) -> P v m (Maybe TypeReference)
resolveToLocalNamespacedType :: forall (m :: * -> *) v.
(Monad m, Ord v) =>
Token (HashQualified Name) -> P v m (Maybe TypeReference)
resolveToLocalNamespacedType Token (HashQualified Name)
tok =
  case Token (HashQualified Name) -> HashQualified Name
forall a. Token a -> a
L.payload Token (HashQualified Name)
tok of
    HQ.NameOnly Name
name ->
      (ParsingEnv m -> Maybe Name)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Maybe Name)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ParsingEnv m -> Maybe Name
forall (m :: * -> *). ParsingEnv m -> Maybe Name
maybeNamespace ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Maybe Name)
-> (Maybe Name -> P v m (Maybe TypeReference))
-> P v m (Maybe TypeReference)
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 Name
Nothing -> Maybe TypeReference -> P v m (Maybe TypeReference)
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe TypeReference
forall a. Maybe a
Nothing
        Just Name
namespace -> do
          Names
localNames <- (ParsingEnv m -> Names)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) Names
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ParsingEnv m -> Names
forall (m :: * -> *). ParsingEnv m -> Names
localNamespacePrefixedTypesAndConstructors
          pure case SearchType -> HashQualified Name -> Names -> Set TypeReference
Names.lookupHQType SearchType
Names.ExactName (Name -> HashQualified Name
forall n. n -> HashQualified n
HQ.NameOnly (HasCallStack => Name -> Name -> Name
Name -> Name -> Name
Name.joinDot Name
namespace Name
name)) Names
localNames of
            Set TypeReference
refs
              | Set TypeReference -> Bool
forall a. Set a -> Bool
Set.null Set TypeReference
refs -> Maybe TypeReference
forall a. Maybe a
Nothing
              -- 2+ name case is impossible: we looked up exact names in the locally-bound names. Two bindings
              -- with the same name would have been a parse error. So, just take the minimum element from the set,
              -- which we know is a singleton.
              | Bool
otherwise -> TypeReference -> Maybe TypeReference
forall a. a -> Maybe a
Just (Set TypeReference -> TypeReference
forall a. Set a -> a
Set.findMin Set TypeReference
refs)
    HashQualified Name
_ -> Maybe TypeReference -> P v m (Maybe TypeReference)
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe TypeReference
forall a. Maybe a
Nothing

-- We disallow type annotations and lambdas,
-- just function application and operators
blockTerm :: (Monad m, Var v) => TermP v m
blockTerm :: forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
blockTerm = TermP v m -> TermP v m
forall v (m :: * -> *). Var v => TermP v m -> TermP v m
lam TermP v m
forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
term TermP v m -> TermP v m -> TermP v 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
<|> TermP v m
forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
infixAppOrBooleanOp

match :: (Monad m, Var v) => TermP v m
match :: forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
match = do
  Token ()
start <- String -> P v m (Token ())
forall v (m :: * -> *). Ord v => String -> P v m (Token ())
openBlockWith String
"match"
  Term v Ann
scrutinee <- TermP v m
forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
term
  Token ()
_ <- P v m (Token ())
forall v (m :: * -> *). Ord v => P v m (Token ())
optionalCloseBlock
  Token ()
_ <-
    String -> P v m (Token ())
forall v (m :: * -> *). Ord v => String -> P v m (Token ())
openBlockWith String
"with" 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
<|> do
      Token Lexeme
t <- P v m (Token Lexeme)
forall v (m :: * -> *). Ord v => P v m (Token Lexeme)
anyToken
      Error v -> P v m (Token ())
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
P.customFailure (String -> Token Lexeme -> Error v
forall v. String -> Token Lexeme -> Error v
ExpectedBlockOpen String
"with" Token Lexeme
t)
  ([Int]
_arities, [MatchCase Ann (Term v Ann)]
cases) <- [(Int, MatchCase Ann (Term v Ann))]
-> ([Int], [MatchCase Ann (Term v Ann)])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Int, MatchCase Ann (Term v Ann))]
 -> ([Int], [MatchCase Ann (Term v Ann)]))
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     [(Int, MatchCase Ann (Term v Ann))]
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     ([Int], [MatchCase Ann (Term v Ann)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT
  (Error v)
  Input
  (ReaderT (ParsingEnv m) m)
  [(Int, MatchCase Ann (Term v Ann))]
forall (m :: * -> *) v.
(Monad m, Var v) =>
P v m [(Int, MatchCase Ann (Term v Ann))]
matchCases
  Token ()
_ <- P v m (Token ())
forall v (m :: * -> *). Ord v => P v m (Token ())
optionalCloseBlock
  let anns :: Ann
anns = (MatchCase Ann (Term v Ann) -> Ann -> Ann)
-> Ann -> Maybe (MatchCase Ann (Term v Ann)) -> Ann
forall a b. (a -> b -> b) -> b -> Maybe a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
(<>) (Ann -> Ann -> Ann)
-> (MatchCase Ann (Term v Ann) -> Ann)
-> MatchCase Ann (Term v Ann)
-> Ann
-> Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MatchCase Ann (Term v Ann) -> Ann
forall a. Annotated a => a -> Ann
ann) (Token () -> Ann
forall a. Annotated a => a -> Ann
ann Token ()
start) (Maybe (MatchCase Ann (Term v Ann)) -> Ann)
-> Maybe (MatchCase Ann (Term v Ann)) -> Ann
forall a b. (a -> b) -> a -> b
$ [MatchCase Ann (Term v Ann)] -> Maybe (MatchCase Ann (Term v Ann))
forall a. [a] -> Maybe a
lastMay [MatchCase Ann (Term v Ann)]
cases
  pure $ Ann -> Term v Ann -> [MatchCase Ann (Term v Ann)] -> Term v Ann
forall v a vt at.
Ord v =>
a
-> Term2 vt at a v a
-> [MatchCase a (Term2 vt at a v a)]
-> Term2 vt at a v a
Term.match Ann
anns Term v Ann
scrutinee [MatchCase Ann (Term v Ann)]
cases

matchCases :: (Monad m, Var v) => P v m [(Int, Term.MatchCase Ann (Term v Ann))]
matchCases :: forall (m :: * -> *) v.
(Monad m, Var v) =>
P v m [(Int, MatchCase Ann (Term v Ann))]
matchCases = P v m (Token ())
-> P v m (Int, [MatchCase Ann (Term v Ann)])
-> P v m [(Int, [MatchCase Ann (Term v Ann)])]
forall v (m :: * -> *) a b.
Ord v =>
P v m a -> P v m b -> P v m [b]
sepBy P v m (Token ())
forall v (m :: * -> *). Ord v => P v m (Token ())
semi P v m (Int, [MatchCase Ann (Term v Ann)])
forall (m :: * -> *) v.
(Monad m, Var v) =>
P v m (Int, [MatchCase Ann (Term v Ann)])
matchCase P v m [(Int, [MatchCase Ann (Term v Ann)])]
-> ([(Int, [MatchCase Ann (Term v Ann)])]
    -> [(Int, MatchCase Ann (Term v Ann))])
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     [(Int, MatchCase Ann (Term v Ann))]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \[(Int, [MatchCase Ann (Term v Ann)])]
cases_ -> [(Int
n, MatchCase Ann (Term v Ann)
c) | (Int
n, [MatchCase Ann (Term v Ann)]
cs) <- [(Int, [MatchCase Ann (Term v Ann)])]
cases_, MatchCase Ann (Term v Ann)
c <- [MatchCase Ann (Term v Ann)]
cs]

-- Returns the arity of the pattern and the `MatchCase`. Examples:
--
--   (a, b) -> a - b -- arity 1
--   foo, hd +: tl -> foo tl -- arity 2
--
-- Cases with arity greater than 1 are desugared to matching on tuples,
-- so the following are parsed the same:
--
--   42, x -> ...
--   (42, x) -> ...
matchCase :: (Monad m, Var v) => P v m (Int, [Term.MatchCase Ann (Term v Ann)])
matchCase :: forall (m :: * -> *) v.
(Monad m, Var v) =>
P v m (Int, [MatchCase Ann (Term v Ann)])
matchCase = do
  [(Pattern Ann, [(Ann, v)])]
pats <- P v m (Token String)
-> P v m (Pattern Ann, [(Ann, v)])
-> P v m [(Pattern Ann, [(Ann, v)])]
forall v (m :: * -> *) a b.
Ord v =>
P v m a -> P v m b -> P v m [b]
sepBy1 (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
"\",\"" (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
$ String -> P v m (Token String)
forall v (m :: * -> *). Ord v => String -> P v m (Token String)
reserved String
",") P v m (Pattern Ann, [(Ann, v)])
forall (m :: * -> *) v.
(Monad m, Var v) =>
P v m (Pattern Ann, [(Ann, v)])
parsePattern
  let boundVars' :: [v]
boundVars' = [v
v | (Pattern Ann
_, [(Ann, v)]
vs) <- [(Pattern Ann, [(Ann, v)])]
pats, (Ann
_ann, v
v) <- [(Ann, v)]
vs]
      pat :: Pattern Ann
pat = case (Pattern Ann, [(Ann, v)]) -> Pattern Ann
forall a b. (a, b) -> a
fst ((Pattern Ann, [(Ann, v)]) -> Pattern Ann)
-> [(Pattern Ann, [(Ann, v)])] -> [Pattern Ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Pattern Ann, [(Ann, v)])]
pats of
        [Pattern Ann
p] -> Pattern Ann
p
        [Pattern Ann]
pats -> (Pattern Ann -> Pattern Ann -> Pattern Ann)
-> Pattern Ann -> [Pattern Ann] -> Pattern Ann
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Pattern Ann -> Pattern Ann -> Pattern Ann
pair (Ann -> Pattern Ann
forall {loc}. loc -> Pattern loc
unit (Pattern Ann -> Ann
forall a. Annotated a => a -> Ann
ann (Pattern Ann -> Ann)
-> ([Pattern Ann] -> Pattern Ann) -> [Pattern Ann] -> Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pattern Ann] -> Pattern Ann
forall a. HasCallStack => [a] -> a
last ([Pattern Ann] -> Ann) -> [Pattern Ann] -> Ann
forall a b. (a -> b) -> a -> b
$ [Pattern Ann]
pats)) [Pattern Ann]
pats
      unit :: loc -> Pattern loc
unit loc
ann = loc -> ConstructorReference -> [Pattern loc] -> Pattern loc
forall loc.
loc -> ConstructorReference -> [Pattern loc] -> Pattern loc
Pattern.Constructor loc
ann (TypeReference -> ConstructorId -> ConstructorReference
forall r. r -> ConstructorId -> GConstructorReference r
ConstructorReference TypeReference
DD.unitRef ConstructorId
0) []
      pair :: Pattern Ann -> Pattern Ann -> Pattern Ann
pair Pattern Ann
p1 Pattern Ann
p2 = Ann -> ConstructorReference -> [Pattern Ann] -> Pattern Ann
forall loc.
loc -> ConstructorReference -> [Pattern loc] -> Pattern loc
Pattern.Constructor (Pattern Ann -> Ann
forall a. Annotated a => a -> Ann
ann Pattern Ann
p1 Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
<> Pattern Ann -> Ann
forall a. Annotated a => a -> Ann
ann Pattern Ann
p2) (TypeReference -> ConstructorId -> ConstructorReference
forall r. r -> ConstructorId -> GConstructorReference r
ConstructorReference TypeReference
DD.pairRef ConstructorId
0) [Pattern Ann
p1, Pattern Ann
p2]
  let guardedBlocks :: P v m [(Maybe (Term v Ann), Term v Ann)]
guardedBlocks = String
-> P v m [(Maybe (Term v Ann), Term v Ann)]
-> P v m [(Maybe (Term v Ann), Term v Ann)]
forall v a (m :: * -> *).
(Ord v, Show a) =>
String -> P v m a -> P v m a
label String
"pattern guard" (P v m [(Maybe (Term v Ann), Term v Ann)]
 -> P v m [(Maybe (Term v Ann), Term v Ann)])
-> (ParsecT
      (Error v)
      Input
      (ReaderT (ParsingEnv m) m)
      (Maybe (Term v Ann), Term v Ann)
    -> P v m [(Maybe (Term v Ann), Term v Ann)])
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (Maybe (Term v Ann), Term v Ann)
-> P v m [(Maybe (Term v Ann), Term v Ann)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT
  (Error v)
  Input
  (ReaderT (ParsingEnv m) m)
  (Maybe (Term v Ann), Term v Ann)
-> P v m [(Maybe (Term v Ann), Term v Ann)]
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]
some (ParsecT
   (Error v)
   Input
   (ReaderT (ParsingEnv m) m)
   (Maybe (Term v Ann), Term v Ann)
 -> P v m [(Maybe (Term v Ann), Term v Ann)])
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (Maybe (Term v Ann), Term v Ann)
-> P v m [(Maybe (Term v Ann), Term v Ann)]
forall a b. (a -> b) -> a -> b
$ do
        Token String
_ <- String -> P v m (Token String)
forall v (m :: * -> *). Ord v => String -> P v m (Token String)
reserved String
"|"
        Maybe (Term v Ann)
guard <-
          [ParsecT
   (Error v) Input (ReaderT (ParsingEnv m) m) (Maybe (Term v Ann))]
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Maybe (Term v Ann))
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
            [ Maybe (Term v Ann)
forall a. Maybe a
Nothing Maybe (Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token ())
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Maybe (Term v Ann))
forall a b.
a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) b
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token ())
forall v (m :: * -> *). Ord v => Text -> P v m (Token ())
quasikeyword Text
"otherwise",
              Term v Ann -> Maybe (Term v Ann)
forall a. a -> Maybe a
Just (Term v Ann -> Maybe (Term v Ann))
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Maybe (Term v Ann))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
infixAppOrBooleanOp
            ]
        (Ann
_spanAnn, Term v Ann
t) <- String -> P v m (Ann, Term v Ann)
forall (m :: * -> *) v.
(Monad m, Var v) =>
String -> P v m (Ann, Term v Ann)
layoutBlock String
"->"
        pure (Maybe (Term v Ann)
guard, Term v Ann
t)
  let unguardedBlock :: ParsecT
  (Error v)
  Input
  (ReaderT (ParsingEnv m) m)
  (Maybe (Term v Ann), Term v Ann)
unguardedBlock = String
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (Maybe (Term v Ann), Term v Ann)
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (Maybe (Term v Ann), Term v Ann)
forall v a (m :: * -> *).
(Ord v, Show a) =>
String -> P v m a -> P v m a
label String
"case match" do
        (Ann
_spanAnn, Term v Ann
t) <- String -> P v m (Ann, Term v Ann)
forall (m :: * -> *) v.
(Monad m, Var v) =>
String -> P v m (Ann, Term v Ann)
layoutBlock String
"->"
        (Maybe (Term v Ann), Term v Ann)
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (Maybe (Term v Ann), Term v Ann)
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Term v Ann)
forall a. Maybe a
Nothing, Term v Ann
t)
  -- a pattern's RHS is either one or more guards, or a single unguarded block.
  [(Maybe (Term v Ann), Term v Ann)]
guardsAndBlocks <- P v m [(Maybe (Term v Ann), Term v Ann)]
guardedBlocks P v m [(Maybe (Term v Ann), Term v Ann)]
-> P v m [(Maybe (Term v Ann), Term v Ann)]
-> P v m [(Maybe (Term v Ann), Term v Ann)]
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
<|> (forall (f :: * -> *) a. Applicative f => a -> f a
pure @[] ((Maybe (Term v Ann), Term v Ann)
 -> [(Maybe (Term v Ann), Term v Ann)])
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (Maybe (Term v Ann), Term v Ann)
-> P v m [(Maybe (Term v Ann), Term v Ann)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT
  (Error v)
  Input
  (ReaderT (ParsingEnv m) m)
  (Maybe (Term v Ann), Term v Ann)
unguardedBlock)
  let absChain :: t v -> Term f v Ann -> Term f v Ann
absChain t v
vs Term f v Ann
t = (v -> Term f v Ann -> Term f v Ann)
-> Term f v Ann -> t v -> Term f v Ann
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\v
v Term f v Ann
t -> Ann -> v -> Term f v Ann -> Term f v Ann
forall v a (f :: * -> *).
Ord v =>
a -> v -> Term f v a -> Term f v a
ABT.abs' (Term f v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term f v Ann
t) v
v Term f v Ann
t) Term f v Ann
t t v
vs
  let mk :: (Maybe (Term v Ann), Term v Ann) -> MatchCase Ann (Term v Ann)
mk (Maybe (Term v Ann)
guard, Term v Ann
t) = Pattern Ann
-> Maybe (Term v Ann) -> Term v Ann -> MatchCase Ann (Term v Ann)
forall loc a. Pattern loc -> Maybe a -> a -> MatchCase loc a
Term.MatchCase Pattern Ann
pat ((Term v Ann -> Term v Ann)
-> Maybe (Term v Ann) -> Maybe (Term v Ann)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([v] -> Term v Ann -> Term v Ann
forall {t :: * -> *} {v} {f :: * -> *}.
(Foldable t, Ord v) =>
t v -> Term f v Ann -> Term f v Ann
absChain [v]
boundVars') Maybe (Term v Ann)
guard) ([v] -> Term v Ann -> Term v Ann
forall {t :: * -> *} {v} {f :: * -> *}.
(Foldable t, Ord v) =>
t v -> Term f v Ann -> Term f v Ann
absChain [v]
boundVars' Term v Ann
t)
  pure $ ([(Pattern Ann, [(Ann, v)])] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Pattern Ann, [(Ann, v)])]
pats, (Maybe (Term v Ann), Term v Ann) -> MatchCase Ann (Term v Ann)
mk ((Maybe (Term v Ann), Term v Ann) -> MatchCase Ann (Term v Ann))
-> [(Maybe (Term v Ann), Term v Ann)]
-> [MatchCase Ann (Term v Ann)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Maybe (Term v Ann), Term v Ann)]
guardsAndBlocks)

parsePattern :: forall m v. (Monad m, Var v) => P v m (Pattern Ann, [(Ann, v)])
parsePattern :: forall (m :: * -> *) v.
(Monad m, Var v) =>
P v m (Pattern Ann, [(Ann, v)])
parsePattern = String
-> P v m (Pattern Ann, [(Ann, v)])
-> P v m (Pattern Ann, [(Ann, v)])
forall v a (m :: * -> *).
(Ord v, Show a) =>
String -> P v m a -> P v m a
label String
"pattern" P v m (Pattern Ann, [(Ann, v)])
root
  where
    root :: P v m (Pattern Ann, [(Ann, v)])
root = P v m (Pattern Ann, [(Ann, v)])
-> P v
     m
     ((Pattern Ann, [(Ann, v)])
      -> (Pattern Ann, [(Ann, v)]) -> (Pattern Ann, [(Ann, v)]))
-> P v m (Pattern Ann, [(Ann, v)])
forall v (m :: * -> *) a.
Ord v =>
P v m a -> P v m (a -> a -> a) -> P v m a
chainl1 P v m (Pattern Ann, [(Ann, v)])
patternCandidates P v
  m
  ((Pattern Ann, [(Ann, v)])
   -> (Pattern Ann, [(Ann, v)]) -> (Pattern Ann, [(Ann, v)]))
patternInfixApp
    patternCandidates :: P v m (Pattern Ann, [(Ann, v)])
patternCandidates = P v m (Pattern Ann, [(Ann, v)])
constructor P v m (Pattern Ann, [(Ann, v)])
-> P v m (Pattern Ann, [(Ann, v)])
-> P v m (Pattern Ann, [(Ann, 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 (Pattern Ann, [(Ann, v)])
leaf
    patternInfixApp ::
      P
        v
        m
        ( (Pattern Ann, [(Ann, v)]) ->
          (Pattern Ann, [(Ann, v)]) ->
          (Pattern Ann, [(Ann, v)])
        )
    patternInfixApp :: P v
  m
  ((Pattern Ann, [(Ann, v)])
   -> (Pattern Ann, [(Ann, v)]) -> (Pattern Ann, [(Ann, v)]))
patternInfixApp = SeqOp
-> (Pattern Ann, [(Ann, v)])
-> (Pattern Ann, [(Ann, v)])
-> (Pattern Ann, [(Ann, v)])
forall {a}.
SeqOp
-> (Pattern Ann, [a]) -> (Pattern Ann, [a]) -> (Pattern Ann, [a])
f (SeqOp
 -> (Pattern Ann, [(Ann, v)])
 -> (Pattern Ann, [(Ann, v)])
 -> (Pattern Ann, [(Ann, v)]))
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) SeqOp
-> P v
     m
     ((Pattern Ann, [(Ann, v)])
      -> (Pattern Ann, [(Ann, v)]) -> (Pattern Ann, [(Ann, v)]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) SeqOp
forall v (m :: * -> *). Ord v => P v m SeqOp
seqOp
      where
        f :: SeqOp
-> (Pattern Ann, [a]) -> (Pattern Ann, [a]) -> (Pattern Ann, [a])
f SeqOp
op (Pattern Ann
l, [a]
lvs) (Pattern Ann
r, [a]
rvs) =
          (Ann -> Pattern Ann -> SeqOp -> Pattern Ann -> Pattern Ann
forall loc.
loc -> Pattern loc -> SeqOp -> Pattern loc -> Pattern loc
Pattern.SequenceOp (Pattern Ann -> Ann
forall a. Annotated a => a -> Ann
ann Pattern Ann
l Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
<> Pattern Ann -> Ann
forall a. Annotated a => a -> Ann
ann Pattern Ann
r) Pattern Ann
l SeqOp
op Pattern Ann
r, [a]
lvs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
rvs)

    -- note: nullaryCtor comes before var patterns, since (for better or worse)
    -- they can overlap (a variable could be called 'Foo' in the current grammar).
    -- This order treats ambiguous patterns as nullary constructors if there's
    -- a constructor with a matching name.
    leaf :: P v m (Pattern Ann, [(Ann, v)])
leaf =
      P v m (Pattern Ann, [(Ann, v)])
literal
        P v m (Pattern Ann, [(Ann, v)])
-> P v m (Pattern Ann, [(Ann, v)])
-> P v m (Pattern Ann, [(Ann, 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 (Pattern Ann, [(Ann, v)])
nullaryCtor
        P v m (Pattern Ann, [(Ann, v)])
-> P v m (Pattern Ann, [(Ann, v)])
-> P v m (Pattern Ann, [(Ann, 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 (Pattern Ann, [(Ann, v)])
varOrAs
        P v m (Pattern Ann, [(Ann, v)])
-> P v m (Pattern Ann, [(Ann, v)])
-> P v m (Pattern Ann, [(Ann, 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 (Pattern Ann, [(Ann, v)])
unbound
        P v m (Pattern Ann, [(Ann, v)])
-> P v m (Pattern Ann, [(Ann, v)])
-> P v m (Pattern Ann, [(Ann, 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 (Pattern Ann, [(Ann, v)])
seqLiteral
        P v m (Pattern Ann, [(Ann, v)])
-> P v m (Pattern Ann, [(Ann, v)])
-> P v m (Pattern Ann, [(Ann, 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 (Pattern Ann, [(Ann, v)])
parenthesizedOrTuplePattern
        P v m (Pattern Ann, [(Ann, v)])
-> P v m (Pattern Ann, [(Ann, v)])
-> P v m (Pattern Ann, [(Ann, 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 (Pattern Ann, [(Ann, v)])
effect
    literal :: P v m (Pattern Ann, [(Ann, v)])
literal = (,[]) (Pattern Ann -> (Pattern Ann, [(Ann, v)]))
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann)
-> P v m (Pattern Ann, [(Ann, v)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann)]
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann)
forall {m :: * -> *}.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann)
true, ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann)
forall {m :: * -> *}.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann)
false, ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann)
forall {m :: * -> *}.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann)
number, ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann)
forall {m :: * -> *}.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann)
text, ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann)
forall {m :: * -> *}.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann)
char]
    true :: ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann)
true = (\Token String
t -> Ann -> Bool -> Pattern Ann
forall loc. loc -> Bool -> Pattern loc
Pattern.Boolean (Token String -> Ann
forall a. Annotated a => a -> Ann
ann Token String
t) Bool
True) (Token String -> Pattern Ann)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token String)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token String)
forall v (m :: * -> *). Ord v => String -> P v m (Token String)
reserved String
"true"
    false :: ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann)
false = (\Token String
t -> Ann -> Bool -> Pattern Ann
forall loc. loc -> Bool -> Pattern loc
Pattern.Boolean (Token String -> Ann
forall a. Annotated a => a -> Ann
ann Token String
t) Bool
False) (Token String -> Pattern Ann)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token String)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token String)
forall v (m :: * -> *). Ord v => String -> P v m (Token String)
reserved String
"false"
    number :: ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann)
number =
      ParsecT
  (Error v)
  Input
  (ReaderT (ParsingEnv m) m)
  (ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann))
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (ParsecT
   (Error v)
   Input
   (ReaderT (ParsingEnv m) m)
   (ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann))
 -> ParsecT
      (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann))
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann))
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann)
forall a b. (a -> b) -> a -> b
$
        (Token Int64
 -> ParsecT
      (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann))
-> (Token ConstructorId
    -> ParsecT
         (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann))
-> (Token Double
    -> ParsecT
         (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann))
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann))
forall v a (m :: * -> *).
Ord v =>
(Token Int64 -> a)
-> (Token ConstructorId -> a) -> (Token Double -> a) -> P v m a
number'
          (Pattern Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann)
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pattern Ann
 -> ParsecT
      (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann))
-> (Token Int64 -> Pattern Ann)
-> Token Int64
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ann -> Int64 -> Pattern Ann) -> Token Int64 -> Pattern Ann
forall a b. (Ann -> a -> b) -> Token a -> b
tok Ann -> Int64 -> Pattern Ann
forall loc. loc -> Int64 -> Pattern loc
Pattern.Int)
          (Pattern Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann)
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pattern Ann
 -> ParsecT
      (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann))
-> (Token ConstructorId -> Pattern Ann)
-> Token ConstructorId
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ann -> ConstructorId -> Pattern Ann)
-> Token ConstructorId -> Pattern Ann
forall a b. (Ann -> a -> b) -> Token a -> b
tok Ann -> ConstructorId -> Pattern Ann
forall loc. loc -> ConstructorId -> Pattern loc
Pattern.Nat)
          ((Ann
 -> Double
 -> ParsecT
      (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann))
-> Token Double
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann)
forall a b. (Ann -> a -> b) -> Token a -> b
tok (ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann)
-> Double
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann)
forall a b. a -> b -> a
const (ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann)
 -> Double
 -> ParsecT
      (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann))
-> (Ann
    -> ParsecT
         (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann))
-> Ann
-> Double
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error v
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann)
forall v (m :: * -> *) x. Ord v => Error v -> P v m x
failCommitted (Error v
 -> ParsecT
      (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann))
-> (Ann -> Error v)
-> Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ann -> Error v
forall v. Ann -> Error v
FloatPattern))
    text :: ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann)
text = (\Token Text
t -> Ann -> Text -> Pattern Ann
forall loc. loc -> Text -> Pattern loc
Pattern.Text (Token Text -> Ann
forall a. Annotated a => a -> Ann
ann Token Text
t) (Token Text -> Text
forall a. Token a -> a
L.payload Token Text
t)) (Token Text -> Pattern Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token Text)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token Text)
forall v (m :: * -> *). Ord v => P v m (Token Text)
string
    char :: ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann)
char = (\Token Char
c -> Ann -> Char -> Pattern Ann
forall loc. loc -> Char -> Pattern loc
Pattern.Char (Token Char -> Ann
forall a. Annotated a => a -> Ann
ann Token Char
c) (Token Char -> Char
forall a. Token a -> a
L.payload Token Char
c)) (Token Char -> Pattern Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token Char)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token Char)
forall v (m :: * -> *). Ord v => P v m (Token Char)
character
    parenthesizedOrTuplePattern :: P v m (Pattern Ann, [(Ann, v)])
    parenthesizedOrTuplePattern :: P v m (Pattern Ann, [(Ann, v)])
parenthesizedOrTuplePattern = do
      (Ann
_spanAnn, (Pattern Ann
pat, [(Ann, v)]
pats)) <- P v m (Pattern Ann, [(Ann, v)])
-> (Ann -> (Pattern Ann, [(Ann, v)]))
-> ((Pattern Ann, [(Ann, v)])
    -> (Pattern Ann, [(Ann, v)]) -> (Pattern Ann, [(Ann, v)]))
-> P v m (Ann, (Pattern Ann, [(Ann, v)]))
forall v (m :: * -> *) a.
Ord v =>
P v m a -> (Ann -> a) -> (a -> a -> a) -> P v m (Ann, a)
tupleOrParenthesized P v m (Pattern Ann, [(Ann, v)])
forall (m :: * -> *) v.
(Monad m, Var v) =>
P v m (Pattern Ann, [(Ann, v)])
parsePattern Ann -> (Pattern Ann, [(Ann, v)])
forall {loc} {a}. loc -> (Pattern loc, [a])
unit (Pattern Ann, [(Ann, v)])
-> (Pattern Ann, [(Ann, v)]) -> (Pattern Ann, [(Ann, v)])
forall {a}.
(Pattern Ann, [a]) -> (Pattern Ann, [a]) -> (Pattern Ann, [a])
pair
      (Pattern Ann, [(Ann, v)]) -> P v m (Pattern Ann, [(Ann, v)])
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pattern Ann
pat, [(Ann, v)]
pats)
    unit :: loc -> (Pattern loc, [a])
unit loc
ann = (loc -> ConstructorReference -> [Pattern loc] -> Pattern loc
forall loc.
loc -> ConstructorReference -> [Pattern loc] -> Pattern loc
Pattern.Constructor loc
ann (TypeReference -> ConstructorId -> ConstructorReference
forall r. r -> ConstructorId -> GConstructorReference r
ConstructorReference TypeReference
DD.unitRef ConstructorId
0) [], [])
    pair :: (Pattern Ann, [a]) -> (Pattern Ann, [a]) -> (Pattern Ann, [a])
pair (Pattern Ann
p1, [a]
v1) (Pattern Ann
p2, [a]
v2) =
      ( Ann -> ConstructorReference -> [Pattern Ann] -> Pattern Ann
forall loc.
loc -> ConstructorReference -> [Pattern loc] -> Pattern loc
Pattern.Constructor (Pattern Ann -> Ann
forall a. Annotated a => a -> Ann
ann Pattern Ann
p1 Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
<> Pattern Ann -> Ann
forall a. Annotated a => a -> Ann
ann Pattern Ann
p2) (TypeReference -> ConstructorId -> ConstructorReference
forall r. r -> ConstructorId -> GConstructorReference r
ConstructorReference TypeReference
DD.pairRef ConstructorId
0) [Pattern Ann
p1, Pattern Ann
p2],
        [a]
v1 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
v2
      )
    -- Foo x@(Blah 10)
    varOrAs :: P v m (Pattern Ann, [(Ann, v)])
    varOrAs :: P v m (Pattern Ann, [(Ann, v)])
varOrAs = do
      Token v
v <- P v m (Token v)
forall v (m :: * -> *). Var v => P v m (Token v)
wordyPatternName
      Maybe (Token String)
o <- ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token String)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Maybe (Token String))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (String
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token String)
forall v (m :: * -> *). Ord v => String -> P v m (Token String)
reserved String
"@")
      if Maybe (Token String) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Token String)
o
        then (\(Pattern Ann
p, [(Ann, v)]
vs) -> (Ann -> Pattern Ann -> Pattern Ann
forall loc. loc -> Pattern loc -> Pattern loc
Pattern.As (Token v -> Ann
forall a. Annotated a => a -> Ann
ann Token v
v) Pattern Ann
p, Token v -> (Ann, v)
forall a. Token a -> (Ann, a)
tokenToPair Token v
v (Ann, v) -> [(Ann, v)] -> [(Ann, v)]
forall a. a -> [a] -> [a]
: [(Ann, v)]
vs)) ((Pattern Ann, [(Ann, v)]) -> (Pattern Ann, [(Ann, v)]))
-> P v m (Pattern Ann, [(Ann, v)])
-> P v m (Pattern Ann, [(Ann, v)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P v m (Pattern Ann, [(Ann, v)])
leaf
        else (Pattern Ann, [(Ann, v)]) -> P v m (Pattern Ann, [(Ann, v)])
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ann -> Pattern Ann
forall {loc}. loc -> Pattern loc
Pattern.Var (Token v -> Ann
forall a. Annotated a => a -> Ann
ann Token v
v), [Token v -> (Ann, v)
forall a. Token a -> (Ann, a)
tokenToPair Token v
v])
    unbound :: P v m (Pattern Ann, [(Ann, v)])
    unbound :: P v m (Pattern Ann, [(Ann, v)])
unbound = (\Token NameSegment
tok -> (Ann -> Pattern Ann
forall {loc}. loc -> Pattern loc
Pattern.Unbound (Token NameSegment -> Ann
forall a. Annotated a => a -> Ann
ann Token NameSegment
tok), [])) (Token NameSegment -> (Pattern Ann, [(Ann, v)]))
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token NameSegment)
-> P v m (Pattern Ann, [(Ann, v)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT
  (Error v) Input (ReaderT (ParsingEnv m) m) (Token NameSegment)
forall v (m :: * -> *). Ord v => P v m (Token NameSegment)
blank
    ctor :: CT.ConstructorType -> P v m (L.Token ConstructorReference)
    ctor :: ConstructorType -> P v m (Token ConstructorReference)
ctor ConstructorType
ct = do
      -- this might be a var, so we avoid consuming it at first
      Token (HashQualified Name)
tok <- ParsecT
  (Error v)
  Input
  (ReaderT (ParsingEnv m) m)
  (Token (HashQualified Name))
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (Token (HashQualified Name))
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 (HashQualified Name))
forall v (m :: * -> *). Ord v => P v m (Token (HashQualified Name))
hqPrefixId

      -- First, if:
      --
      --   * The token isn't hash-qualified (e.g. "Foo.Bar")
      --   * We're under a namespace directive (e.g. "baz")
      --   * There's an exact match for a locally-bound constructor (e.g. "baz.Foo.Bar")
      --
      -- Then:
      --
      --   * Use that constructor reference (duh)
      --
      -- Else:
      --
      --   * Fall through to the normal logic of looking the constructor name up in all of the names (which includes
      --     the locally-bound constructors).

      Maybe ConstructorReference
maybeLocalCtor <-
        case Token (HashQualified Name) -> HashQualified Name
forall a. Token a -> a
L.payload Token (HashQualified Name)
tok of
          HQ.NameOnly Name
name ->
            (ParsingEnv m -> Maybe Name)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Maybe Name)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ParsingEnv m -> Maybe Name
forall (m :: * -> *). ParsingEnv m -> Maybe Name
maybeNamespace ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Maybe Name)
-> (Maybe Name
    -> ParsecT
         (Error v)
         Input
         (ReaderT (ParsingEnv m) m)
         (Maybe ConstructorReference))
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (Maybe ConstructorReference)
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 Name
Nothing -> Maybe ConstructorReference
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (Maybe ConstructorReference)
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ConstructorReference
forall a. Maybe a
Nothing
              Just Name
namespace -> do
                Names
localNames <- (ParsingEnv m -> Names)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) Names
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ParsingEnv m -> Names
forall (m :: * -> *). ParsingEnv m -> Names
localNamespacePrefixedTypesAndConstructors
                case SearchType
-> HashQualified Name
-> ConstructorType
-> Names
-> Set ConstructorReference
Names.lookupHQPattern SearchType
Names.ExactName (Name -> HashQualified Name
forall n. n -> HashQualified n
HQ.NameOnly (HasCallStack => Name -> Name -> Name
Name -> Name -> Name
Name.joinDot Name
namespace Name
name)) ConstructorType
ct Names
localNames of
                  Set ConstructorReference
refs
                    | Set ConstructorReference -> Bool
forall a. Set a -> Bool
Set.null Set ConstructorReference
refs -> Maybe ConstructorReference
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (Maybe ConstructorReference)
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ConstructorReference
forall a. Maybe a
Nothing
                    -- 2+ name case is impossible: we looked up exact names in the locally-bound names. Two bindings
                    -- with the same name would have been a parse error. So, just take the minimum element from the set,
                    -- which we know is a singleton.
                    | Bool
otherwise -> do
                        -- matched ctor name, consume the token
                        Token Lexeme
_ <- P v m (Token Lexeme)
forall v (m :: * -> *). Ord v => P v m (Token Lexeme)
anyToken
                        pure (ConstructorReference -> Maybe ConstructorReference
forall a. a -> Maybe a
Just (Set ConstructorReference -> ConstructorReference
forall a. Set a -> a
Set.findMin Set ConstructorReference
refs))
          HashQualified Name
_ -> Maybe ConstructorReference
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (Maybe ConstructorReference)
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ConstructorReference
forall a. Maybe a
Nothing

      case Maybe ConstructorReference
maybeLocalCtor of
        Just ConstructorReference
localCtor -> Token ConstructorReference -> P v m (Token ConstructorReference)
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConstructorReference
localCtor ConstructorReference
-> Token (HashQualified Name) -> Token ConstructorReference
forall a b. a -> Token b -> Token a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Token (HashQualified Name)
tok)
        Maybe ConstructorReference
Nothing -> do
          Names
names <- (ParsingEnv m -> Names)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) Names
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ParsingEnv m -> Names
forall (m :: * -> *). ParsingEnv m -> Names
names
          case SearchType
-> HashQualified Name
-> ConstructorType
-> Names
-> Set ConstructorReference
Names.lookupHQPattern SearchType
Names.IncludeSuffixes (Token (HashQualified Name) -> HashQualified Name
forall a. Token a -> a
L.payload Token (HashQualified Name)
tok) ConstructorType
ct Names
names of
            Set ConstructorReference
s
              | Set ConstructorReference -> Int
forall a. Set a -> Int
Set.size Set ConstructorReference
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> do
                  -- matched ctor name, consume the token
                  Token Lexeme
_ <- P v m (Token Lexeme)
forall v (m :: * -> *). Ord v => P v m (Token Lexeme)
anyToken
                  pure (Set ConstructorReference -> ConstructorReference
forall a. Set a -> a
Set.findMin Set ConstructorReference
s ConstructorReference
-> Token (HashQualified Name) -> Token ConstructorReference
forall a b. a -> Token b -> Token a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Token (HashQualified Name)
tok)
              | Bool
otherwise -> Names
-> Token (HashQualified Name)
-> Set ConstructorReference
-> P v m (Token ConstructorReference)
forall a.
Names
-> Token (HashQualified Name)
-> Set ConstructorReference
-> P v m a
die Names
names Token (HashQualified Name)
tok Set ConstructorReference
s
      where
        isLower :: Name -> Bool
isLower = (Char -> Bool) -> Text -> Bool
Text.all Char -> Bool
Char.isLower (Text -> Bool) -> (Name -> Text) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
Text.take Int
1 (Text -> Text) -> (Name -> Text) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameSegment -> Text
NameSegment.toUnescapedText (NameSegment -> Text) -> (Name -> NameSegment) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> NameSegment
Name.lastSegment
        isIgnored :: Name -> Bool
isIgnored Name
n = Int -> Text -> Text
Text.take Int
1 (Name -> Text
Name.toText Name
n) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"_"
        die :: Names -> L.Token (HQ.HashQualified Name) -> Set ConstructorReference -> P v m a
        die :: forall a.
Names
-> Token (HashQualified Name)
-> Set ConstructorReference
-> P v m a
die Names
names Token (HashQualified Name)
hq Set ConstructorReference
s = case Token (HashQualified Name) -> HashQualified Name
forall a. Token a -> a
L.payload Token (HashQualified Name)
hq of
          -- if token not hash qualified and not uppercase,
          -- fail w/out consuming it to allow backtracking
          HQ.NameOnly Name
n
            | Set ConstructorReference -> Bool
forall a. Set a -> Bool
Set.null Set ConstructorReference
s
                Bool -> Bool -> Bool
&& (Name -> Bool
isLower Name
n Bool -> Bool -> Bool
|| Name -> Bool
isIgnored Name
n) ->
                String -> P v m a
forall a.
String -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> P v m a) -> String -> P v m a
forall a b. (a -> b) -> a -> b
$ String
"not a constructor name: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Show a => a -> String
show Name
n
          -- it was hash qualified and/or uppercase, and was either not found or ambiguous, that's a failure!
          HashQualified Name
_ ->
            Error v -> P v m a
forall v (m :: * -> *) x. Ord v => Error v -> P v m x
failCommitted (Error v -> P v m a) -> Error v -> P v m a
forall a b. (a -> b) -> a -> b
$
              [ResolutionFailure Ann] -> Error v
forall v. [ResolutionFailure Ann] -> Error v
ResolutionFailures
                [ HashQualified Name
-> Ann -> ResolutionError Referent -> ResolutionFailure Ann
forall annotation.
HashQualified Name
-> annotation
-> ResolutionError Referent
-> ResolutionFailure annotation
TermResolutionFailure
                    (Token (HashQualified Name) -> HashQualified Name
forall a. Token a -> a
L.payload Token (HashQualified Name)
hq)
                    (Token (HashQualified Name) -> Ann
forall a. Annotated a => a -> Ann
ann Token (HashQualified Name)
hq)
                    if Set ConstructorReference -> Bool
forall a. Set a -> Bool
Set.null Set ConstructorReference
s
                      then ResolutionError Referent
forall ref. ResolutionError ref
NotFound
                      else
                        Names -> Set Referent -> Set Name -> ResolutionError Referent
forall ref. Names -> Set ref -> Set Name -> ResolutionError ref
Ambiguous
                          Names
names
                          ((ConstructorReference -> Referent)
-> Set ConstructorReference -> Set Referent
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (\ConstructorReference
ref -> ConstructorReference -> ConstructorType -> Referent
Referent.Con ConstructorReference
ref ConstructorType
ct) Set ConstructorReference
s)
                          -- Eh, here we're saying there are no "local" constructors – they're all from "the namespace".
                          -- That's not necessarily true, but it doesn't (currently) affect the error message any, and
                          -- we have already parsed and hashed local constructors (so they aren't really different from
                          -- namespace constructors).
                          Set Name
forall a. Set a
Set.empty
                ]
    unzipPatterns :: ([a] -> [a] -> t) -> [(a, [a])] -> t
unzipPatterns [a] -> [a] -> t
f [(a, [a])]
elems = case [(a, [a])] -> ([a], [[a]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(a, [a])]
elems of ([a]
patterns, [[a]]
vs) -> [a] -> [a] -> t
f [a]
patterns ([[a]] -> [a]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join [[a]]
vs)

    effectBind :: P v m (Pattern Ann, [(Ann, v)])
effectBind = do
      Token ConstructorReference
tok <- ConstructorType -> P v m (Token ConstructorReference)
ctor ConstructorType
CT.Effect
      [(Pattern Ann, [(Ann, v)])]
leaves <- P v m (Pattern Ann, [(Ann, v)])
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     [(Pattern Ann, [(Ann, v)])]
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 P v m (Pattern Ann, [(Ann, v)])
leaf
      Token String
_ <- String
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token String)
forall v (m :: * -> *). Ord v => String -> P v m (Token String)
reserved String
"->"
      (Pattern Ann
cont, [(Ann, v)]
vsp) <- P v m (Pattern Ann, [(Ann, v)])
forall (m :: * -> *) v.
(Monad m, Var v) =>
P v m (Pattern Ann, [(Ann, v)])
parsePattern
      pure $
        let f :: [Pattern Ann] -> [(Ann, v)] -> (Pattern Ann, [(Ann, v)])
f [Pattern Ann]
patterns [(Ann, v)]
vs = (Ann
-> ConstructorReference
-> [Pattern Ann]
-> Pattern Ann
-> Pattern Ann
forall loc.
loc
-> ConstructorReference
-> [Pattern loc]
-> Pattern loc
-> Pattern loc
Pattern.EffectBind (Token ConstructorReference -> Ann
forall a. Annotated a => a -> Ann
ann Token ConstructorReference
tok Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
<> Pattern Ann -> Ann
forall a. Annotated a => a -> Ann
ann Pattern Ann
cont) (Token ConstructorReference -> ConstructorReference
forall a. Token a -> a
L.payload Token ConstructorReference
tok) [Pattern Ann]
patterns Pattern Ann
cont, [(Ann, v)]
vs [(Ann, v)] -> [(Ann, v)] -> [(Ann, v)]
forall a. [a] -> [a] -> [a]
++ [(Ann, v)]
vsp)
         in ([Pattern Ann] -> [(Ann, v)] -> (Pattern Ann, [(Ann, v)]))
-> [(Pattern Ann, [(Ann, v)])] -> (Pattern Ann, [(Ann, v)])
forall {a} {a} {t}. ([a] -> [a] -> t) -> [(a, [a])] -> t
unzipPatterns [Pattern Ann] -> [(Ann, v)] -> (Pattern Ann, [(Ann, v)])
f [(Pattern Ann, [(Ann, v)])]
leaves

    effectPure :: P v m (Pattern Ann, [(Ann, v)])
effectPure = (Pattern Ann, [(Ann, v)]) -> (Pattern Ann, [(Ann, v)])
forall {b}. (Pattern Ann, b) -> (Pattern Ann, b)
go ((Pattern Ann, [(Ann, v)]) -> (Pattern Ann, [(Ann, v)]))
-> P v m (Pattern Ann, [(Ann, v)])
-> P v m (Pattern Ann, [(Ann, v)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P v m (Pattern Ann, [(Ann, v)])
forall (m :: * -> *) v.
(Monad m, Var v) =>
P v m (Pattern Ann, [(Ann, v)])
parsePattern
      where
        go :: (Pattern Ann, b) -> (Pattern Ann, b)
go (Pattern Ann
p, b
vs) = (Ann -> Pattern Ann -> Pattern Ann
forall loc. loc -> Pattern loc -> Pattern loc
Pattern.EffectPure (Pattern Ann -> Ann
forall a. Annotated a => a -> Ann
ann Pattern Ann
p) Pattern Ann
p, b
vs)

    effect :: P v m (Pattern Ann, [(Ann, v)])
effect = do
      Token ()
start <- String -> P v m (Token ())
forall v (m :: * -> *). Ord v => String -> P v m (Token ())
openBlockWith String
"{"

      -- After the opening curly brace, we are expecting either an EffectBind or an EffectPure:
      --
      --   EffectBind            EffectPure
      --
      --   { foo bar -> baz }    { qux }
      --     ^^^^^^^^^^^^^^        ^^^
      --
      -- We accomplish that as follows:
      --
      --   * First try EffectPure + "}"
      --     * If that fails, back the parser up and try EffectBind + "}" instaed
      --
      -- This won't always result in the best possible error messages, but it's not exactly trivial to do better,
      -- requiring more sophisticated look-ahead logic. So, this is how it works for now.
      (Pattern Ann
inner, [(Ann, v)]
vs, Token ()
end) <-
        [ParsecT
   (Error v)
   Input
   (ReaderT (ParsingEnv m) m)
   (Pattern Ann, [(Ann, v)], Token ())]
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (Pattern Ann, [(Ann, v)], Token ())
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
          [ ParsecT
  (Error v)
  Input
  (ReaderT (ParsingEnv m) m)
  (Pattern Ann, [(Ann, v)], Token ())
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (Pattern Ann, [(Ann, v)], Token ())
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
              (Pattern Ann
inner, [(Ann, v)]
vs) <- P v m (Pattern Ann, [(Ann, v)])
effectPure
              Token ()
end <- P v m (Token ())
forall v (m :: * -> *). Ord v => P v m (Token ())
closeBlock
              pure (Pattern Ann
inner, [(Ann, v)]
vs, Token ()
end),
            do
              (Pattern Ann
inner, [(Ann, v)]
vs) <- P v m (Pattern Ann, [(Ann, v)])
effectBind
              Token ()
end <- P v m (Token ())
forall v (m :: * -> *). Ord v => P v m (Token ())
closeBlock
              pure (Pattern Ann
inner, [(Ann, v)]
vs, Token ()
end)
          ]

      pure (Pattern Ann -> Ann -> Pattern Ann
forall loc. Pattern loc -> loc -> Pattern loc
Pattern.setLoc Pattern Ann
inner (Token () -> Ann
forall a. Annotated a => a -> Ann
ann Token ()
start Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
<> Token () -> Ann
forall a. Annotated a => a -> Ann
ann Token ()
end), [(Ann, v)]
vs)

    -- ex: unique type Day = Mon | Tue | ...
    nullaryCtor :: P v m (Pattern Ann, [(Ann, v)])
nullaryCtor = do
      Token ConstructorReference
tok <- ConstructorType -> P v m (Token ConstructorReference)
ctor ConstructorType
CT.Data
      pure (Ann -> ConstructorReference -> [Pattern Ann] -> Pattern Ann
forall loc.
loc -> ConstructorReference -> [Pattern loc] -> Pattern loc
Pattern.Constructor (Token ConstructorReference -> Ann
forall a. Annotated a => a -> Ann
ann Token ConstructorReference
tok) (Token ConstructorReference -> ConstructorReference
forall a. Token a -> a
L.payload Token ConstructorReference
tok) [], [])

    constructor :: P v m (Pattern Ann, [(Ann, v)])
constructor = do
      Token ConstructorReference
tok <- ConstructorType -> P v m (Token ConstructorReference)
ctor ConstructorType
CT.Data
      let f :: [Pattern Ann] -> [(Ann, v)] -> (Pattern Ann, [(Ann, v)])
f [Pattern Ann]
patterns [(Ann, v)]
vs =
            let loc :: Ann
loc = (Ann -> Ann -> Ann) -> Ann -> [Ann] -> Ann
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
(<>) (Token ConstructorReference -> Ann
forall a. Annotated a => a -> Ann
ann Token ConstructorReference
tok) ([Ann] -> Ann) -> [Ann] -> Ann
forall a b. (a -> b) -> a -> b
$ (Pattern Ann -> Ann) -> [Pattern Ann] -> [Ann]
forall a b. (a -> b) -> [a] -> [b]
map Pattern Ann -> Ann
forall a. Annotated a => a -> Ann
ann [Pattern Ann]
patterns
             in (Ann -> ConstructorReference -> [Pattern Ann] -> Pattern Ann
forall loc.
loc -> ConstructorReference -> [Pattern loc] -> Pattern loc
Pattern.Constructor Ann
loc (Token ConstructorReference -> ConstructorReference
forall a. Token a -> a
L.payload Token ConstructorReference
tok) [Pattern Ann]
patterns, [(Ann, v)]
vs)
      ([Pattern Ann] -> [(Ann, v)] -> (Pattern Ann, [(Ann, v)]))
-> [(Pattern Ann, [(Ann, v)])] -> (Pattern Ann, [(Ann, v)])
forall {a} {a} {t}. ([a] -> [a] -> t) -> [(a, [a])] -> t
unzipPatterns [Pattern Ann] -> [(Ann, v)] -> (Pattern Ann, [(Ann, v)])
f ([(Pattern Ann, [(Ann, v)])] -> (Pattern Ann, [(Ann, v)]))
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     [(Pattern Ann, [(Ann, v)])]
-> P v m (Pattern Ann, [(Ann, v)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P v m (Pattern Ann, [(Ann, v)])
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     [(Pattern Ann, [(Ann, v)])]
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 P v m (Pattern Ann, [(Ann, v)])
leaf

    seqLiteral :: P v m (Pattern Ann, [(Ann, v)])
seqLiteral = (Ann -> [(Pattern Ann, [(Ann, v)])] -> (Pattern Ann, [(Ann, v)]))
-> P v m (Pattern Ann, [(Ann, v)])
-> P v m (Pattern Ann, [(Ann, v)])
forall v a (m :: * -> *).
Ord v =>
(Ann -> [a] -> a) -> P v m a -> P v m a
Parser.seq Ann -> [(Pattern Ann, [(Ann, v)])] -> (Pattern Ann, [(Ann, v)])
forall {loc} {a}. loc -> [(Pattern loc, [a])] -> (Pattern loc, [a])
f P v m (Pattern Ann, [(Ann, v)])
root
      where
        f :: loc -> [(Pattern loc, [a])] -> (Pattern loc, [a])
f loc
loc = ([Pattern loc] -> [a] -> (Pattern loc, [a]))
-> [(Pattern loc, [a])] -> (Pattern loc, [a])
forall {a} {a} {t}. ([a] -> [a] -> t) -> [(a, [a])] -> t
unzipPatterns ((,) (Pattern loc -> [a] -> (Pattern loc, [a]))
-> ([Pattern loc] -> Pattern loc)
-> [Pattern loc]
-> [a]
-> (Pattern loc, [a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. loc -> [Pattern loc] -> Pattern loc
forall loc. loc -> [Pattern loc] -> Pattern loc
Pattern.SequenceLiteral loc
loc)

lam :: (Var v) => TermP v m -> TermP v m
lam :: forall v (m :: * -> *). Var v => TermP v m -> TermP v m
lam TermP v m
p = String -> TermP v m -> TermP v m
forall v a (m :: * -> *).
(Ord v, Show a) =>
String -> P v m a -> P v m a
label String
"lambda" (TermP v m -> TermP v m) -> TermP v m -> TermP v m
forall a b. (a -> b) -> a -> b
$ [Token v] -> Term v Ann -> Term v Ann
forall {v} {vt} {at} {ap}.
Ord v =>
[Token v] -> Term (F vt at ap) v Ann -> Term (F vt at ap) v Ann
mkLam ([Token v] -> Term v Ann -> Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) [Token v]
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (Term v Ann -> Term v Ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) [Token v]
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) [Token v]
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) (Token v)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) [Token v]
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]
some ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token v)
forall v (m :: * -> *). Var v => P v m (Token v)
prefixDefinitionName ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) [Token v]
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token String)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) [Token v]
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
<* 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)
  (Term v Ann -> Term v Ann)
-> TermP v m -> TermP v m
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
<*> TermP v m
p
  where
    mkLam :: [Token v] -> Term (F vt at ap) v Ann -> Term (F vt at ap) v Ann
mkLam [Token v]
vs Term (F vt at ap) v Ann
b =
      let annotatedArgs :: [(Ann, v)]
annotatedArgs = [Token v]
vs [Token v] -> (Token v -> (Ann, v)) -> [(Ann, v)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Token v
v -> (Token v -> Ann
forall a. Annotated a => a -> Ann
ann Token v
v, Token v -> v
forall a. Token a -> a
L.payload Token v
v)
       in Ann
-> [(Ann, v)] -> Term (F vt at ap) v Ann -> Term (F vt at ap) v Ann
forall v a vt at ap.
Ord v =>
a -> [(a, v)] -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.lam' (Token v -> Ann
forall a. Annotated a => a -> Ann
ann ([Token v] -> Token v
forall a. HasCallStack => [a] -> a
head [Token v]
vs) Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
<> Term (F vt at ap) v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term (F vt at ap) v Ann
b) [(Ann, v)]
annotatedArgs Term (F vt at ap) v Ann
b

letBlock, handle, ifthen :: (Monad m, Var v) => TermP v m
letBlock :: forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
letBlock = String -> P v m (Term v Ann) -> P v m (Term v Ann)
forall v a (m :: * -> *).
(Ord v, Show a) =>
String -> P v m a -> P v m a
label String
"let" (P v m (Term v Ann) -> P v m (Term v Ann))
-> P v m (Term v Ann) -> P v m (Term v Ann)
forall a b. (a -> b) -> a -> b
$ ((Ann, Term v Ann) -> Term v Ann
forall a b. (a, b) -> b
snd ((Ann, Term v Ann) -> Term v Ann)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Ann, Term v Ann)
-> P v m (Term v Ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Ann, Term v Ann)
forall (m :: * -> *) v.
(Monad m, Var v) =>
String -> P v m (Ann, Term v Ann)
layoutBlock String
"let")
handle :: forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
handle = String -> P v m (Term v Ann) -> P v m (Term v Ann)
forall v a (m :: * -> *).
(Ord v, Show a) =>
String -> P v m a -> P v m a
label String
"handle" do
  (Ann
handleSpan, Term v Ann
b) <- String -> P v m (Ann, Term v Ann)
forall (m :: * -> *) v.
(Monad m, Var v) =>
String -> P v m (Ann, Term v Ann)
block String
"handle"
  (Ann
_withSpan, Term v Ann
handler) <- String -> P v m (Ann, Term v Ann)
forall (m :: * -> *) v.
(Monad m, Var v) =>
String -> P v m (Ann, Term v Ann)
layoutBlock String
"with"
  -- We don't use the annotation span from 'with' here because it will
  -- include a dedent if it's at the end of block.
  -- Meaning the newline gets overwritten when pretty-printing and it messes things up.
  Term v Ann -> P v m (Term v Ann)
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term v Ann -> P v m (Term v Ann))
-> Term v Ann -> P v m (Term v Ann)
forall a b. (a -> b) -> a -> b
$ Ann -> Term v Ann -> Term v Ann -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.handle (Ann
handleSpan Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
<> Term v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term v Ann
handler) Term v Ann
handler Term v Ann
b

checkCasesArities :: (Ord v, Annotated a) => [(Int, a)] -> P v m (Int, [a])
checkCasesArities :: forall v a (m :: * -> *).
(Ord v, Annotated a) =>
[(Int, a)] -> P v m (Int, [a])
checkCasesArities = \case
  [] -> (Int, [a]) -> P v m (Int, [a])
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
1, [])
  cases :: [(Int, a)]
cases@((Int
i, a
_) : [(Int, a)]
rest) -> case ((Int, a) -> Bool) -> [(Int, a)] -> Maybe (Int, a)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (\(Int
j, a
_) -> Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
i) [(Int, a)]
rest of
    Maybe (Int, a)
Nothing -> (Int, [a]) -> P v m (Int, [a])
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
i, (Int, a) -> a
forall a b. (a, b) -> b
snd ((Int, a) -> a) -> [(Int, a)] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, a)]
cases)
    Just (Int
j, a
a) -> Error v -> P v m (Int, [a])
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
P.customFailure (Error v -> P v m (Int, [a])) -> Error v -> P v m (Int, [a])
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Ann -> Error v
forall v. Int -> Int -> Ann -> Error v
PatternArityMismatch Int
i Int
j (a -> Ann
forall a. Annotated a => a -> Ann
ann a
a)

lamCase :: (Monad m, Var v) => TermP v m
lamCase :: forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
lamCase = do
  Token ()
start <- String -> P v m (Token ())
forall v (m :: * -> *). Ord v => String -> P v m (Token ())
openBlockWith String
"cases"
  [(Int, MatchCase Ann (Term v Ann))]
cases <- P v m [(Int, MatchCase Ann (Term v Ann))]
forall (m :: * -> *) v.
(Monad m, Var v) =>
P v m [(Int, MatchCase Ann (Term v Ann))]
matchCases
  (Int
arity, [MatchCase Ann (Term v Ann)]
cases) <- [(Int, MatchCase Ann (Term v Ann))]
-> P v m (Int, [MatchCase Ann (Term v Ann)])
forall v a (m :: * -> *).
(Ord v, Annotated a) =>
[(Int, a)] -> P v m (Int, [a])
checkCasesArities [(Int, MatchCase Ann (Term v Ann))]
cases
  Token ()
_ <- P v m (Token ())
forall v (m :: * -> *). Ord v => P v m (Token ())
optionalCloseBlock
  [Text]
lamvars <- Int
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) Text
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) [Text]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
arity (Int -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) Text
forall (m :: * -> *) v. (Monad m, Var v) => Int -> P v m Text
Parser.uniqueName Int
10)
  let vars :: [v]
vars =
        Text -> v
forall v. Var v => Text -> v
Var.named (Text -> v) -> [Text] -> [v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text -> Int -> Text
forall {a}. (Eq a, Num a, Show a) => Text -> a -> Text
tweak Text
v Int
i | (Text
v, Int
i) <- [Text]
lamvars [Text] -> [Int] -> [(Text, Int)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [(Int
1 :: Int) ..]]
      tweak :: Text -> a -> Text
tweak Text
v a
0 = Text
v
      tweak Text
v a
i = Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (a -> String
forall a. Show a => a -> String
show a
i)
      lamvarTerms :: [Term v Ann]
lamvarTerms = Ann -> v -> Term v Ann
forall a v vt at ap. a -> v -> Term2 vt at ap v a
Term.var (Token () -> Ann
forall a. Annotated a => a -> Ann
ann Token ()
start) (v -> Term v Ann) -> [v] -> [Term v Ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [v]
vars
      lamvarTerm :: Term v Ann
lamvarTerm = case [Term v Ann]
lamvarTerms of
        [Term v Ann
e] -> Term v Ann
e
        [Term v Ann]
es -> [Term v Ann] -> Term v Ann
forall v a vt at ap.
(Var v, Monoid a) =>
[Term2 vt at ap v a] -> Term2 vt at ap v a
DD.tupleTerm [Term v Ann]
es
      anns :: Ann
anns = (MatchCase Ann (Term v Ann) -> Ann -> Ann)
-> Ann -> Maybe (MatchCase Ann (Term v Ann)) -> Ann
forall a b. (a -> b -> b) -> b -> Maybe a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
(<>) (Ann -> Ann -> Ann)
-> (MatchCase Ann (Term v Ann) -> Ann)
-> MatchCase Ann (Term v Ann)
-> Ann
-> Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MatchCase Ann (Term v Ann) -> Ann
forall a. Annotated a => a -> Ann
ann) (Token () -> Ann
forall a. Annotated a => a -> Ann
ann Token ()
start) (Maybe (MatchCase Ann (Term v Ann)) -> Ann)
-> Maybe (MatchCase Ann (Term v Ann)) -> Ann
forall a b. (a -> b) -> a -> b
$ [MatchCase Ann (Term v Ann)] -> Maybe (MatchCase Ann (Term v Ann))
forall a. [a] -> Maybe a
lastMay [MatchCase Ann (Term v Ann)]
cases
      matchTerm :: Term v Ann
matchTerm = Ann -> Term v Ann -> [MatchCase Ann (Term v Ann)] -> Term v Ann
forall v a vt at.
Ord v =>
a
-> Term2 vt at a v a
-> [MatchCase a (Term2 vt at a v a)]
-> Term2 vt at a v a
Term.match Ann
anns Term v Ann
lamvarTerm [MatchCase Ann (Term v Ann)]
cases
  let annotatedVars :: [(Ann, v)]
annotatedVars = (Ann -> Ann
Ann.GeneratedFrom (Ann -> Ann) -> Ann -> Ann
forall a b. (a -> b) -> a -> b
$ Token () -> Ann
forall a. Annotated a => a -> Ann
ann Token ()
start,) (v -> (Ann, v)) -> [v] -> [(Ann, v)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [v]
vars
  pure $ Ann -> [(Ann, v)] -> Term v Ann -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> [(a, v)] -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.lam' Ann
anns [(Ann, v)]
annotatedVars Term v Ann
matchTerm

ifthen :: forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
ifthen = String -> P v m (Term v Ann) -> P v m (Term v Ann)
forall v a (m :: * -> *).
(Ord v, Show a) =>
String -> P v m a -> P v m a
label String
"if" do
  Token Lexeme
start <- P v m (Token Lexeme)
forall v (m :: * -> *). Ord v => P v m (Token Lexeme)
peekAny
  (Ann
_spanAnn, Term v Ann
c) <- String -> P v m (Ann, Term v Ann)
forall (m :: * -> *) v.
(Monad m, Var v) =>
String -> P v m (Ann, Term v Ann)
block String
"if"
  (Ann
_spanAnn, Term v Ann
t) <- String -> P v m (Ann, Term v Ann)
forall (m :: * -> *) v.
(Monad m, Var v) =>
String -> P v m (Ann, Term v Ann)
block String
"then"
  (Ann
_spanAnn, Term v Ann
f) <- String -> P v m (Ann, Term v Ann)
forall (m :: * -> *) v.
(Monad m, Var v) =>
String -> P v m (Ann, Term v Ann)
layoutBlock String
"else"
  pure $ Ann -> Term v Ann -> Term v Ann -> Term v Ann -> Term v Ann
forall v a vt at ap.
Ord v =>
a
-> Term2 vt at ap v a
-> Term2 vt at ap v a
-> Term2 vt at ap v a
-> Term2 vt at ap v a
Term.iff (Token Lexeme -> Ann
forall a. Annotated a => a -> Ann
ann Token Lexeme
start Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
<> Term v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term v Ann
f) Term v Ann
c Term v Ann
t Term v Ann
f

text :: (Var v) => TermP v m
text :: forall v (m :: * -> *). Var v => TermP v m
text = (Ann -> Text -> Term v Ann) -> Token Text -> Term v Ann
forall a b. (Ann -> a -> b) -> Token a -> b
tok Ann -> Text -> Term v Ann
forall v a vt at ap. Ord v => a -> Text -> Term2 vt at ap v a
Term.text (Token Text -> Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token Text)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token Text)
forall v (m :: * -> *). Ord v => P v m (Token Text)
string

char :: (Var v) => TermP v m
char :: forall v (m :: * -> *). Var v => TermP v m
char = (Ann -> Char -> Term v Ann) -> Token Char -> Term v Ann
forall a b. (Ann -> a -> b) -> Token a -> b
tok Ann -> Char -> Term v Ann
forall v a vt at ap. Ord v => a -> Char -> Term2 vt at ap v a
Term.char (Token Char -> Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token Char)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token Char)
forall v (m :: * -> *). Ord v => P v m (Token Char)
character

boolean :: (Var v) => TermP v m
boolean :: forall v (m :: * -> *). Var v => TermP v m
boolean =
  ((\Token String
t -> Ann -> Bool -> Term v Ann
forall v a vt at ap. Ord v => a -> Bool -> Term2 vt at ap v a
Term.boolean (Token String -> Ann
forall a. Annotated a => a -> Ann
ann Token String
t) Bool
True) (Token String -> Term v Ann)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token String)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token String)
forall v (m :: * -> *). Ord v => String -> P v m (Token String)
reserved String
"true")
    ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
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
<|> ((\Token String
t -> Ann -> Bool -> Term v Ann
forall v a vt at ap. Ord v => a -> Bool -> Term2 vt at ap v a
Term.boolean (Token String -> Ann
forall a. Annotated a => a -> Ann
ann Token String
t) Bool
False) (Token String -> Term v Ann)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token String)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token String)
forall v (m :: * -> *). Ord v => String -> P v m (Token String)
reserved String
"false")

list :: (Var v) => TermP v m -> TermP v m
list :: forall v (m :: * -> *). Var v => TermP v m -> TermP v m
list = (Ann -> [Term v Ann] -> Term v Ann)
-> P v m (Term v Ann) -> P v m (Term v Ann)
forall v a (m :: * -> *).
Ord v =>
(Ann -> [a] -> a) -> P v m a -> P v m a
Parser.seq Ann -> [Term v Ann] -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
Term.list

hashQualifiedPrefixTerm :: (Monad m, Var v) => TermP v m
hashQualifiedPrefixTerm :: forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
hashQualifiedPrefixTerm = Token (HashQualified Name) -> TermP v m
forall (m :: * -> *) v.
(Monad m, Var v) =>
Token (HashQualified Name) -> TermP v m
resolveHashQualified (Token (HashQualified Name) -> TermP v m)
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (Token (HashQualified Name))
-> TermP v m
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ParsecT
  (Error v)
  Input
  (ReaderT (ParsingEnv m) m)
  (Token (HashQualified Name))
forall v (m :: * -> *). Ord v => P v m (Token (HashQualified Name))
hqPrefixId

quasikeyword :: (Ord v) => Text -> P v m (L.Token ())
quasikeyword :: forall v (m :: * -> *). Ord v => Text -> P v m (Token ())
quasikeyword Text
kw = (Lexeme -> Maybe ()) -> P v m (Token ())
forall v a (m :: * -> *).
Ord v =>
(Lexeme -> Maybe a) -> P v m (Token a)
queryToken \case
  L.WordyId (HQ'.NameOnly Name
n) | Name -> Text -> Bool
nameIsKeyword Name
n Text
kw -> () -> Maybe ()
forall a. a -> Maybe a
Just ()
  Lexeme
_ -> Maybe ()
forall a. Maybe a
Nothing

nameIsKeyword :: Name -> Text -> Bool
nameIsKeyword :: Name -> Text -> Bool
nameIsKeyword Name
name Text
keyword =
  case (Name -> Bool
Name.isRelative Name
name, Name -> NonEmpty NameSegment
Name.reverseSegments Name
name) of
    (Bool
True, NameSegment
segment NonEmpty.:| []) -> NameSegment -> Text
NameSegment.toEscapedText NameSegment
segment Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
keyword
    (Bool, NonEmpty NameSegment)
_ -> Bool
False

-- If the hash qualified is name only, it is treated as a var, if it
-- has a short hash, we resolve that short hash immediately and fail
-- committed if that short hash can't be found in the current environment
resolveHashQualified :: (Monad m, Var v) => L.Token (HQ.HashQualified Name) -> TermP v m
resolveHashQualified :: forall (m :: * -> *) v.
(Monad m, Var v) =>
Token (HashQualified Name) -> TermP v m
resolveHashQualified Token (HashQualified Name)
tok = do
  case Token (HashQualified Name) -> HashQualified Name
forall a. Token a -> a
L.payload Token (HashQualified Name)
tok of
    HQ.NameOnly Name
n -> Term v Ann -> TermP v m
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term v Ann -> TermP v m) -> Term v Ann -> TermP v m
forall a b. (a -> b) -> a -> b
$ Ann -> v -> Term v Ann
forall a v vt at ap. a -> v -> Term2 vt at ap v a
Term.var (Token (HashQualified Name) -> Ann
forall a. Annotated a => a -> Ann
ann Token (HashQualified Name)
tok) (Name -> v
forall v. Var v => Name -> v
Name.toVar Name
n)
    HashQualified Name
_ -> do
      Names
names <- (ParsingEnv m -> Names)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) Names
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ParsingEnv m -> Names
forall (m :: * -> *). ParsingEnv m -> Names
names
      case SearchType -> HashQualified Name -> Names -> Set Referent
Names.lookupHQTerm SearchType
Names.IncludeSuffixes (Token (HashQualified Name) -> HashQualified Name
forall a. Token a -> a
L.payload Token (HashQualified Name)
tok) Names
names of
        Set Referent
s
          | Set Referent -> Bool
forall a. Set a -> Bool
Set.null Set Referent
s -> Error v -> TermP v m
forall v (m :: * -> *) x. Ord v => Error v -> P v m x
failCommitted (Error v -> TermP v m) -> Error v -> TermP v m
forall a b. (a -> b) -> a -> b
$ Token (HashQualified Name) -> Set Referent -> Error v
forall v. Token (HashQualified Name) -> Set Referent -> Error v
UnknownTerm Token (HashQualified Name)
tok Set Referent
s
          | Set Referent -> Int
forall a. Set a -> Int
Set.size Set Referent
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 -> Error v -> TermP v m
forall v (m :: * -> *) x. Ord v => Error v -> P v m x
failCommitted (Error v -> TermP v m) -> Error v -> TermP v m
forall a b. (a -> b) -> a -> b
$ Token (HashQualified Name) -> Set Referent -> Error v
forall v. Token (HashQualified Name) -> Set Referent -> Error v
UnknownTerm Token (HashQualified Name)
tok Set Referent
s
          | Bool
otherwise -> Term v Ann -> TermP v m
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term v Ann -> TermP v m) -> Term v Ann -> TermP v m
forall a b. (a -> b) -> a -> b
$ Ann -> Referent -> Term v Ann
forall v a vt at ap. Ord v => a -> Referent -> Term2 vt at ap v a
Term.fromReferent (Token (HashQualified Name) -> Ann
forall a. Annotated a => a -> Ann
ann Token (HashQualified Name)
tok) (Set Referent -> Referent
forall a. Set a -> a
Set.findMin Set Referent
s)

termLeaf :: forall m v. (Monad m, Var v) => TermP v m
termLeaf :: forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
termLeaf =
  [ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)]
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
    [ ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
force,
      ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
hashQualifiedPrefixTerm,
      ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall v (m :: * -> *). Var v => TermP v m
text,
      ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall v (m :: * -> *). Var v => TermP v m
char,
      ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall v (m :: * -> *). Var v => TermP v m
number,
      ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall v (m :: * -> *). Var v => TermP v m
bytes,
      ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall v (m :: * -> *). Var v => TermP v m
boolean,
      ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
link,
      ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
tupleOrParenthesizedTerm,
      ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
keywordBlock,
      ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall v (m :: * -> *). Var v => TermP v m -> TermP v m
list ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
term,
      ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
delayQuote,
      ((Ann, Term v Ann) -> Term v Ann
forall a b. (a, b) -> b
snd ((Ann, Term v Ann) -> Term v Ann)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Ann, Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT
  (Error v) Input (ReaderT (ParsingEnv m) m) (Ann, Term v Ann)
forall (m :: * -> *) v. (Monad m, Var v) => P v m (Ann, Term v Ann)
delayBlock),
      ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
bang,
      ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
docBlock,
      ParsecT
  (Error v) Input (ReaderT (ParsingEnv m) m) (Ann, Term v Ann)
forall (m :: * -> *) v. (Monad m, Var v) => P v m (Ann, Term v Ann)
doc2Block ParsecT
  (Error v) Input (ReaderT (ParsingEnv m) m) (Ann, Term v Ann)
-> ((Ann, Term v Ann) -> Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Ann
spanAnn, Term v Ann
trm) -> Term v Ann
trm {ABT.annotation = ABT.annotation trm <> spanAnn}
    ]

-- | Gives a parser an explicit stream to parse, so that it consumes nothing from the original stream when it runs.
--
--   This is used inside the `Doc` -> `Term` conversion, where we have chunks of Unison code embedded that need to be
--   parsed. It’s a consequence of parsing Doc in the midst of the Unison lexer.
subParse :: (Ord v, Monad m) => P v m a -> [L.Token L.Lexeme] -> P v m a
subParse :: forall v (m :: * -> *) a.
(Ord v, Monad m) =>
P v m a -> [Token Lexeme] -> P v m a
subParse P v m a
p [Token Lexeme]
toks = do
  Input
orig <- ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) Input
forall e s (m :: * -> *). MonadParsec e s m => m s
P.getInput
  Input -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ()
forall e s (m :: * -> *). MonadParsec e s m => s -> m ()
P.setInput (Input -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ())
-> Input -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ()
forall a b. (a -> b) -> a -> b
$ [Token Lexeme] -> Input
Input [Token Lexeme]
toks
  a
result <- 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
  Input -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ()
forall e s (m :: * -> *). MonadParsec e s m => s -> m ()
P.setInput Input
orig
  pure a
result

-- | Syntax for documentation v2 blocks, which are surrounded by @{{@ @}}@.
-- The lexer does most of the heavy lifting so there's not a lot for
-- the parser to do. For instance, in
--
-- > {{
-- > Hi there!
-- >
-- > goodbye.
-- > }}
--
-- the lexer will produce:
--
-- > [ Doc
-- >   ( DocUntitledSection
-- >     (DocParagraph (DocWord "Hi" :| [DocWord "there!"]))
-- >     (DocParagraph (DocWord "goodbye" :| []))
-- >   )
-- > ]
--
-- The parser will parse this into the Unison expression:
--
-- > syntax.docUntitledSection [
-- >   syntax.docParagraph [syntax.docWord "Hi", syntax.docWord "there!"],
-- >   syntax.docParagraph [syntax.docWord "goodbye"]
-- > ]
--
-- Where @syntax.doc{Paragraph, UntitledSection,...}@ are all ordinary term
-- variables that will be looked up in the environment like anything else. This
-- means that the documentation syntax can have its meaning changed by
-- overriding what functions the names @syntax.doc*@ correspond to.
doc2Block :: forall m v. (Monad m, Var v) => P v m (Ann {- Annotation for the whole spanning block -}, Term v Ann)
doc2Block :: forall (m :: * -> *) v. (Monad m, Var v) => P v m (Ann, Term v Ann)
doc2Block = do
  L.Token UntitledSection
  (Tree (Token (ReferenceType, HashQualified Name)) [Token Lexeme])
docContents Pos
startDoc Pos
endDoc <- P v
  m
  (Token
     (UntitledSection
        (Tree (Token (ReferenceType, HashQualified Name)) [Token Lexeme])))
forall v (m :: * -> *).
Ord v =>
P v
  m
  (Token
     (UntitledSection
        (Tree (Token (ReferenceType, HashQualified Name)) [Token Lexeme])))
doc
  let docAnn :: Ann
docAnn = Pos -> Pos -> Ann
Ann Pos
startDoc Pos
endDoc
  (Ann
docAnn,) (Term v Ann -> (Ann, Term v Ann))
-> (UntitledSection (Term v Ann) -> Term v Ann)
-> UntitledSection (Term v Ann)
-> (Ann, Term v Ann)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ann -> UntitledSection (Term v Ann) -> Term v Ann
docUntitledSection (Ann -> Ann
forall a. Annotated a => a -> Ann
gann Ann
docAnn) (UntitledSection (Term v Ann) -> (Ann, Term v Ann))
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (UntitledSection (Term v Ann))
-> P v m (Ann, Term v Ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Tree (Token (ReferenceType, HashQualified Name)) [Token Lexeme]
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> UntitledSection
     (Tree (Token (ReferenceType, HashQualified Name)) [Token Lexeme])
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (UntitledSection (Term v Ann))
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) -> UntitledSection a -> f (UntitledSection b)
traverse Tree (Token (ReferenceType, HashQualified Name)) [Token Lexeme]
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
foldTop UntitledSection
  (Tree (Token (ReferenceType, HashQualified Name)) [Token Lexeme])
docContents
  where
    foldTop :: Tree (Token (ReferenceType, HashQualified Name)) [Token Lexeme]
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
foldTop = (CofreeF
   (Top
      [Token Lexeme]
      (Leaves
         (Token (ReferenceType, HashQualified Name)) [Token Lexeme]))
   Ann
   (Term v Ann)
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> Tree (Token (ReferenceType, HashQualified Name)) [Token Lexeme]
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall t (f :: * -> *) (m :: * -> *) a.
(Recursive t f, Traversable f, Monad m) =>
(f a -> m a) -> t -> m a
cataM \(Ann
a :< Top
  [Token Lexeme]
  (Leaves (Token (ReferenceType, HashQualified Name)) [Token Lexeme])
  (Term v Ann)
top) -> Ann
-> Top [Token Lexeme] (Term v Ann) (Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
docTop Ann
a (Top [Token Lexeme] (Term v Ann) (Term v Ann)
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (Top [Token Lexeme] (Term v Ann) (Term v Ann))
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Leaves (Token (ReferenceType, HashQualified Name)) [Token Lexeme]
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> (Term v Ann
    -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> Top
     [Token Lexeme]
     (Leaves (Token (ReferenceType, HashQualified Name)) [Token Lexeme])
     (Term v Ann)
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (Top [Token Lexeme] (Term v Ann) (Term v Ann))
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c)
-> (b -> f d)
-> Top [Token Lexeme] a b
-> f (Top [Token Lexeme] c d)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse ((CofreeF
   (Leaf (Token (ReferenceType, HashQualified Name)) [Token Lexeme])
   Ann
   (Term v Ann)
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> Leaves
     (Token (ReferenceType, HashQualified Name)) [Token Lexeme]
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall t (f :: * -> *) (m :: * -> *) a.
(Recursive t f, Traversable f, Monad m) =>
(f a -> m a) -> t -> m a
cataM \(Ann
a :< Leaf
  (Token (ReferenceType, HashQualified Name))
  [Token Lexeme]
  (Term v Ann)
leaf) -> Ann
-> Leaf
     (Token (ReferenceType, HashQualified Name))
     [Token Lexeme]
     (Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
docLeaf Ann
a Leaf
  (Token (ReferenceType, HashQualified Name))
  [Token Lexeme]
  (Term v Ann)
leaf) Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Top
  [Token Lexeme]
  (Leaves (Token (ReferenceType, HashQualified Name)) [Token Lexeme])
  (Term v Ann)
top

    gann :: (Annotated a) => a -> Ann
    gann :: forall a. Annotated a => a -> Ann
gann = Ann -> Ann
Ann.GeneratedFrom (Ann -> Ann) -> (a -> Ann) -> a -> Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Ann
forall a. Annotated a => a -> Ann
ann

    addDelay :: Term v Ann -> Term v Ann
    addDelay :: Term v Ann -> Term v Ann
addDelay Term v Ann
tm = Ann -> Term v Ann -> Term v Ann
forall v a vt at ap.
Var v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.delay (Term v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term v Ann
tm) Term v Ann
tm

    f :: (Annotated a) => a -> String -> Term v Ann
    f :: forall a. Annotated a => a -> String -> Term v Ann
f a
a = Ann -> v -> Term v Ann
forall a v vt at ap. a -> v -> Term2 vt at ap v a
Term.var (a -> Ann
forall a. Annotated a => a -> Ann
gann a
a) (v -> Term v Ann) -> (String -> v) -> String -> Term v Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> v
forall v. Var v => String -> v
Var.nameds (String -> v) -> (String -> String) -> String -> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"syntax.doc" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>)

    docUntitledSection :: Ann -> Doc.UntitledSection (Term v Ann) -> Term v Ann
    docUntitledSection :: Ann -> UntitledSection (Term v Ann) -> Term v Ann
docUntitledSection Ann
ann (Doc.UntitledSection [Term v Ann]
tops) =
      Ann -> Term v Ann -> Term v Ann -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app Ann
ann (Ann -> String -> Term v Ann
forall a. Annotated a => a -> String -> Term v Ann
f Ann
ann String
"UntitledSection") (Term v Ann -> Term v Ann) -> Term v Ann -> Term v Ann
forall a b. (a -> b) -> a -> b
$ Ann -> [Term v Ann] -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
Term.list ([Term v Ann] -> Ann
forall a. Annotated a => a -> Ann
gann [Term v Ann]
tops) [Term v Ann]
tops

    docTop :: Ann -> Doc.Top [L.Token L.Lexeme] (Term v Ann) (Term v Ann) -> TermP v m
    docTop :: Ann
-> Top [Token Lexeme] (Term v Ann) (Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
docTop Ann
d = \case
      Doc.Section Paragraph (Term v Ann)
title [Term v Ann]
body -> Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term v Ann
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a b. (a -> b) -> a -> b
$ Term v Ann -> [Term v Ann] -> Term v Ann
forall v a vt at ap.
(Ord v, Semigroup a) =>
Term2 vt at ap v a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
Term.apps' (Ann -> String -> Term v Ann
forall a. Annotated a => a -> String -> Term v Ann
f Ann
d String
"Section") [Ann -> Paragraph (Term v Ann) -> Term v Ann
docParagraph Ann
d Paragraph (Term v Ann)
title, Ann -> [Term v Ann] -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
Term.list ([Term v Ann] -> Ann
forall a. Annotated a => a -> Ann
gann [Term v Ann]
body) [Term v Ann]
body]
      Doc.Eval [Token Lexeme]
code ->
        Ann -> Term v Ann -> Term v Ann -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app (Ann -> Ann
forall a. Annotated a => a -> Ann
gann Ann
d) (Ann -> String -> Term v Ann
forall a. Annotated a => a -> String -> Term v Ann
f Ann
d String
"Eval") (Term v Ann -> Term v Ann)
-> ((Ann, Term v Ann) -> Term v Ann)
-> (Ann, Term v Ann)
-> Term v Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term v Ann -> Term v Ann
addDelay (Term v Ann -> Term v Ann)
-> ((Ann, Term v Ann) -> Term v Ann)
-> (Ann, Term v Ann)
-> Term v Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ann, Term v Ann) -> Term v Ann
forall a b. (a, b) -> b
snd
          ((Ann, Term v Ann) -> Term v Ann)
-> P v m (Ann, Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P v m (Ann, Term v Ann)
-> [Token Lexeme] -> P v m (Ann, Term v Ann)
forall v (m :: * -> *) a.
(Ord v, Monad m) =>
P v m a -> [Token Lexeme] -> P v m a
subParse (Bool
-> Bool
-> String
-> P v m (Token ())
-> P v m Ann
-> P v m (Ann, Term v Ann)
forall (m :: * -> *) v end.
(Monad m, Var v, Annotated end) =>
Bool
-> Bool
-> String
-> P v m (Token ())
-> P v m end
-> P v m (Ann, Term v Ann)
block' Bool
False Bool
False String
"syntax.docEval" (Token () -> P v m (Token ())
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Token () -> P v m (Token ())) -> Token () -> P v m (Token ())
forall a b. (a -> b) -> a -> b
$ () -> Token ()
forall a. a -> Token a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (P v m Ann -> P v m (Ann, Term v Ann))
-> P v m Ann -> P v m (Ann, Term v Ann)
forall a b. (a -> b) -> a -> b
$ Ann
Ann.External Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ()
-> P v m Ann
forall a b.
a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) b
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a b. Functor 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) [Token Lexeme]
code
      Doc.ExampleBlock [Token Lexeme]
code ->
        Term v Ann -> [Term v Ann] -> Term v Ann
forall v a vt at ap.
(Ord v, Semigroup a) =>
Term2 vt at ap v a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
Term.apps' (Ann -> String -> Term v Ann
forall a. Annotated a => a -> String -> Term v Ann
f Ann
d String
"ExampleBlock") ([Term v Ann] -> Term v Ann)
-> ((Ann, Term v Ann) -> [Term v Ann])
-> (Ann, Term v Ann)
-> Term v Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ann -> ConstructorId -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> ConstructorId -> Term2 vt at ap v a
Term.nat (Ann -> Ann
forall a. Annotated a => a -> Ann
gann Ann
d) ConstructorId
0 Term v Ann -> [Term v Ann] -> [Term v Ann]
forall a. a -> [a] -> [a]
:) ([Term v Ann] -> [Term v Ann])
-> ((Ann, Term v Ann) -> [Term v Ann])
-> (Ann, Term v Ann)
-> [Term v Ann]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term v Ann -> [Term v Ann]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term v Ann -> [Term v Ann])
-> ((Ann, Term v Ann) -> Term v Ann)
-> (Ann, Term v Ann)
-> [Term v Ann]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term v Ann -> Term v Ann
addDelay (Term v Ann -> Term v Ann)
-> ((Ann, Term v Ann) -> Term v Ann)
-> (Ann, Term v Ann)
-> Term v Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ann, Term v Ann) -> Term v Ann
forall a b. (a, b) -> b
snd
          ((Ann, Term v Ann) -> Term v Ann)
-> P v m (Ann, Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P v m (Ann, Term v Ann)
-> [Token Lexeme] -> P v m (Ann, Term v Ann)
forall v (m :: * -> *) a.
(Ord v, Monad m) =>
P v m a -> [Token Lexeme] -> P v m a
subParse (Bool
-> Bool
-> String
-> P v m (Token ())
-> P v m Ann
-> P v m (Ann, Term v Ann)
forall (m :: * -> *) v end.
(Monad m, Var v, Annotated end) =>
Bool
-> Bool
-> String
-> P v m (Token ())
-> P v m end
-> P v m (Ann, Term v Ann)
block' Bool
False Bool
True String
"syntax.docExampleBlock" (Token () -> P v m (Token ())
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Token () -> P v m (Token ())) -> Token () -> P v m (Token ())
forall a b. (a -> b) -> a -> b
$ () -> Token ()
forall a. a -> Token a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (P v m Ann -> P v m (Ann, Term v Ann))
-> P v m Ann -> P v m (Ann, Term v Ann)
forall a b. (a -> b) -> a -> b
$ Ann
Ann.External Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ()
-> P v m Ann
forall a b.
a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) b
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a b. Functor 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) [Token Lexeme]
code
      Doc.CodeBlock String
label String
body ->
        Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term v Ann
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a b. (a -> b) -> a -> b
$
          Term v Ann -> [Term v Ann] -> Term v Ann
forall v a vt at ap.
(Ord v, Semigroup a) =>
Term2 vt at ap v a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
Term.apps'
            (Ann -> String -> Term v Ann
forall a. Annotated a => a -> String -> Term v Ann
f Ann
d String
"CodeBlock")
            [Ann -> Text -> Term v Ann
forall v a vt at ap. Ord v => a -> Text -> Term2 vt at ap v a
Term.text Ann
d (Text -> Term v Ann) -> Text -> Term v Ann
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
label, Ann -> Text -> Term v Ann
forall v a vt at ap. Ord v => a -> Text -> Term2 vt at ap v a
Term.text Ann
d (Text -> Term v Ann) -> Text -> Term v Ann
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
body]
      Doc.List' List (Term v Ann)
list -> Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term v Ann
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a b. (a -> b) -> a -> b
$ Ann -> List (Term v Ann) -> Term v Ann
docList Ann
d List (Term v Ann)
list
      Doc.Paragraph' Paragraph (Term v Ann)
para -> Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term v Ann
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a b. (a -> b) -> a -> b
$ Ann -> Paragraph (Term v Ann) -> Term v Ann
docParagraph Ann
d Paragraph (Term v Ann)
para

    docParagraph :: Ann -> Paragraph (Term v Ann) -> Term v Ann
docParagraph Ann
d Paragraph (Term v Ann)
leaves = Ann -> Term v Ann -> Term v Ann -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app (Ann -> Ann
forall a. Annotated a => a -> Ann
gann Ann
d) (Ann -> String -> Term v Ann
forall a. Annotated a => a -> String -> Term v Ann
f Ann
d String
"Paragraph") (Term v Ann -> Term v Ann)
-> ([Term v Ann] -> Term v Ann) -> [Term v Ann] -> Term v Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ann -> [Term v Ann] -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
Term.list Ann
d ([Term v Ann] -> Term v Ann) -> [Term v Ann] -> Term v Ann
forall a b. (a -> b) -> a -> b
$ Paragraph (Term v Ann) -> [Term v Ann]
forall a. Paragraph a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Paragraph (Term v Ann)
leaves

    docList :: Ann -> Doc.List (Term v Ann) -> Term v Ann
    docList :: Ann -> List (Term v Ann) -> Term v Ann
docList Ann
d = \case
      Doc.BulletedList NonEmpty (Column (Term v Ann))
items ->
        Ann -> Term v Ann -> Term v Ann -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app (Ann -> Ann
forall a. Annotated a => a -> Ann
gann Ann
d) (Ann -> String -> Term v Ann
forall a. Annotated a => a -> String -> Term v Ann
f Ann
d String
"BulletedList") (Term v Ann -> Term v Ann)
-> (NonEmpty (Term v Ann) -> Term v Ann)
-> NonEmpty (Term v Ann)
-> Term v Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ann -> [Term v Ann] -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
Term.list (Ann -> Ann
forall a. Annotated a => a -> Ann
gann Ann
d) ([Term v Ann] -> Term v Ann)
-> (NonEmpty (Term v Ann) -> [Term v Ann])
-> NonEmpty (Term v Ann)
-> Term v Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Term v Ann) -> [Term v Ann]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty (Term v Ann) -> Term v Ann)
-> NonEmpty (Term v Ann) -> Term v Ann
forall a b. (a -> b) -> a -> b
$ Ann -> Column (Term v Ann) -> Term v Ann
docColumn Ann
d (Column (Term v Ann) -> Term v Ann)
-> NonEmpty (Column (Term v Ann)) -> NonEmpty (Term v Ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Column (Term v Ann))
items
      Doc.NumberedList items :: NonEmpty (ConstructorId, Column (Term v Ann))
items@((ConstructorId
n, Column (Term v Ann)
_) :| [(ConstructorId, Column (Term v Ann))]
_) ->
        Term v Ann -> [Term v Ann] -> Term v Ann
forall v a vt at ap.
(Ord v, Semigroup a) =>
Term2 vt at ap v a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
Term.apps'
          (Ann -> String -> Term v Ann
forall a. Annotated a => a -> String -> Term v Ann
f Ann
d String
"NumberedList")
          [Ann -> ConstructorId -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> ConstructorId -> Term2 vt at ap v a
Term.nat (Ann -> Ann
forall a. Annotated a => a -> Ann
ann Ann
d) (ConstructorId -> Term v Ann) -> ConstructorId -> Term v Ann
forall a b. (a -> b) -> a -> b
$ ConstructorId
n, Ann -> [Term v Ann] -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
Term.list (Ann -> Ann
forall a. Annotated a => a -> Ann
gann Ann
d) ([Term v Ann] -> Term v Ann)
-> (NonEmpty (Term v Ann) -> [Term v Ann])
-> NonEmpty (Term v Ann)
-> Term v Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Term v Ann) -> [Term v Ann]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty (Term v Ann) -> Term v Ann)
-> NonEmpty (Term v Ann) -> Term v Ann
forall a b. (a -> b) -> a -> b
$ Ann -> Column (Term v Ann) -> Term v Ann
docColumn Ann
d (Column (Term v Ann) -> Term v Ann)
-> ((ConstructorId, Column (Term v Ann)) -> Column (Term v Ann))
-> (ConstructorId, Column (Term v Ann))
-> Term v Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConstructorId, Column (Term v Ann)) -> Column (Term v Ann)
forall a b. (a, b) -> b
snd ((ConstructorId, Column (Term v Ann)) -> Term v Ann)
-> NonEmpty (ConstructorId, Column (Term v Ann))
-> NonEmpty (Term v Ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (ConstructorId, Column (Term v Ann))
items]

    docColumn :: Ann -> Doc.Column (Term v Ann) -> Term v Ann
    docColumn :: Ann -> Column (Term v Ann) -> Term v Ann
docColumn Ann
d (Doc.Column Paragraph (Term v Ann)
para Maybe (List (Term v Ann))
sublist) =
      Ann -> Term v Ann -> Term v Ann -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app (Ann -> Ann
forall a. Annotated a => a -> Ann
gann Ann
d) (Ann -> String -> Term v Ann
forall a. Annotated a => a -> String -> Term v Ann
f Ann
d String
"Column") (Term v Ann -> Term v Ann)
-> ([Term v Ann] -> Term v Ann) -> [Term v Ann] -> Term v Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ann -> [Term v Ann] -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
Term.list (Ann -> Ann
forall a. Annotated a => a -> Ann
gann Ann
d) ([Term v Ann] -> Term v Ann) -> [Term v Ann] -> Term v Ann
forall a b. (a -> b) -> a -> b
$ Ann -> Paragraph (Term v Ann) -> Term v Ann
docParagraph Ann
d Paragraph (Term v Ann)
para Term v Ann -> [Term v Ann] -> [Term v Ann]
forall a. a -> [a] -> [a]
: Maybe (Term v Ann) -> [Term v Ann]
forall a. Maybe a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Ann -> List (Term v Ann) -> Term v Ann
docList Ann
d (List (Term v Ann) -> Term v Ann)
-> Maybe (List (Term v Ann)) -> Maybe (Term v Ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (List (Term v Ann))
sublist)

    docLeaf :: Ann -> Doc.Leaf (L.Token (ReferenceType, HQ'.HashQualified Name)) [L.Token L.Lexeme] (Term v Ann) -> TermP v m
    docLeaf :: Ann
-> Leaf
     (Token (ReferenceType, HashQualified Name))
     [Token Lexeme]
     (Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
docLeaf Ann
d = \case
      Doc.Link EmbedLink (Token (ReferenceType, HashQualified Name))
link -> Ann -> Term v Ann -> Term v Ann -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app (Ann -> Ann
forall a. Annotated a => a -> Ann
gann Ann
d) (Ann -> String -> Term v Ann
forall a. Annotated a => a -> String -> Term v Ann
f Ann
d String
"Link") (Term v Ann -> Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ann
-> EmbedLink (Token (ReferenceType, HashQualified Name))
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
docEmbedLink Ann
d EmbedLink (Token (ReferenceType, HashQualified Name))
link
      Doc.NamedLink Paragraph (Term v Ann)
para Group (Term v Ann)
group -> Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term v Ann
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a b. (a -> b) -> a -> b
$ Term v Ann -> [Term v Ann] -> Term v Ann
forall v a vt at ap.
(Ord v, Semigroup a) =>
Term2 vt at ap v a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
Term.apps' (Ann -> String -> Term v Ann
forall a. Annotated a => a -> String -> Term v Ann
f Ann
d String
"NamedLink") [Ann -> Paragraph (Term v Ann) -> Term v Ann
docParagraph Ann
d Paragraph (Term v Ann)
para, Ann -> Group (Term v Ann) -> Term v Ann
docGroup Ann
d Group (Term v Ann)
group]
      Doc.Example [Token Lexeme]
code -> do
        Term v Ann
trm <- ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
-> [Token Lexeme]
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall v (m :: * -> *) a.
(Ord v, Monad m) =>
P v m a -> [Token Lexeme] -> P v m a
subParse ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
term [Token Lexeme]
code
        Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term v Ann
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> ([Term v Ann] -> Term v Ann)
-> [Term v Ann]
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term v Ann -> [Term v Ann] -> Term v Ann
forall v a vt at ap.
(Ord v, Semigroup a) =>
Term2 vt at ap v a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
Term.apps' (Ann -> String -> Term v Ann
forall a. Annotated a => a -> String -> Term v Ann
f Ann
d String
"Example") ([Term v Ann]
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> [Term v Ann]
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a b. (a -> b) -> a -> b
$ case Term v Ann
trm of
          tm :: Term v Ann
tm@(Term.Apps' Term v Ann
_ [Term v Ann]
xs) ->
            let fvs :: [v]
fvs = [v] -> [v]
forall a. Ord a => [a] -> [a]
List.Extra.nubOrd ([v] -> [v]) -> [v] -> [v]
forall a b. (a -> b) -> a -> b
$ (Term v Ann -> [v]) -> [Term v Ann] -> [v]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Set v -> [v]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Set v -> [v]) -> (Term v Ann -> Set v) -> Term v Ann -> [v]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term v Ann -> Set v
forall vt v a. Term' vt v a -> Set v
Term.freeVars) [Term v Ann]
xs
                n :: Term v Ann
n = Ann -> ConstructorId -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> ConstructorId -> Term2 vt at ap v a
Term.nat (Term v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term v Ann
tm) (Int -> ConstructorId
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([v] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [v]
fvs))
                lam :: Term v Ann
lam = Term v Ann -> Term v Ann
addDelay (Term v Ann -> Term v Ann) -> Term v Ann -> Term v Ann
forall a b. (a -> b) -> a -> b
$ Ann -> [(Ann, v)] -> Term v Ann -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> [(a, v)] -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.lam' (Term v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term v Ann
tm) ((Ann
forall a. Monoid a => a
mempty,) (v -> (Ann, v)) -> [v] -> [(Ann, v)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [v]
fvs) Term v Ann
tm
             in [Term v Ann
n, Term v Ann
lam]
          Term v Ann
tm -> [Ann -> ConstructorId -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> ConstructorId -> Term2 vt at ap v a
Term.nat (Term v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term v Ann
tm) ConstructorId
0, Term v Ann -> Term v Ann
addDelay Term v Ann
tm]
      Doc.Transclude' Transclude [Token Lexeme]
trans -> Ann
-> Transclude [Token Lexeme]
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
docTransclude Ann
d Transclude [Token Lexeme]
trans
      Doc.Bold Paragraph (Term v Ann)
para -> Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term v Ann
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> (Term v Ann -> Term v Ann)
-> Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ann -> Term v Ann -> Term v Ann -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app (Ann -> Ann
forall a. Annotated a => a -> Ann
gann Ann
d) (Ann -> String -> Term v Ann
forall a. Annotated a => a -> String -> Term v Ann
f Ann
d String
"Bold") (Term v Ann
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a b. (a -> b) -> a -> b
$ Ann -> Paragraph (Term v Ann) -> Term v Ann
docParagraph Ann
d Paragraph (Term v Ann)
para
      Doc.Italic Paragraph (Term v Ann)
para -> Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term v Ann
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> (Term v Ann -> Term v Ann)
-> Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ann -> Term v Ann -> Term v Ann -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app (Ann -> Ann
forall a. Annotated a => a -> Ann
gann Ann
d) (Ann -> String -> Term v Ann
forall a. Annotated a => a -> String -> Term v Ann
f Ann
d String
"Italic") (Term v Ann
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a b. (a -> b) -> a -> b
$ Ann -> Paragraph (Term v Ann) -> Term v Ann
docParagraph Ann
d Paragraph (Term v Ann)
para
      Doc.Strikethrough Paragraph (Term v Ann)
para -> Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term v Ann
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> (Term v Ann -> Term v Ann)
-> Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ann -> Term v Ann -> Term v Ann -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app (Ann -> Ann
forall a. Annotated a => a -> Ann
gann Ann
d) (Ann -> String -> Term v Ann
forall a. Annotated a => a -> String -> Term v Ann
f Ann
d String
"Strikethrough") (Term v Ann
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a b. (a -> b) -> a -> b
$ Ann -> Paragraph (Term v Ann) -> Term v Ann
docParagraph Ann
d Paragraph (Term v Ann)
para
      Doc.Verbatim Word
leaf -> Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term v Ann
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> (Term v Ann -> Term v Ann)
-> Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ann -> Term v Ann -> Term v Ann -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app (Ann -> Ann
forall a. Annotated a => a -> Ann
gann Ann
d) (Ann -> String -> Term v Ann
forall a. Annotated a => a -> String -> Term v Ann
f Ann
d String
"Verbatim") (Term v Ann
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a b. (a -> b) -> a -> b
$ Ann -> Word -> Term v Ann
docWord Ann
d Word
leaf
      Doc.Code Word
leaf -> Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term v Ann
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> (Term v Ann -> Term v Ann)
-> Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ann -> Term v Ann -> Term v Ann -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app (Ann -> Ann
forall a. Annotated a => a -> Ann
gann Ann
d) (Ann -> String -> Term v Ann
forall a. Annotated a => a -> String -> Term v Ann
f Ann
d String
"Code") (Term v Ann
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a b. (a -> b) -> a -> b
$ Ann -> Word -> Term v Ann
docWord Ann
d Word
leaf
      Doc.Source NonEmpty
  (SourceElement
     (Token (ReferenceType, HashQualified Name))
     (Transclude [Token Lexeme]))
elems ->
        Ann -> Term v Ann -> Term v Ann -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app (Ann -> Ann
forall a. Annotated a => a -> Ann
gann Ann
d) (Ann -> String -> Term v Ann
forall a. Annotated a => a -> String -> Term v Ann
f Ann
d String
"Source") (Term v Ann -> Term v Ann)
-> (NonEmpty (Term v Ann) -> Term v Ann)
-> NonEmpty (Term v Ann)
-> Term v Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ann -> [Term v Ann] -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
Term.list Ann
d ([Term v Ann] -> Term v Ann)
-> (NonEmpty (Term v Ann) -> [Term v Ann])
-> NonEmpty (Term v Ann)
-> Term v Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Term v Ann) -> [Term v Ann]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty (Term v Ann) -> Term v Ann)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (NonEmpty (Term v Ann))
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SourceElement
   (Token (ReferenceType, HashQualified Name))
   (Transclude [Token Lexeme])
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> NonEmpty
     (SourceElement
        (Token (ReferenceType, HashQualified Name))
        (Transclude [Token Lexeme]))
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (NonEmpty (Term v Ann))
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) -> NonEmpty a -> f (NonEmpty b)
traverse (Ann
-> SourceElement
     (Token (ReferenceType, HashQualified Name))
     (Transclude [Token Lexeme])
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
docSourceElement Ann
d) NonEmpty
  (SourceElement
     (Token (ReferenceType, HashQualified Name))
     (Transclude [Token Lexeme]))
elems
      Doc.FoldedSource NonEmpty
  (SourceElement
     (Token (ReferenceType, HashQualified Name))
     (Transclude [Token Lexeme]))
elems ->
        Ann -> Term v Ann -> Term v Ann -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app (Ann -> Ann
forall a. Annotated a => a -> Ann
gann Ann
d) (Ann -> String -> Term v Ann
forall a. Annotated a => a -> String -> Term v Ann
f Ann
d String
"FoldedSource") (Term v Ann -> Term v Ann)
-> (NonEmpty (Term v Ann) -> Term v Ann)
-> NonEmpty (Term v Ann)
-> Term v Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ann -> [Term v Ann] -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
Term.list Ann
d ([Term v Ann] -> Term v Ann)
-> (NonEmpty (Term v Ann) -> [Term v Ann])
-> NonEmpty (Term v Ann)
-> Term v Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Term v Ann) -> [Term v Ann]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty (Term v Ann) -> Term v Ann)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (NonEmpty (Term v Ann))
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SourceElement
   (Token (ReferenceType, HashQualified Name))
   (Transclude [Token Lexeme])
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> NonEmpty
     (SourceElement
        (Token (ReferenceType, HashQualified Name))
        (Transclude [Token Lexeme]))
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (NonEmpty (Term v Ann))
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) -> NonEmpty a -> f (NonEmpty b)
traverse (Ann
-> SourceElement
     (Token (ReferenceType, HashQualified Name))
     (Transclude [Token Lexeme])
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
docSourceElement Ann
d) NonEmpty
  (SourceElement
     (Token (ReferenceType, HashQualified Name))
     (Transclude [Token Lexeme]))
elems
      Doc.EvalInline [Token Lexeme]
code -> Ann -> Term v Ann -> Term v Ann -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app (Ann -> Ann
forall a. Annotated a => a -> Ann
gann Ann
d) (Ann -> String -> Term v Ann
forall a. Annotated a => a -> String -> Term v Ann
f Ann
d String
"EvalInline") (Term v Ann -> Term v Ann)
-> (Term v Ann -> Term v Ann) -> Term v Ann -> Term v Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term v Ann -> Term v Ann
addDelay (Term v Ann -> Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
-> [Token Lexeme]
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall v (m :: * -> *) a.
(Ord v, Monad m) =>
P v m a -> [Token Lexeme] -> P v m a
subParse ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
term [Token Lexeme]
code
      Doc.Signature NonEmpty
  (EmbedSignatureLink (Token (ReferenceType, HashQualified Name)))
links ->
        Ann -> Term v Ann -> Term v Ann -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app (Ann -> Ann
forall a. Annotated a => a -> Ann
gann Ann
d) (Ann -> String -> Term v Ann
forall a. Annotated a => a -> String -> Term v Ann
f Ann
d String
"Signature") (Term v Ann -> Term v Ann)
-> (NonEmpty (Term v Ann) -> Term v Ann)
-> NonEmpty (Term v Ann)
-> Term v Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ann -> [Term v Ann] -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
Term.list Ann
d ([Term v Ann] -> Term v Ann)
-> (NonEmpty (Term v Ann) -> [Term v Ann])
-> NonEmpty (Term v Ann)
-> Term v Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Term v Ann) -> [Term v Ann]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty (Term v Ann) -> Term v Ann)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (NonEmpty (Term v Ann))
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (EmbedSignatureLink (Token (ReferenceType, HashQualified Name))
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> NonEmpty
     (EmbedSignatureLink (Token (ReferenceType, HashQualified Name)))
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (NonEmpty (Term v Ann))
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) -> NonEmpty a -> f (NonEmpty b)
traverse (Ann
-> EmbedSignatureLink (Token (ReferenceType, HashQualified Name))
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
docEmbedSignatureLink Ann
d) NonEmpty
  (EmbedSignatureLink (Token (ReferenceType, HashQualified Name)))
links
      Doc.SignatureInline EmbedSignatureLink (Token (ReferenceType, HashQualified Name))
link -> Ann -> Term v Ann -> Term v Ann -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app (Ann -> Ann
forall a. Annotated a => a -> Ann
gann Ann
d) (Ann -> String -> Term v Ann
forall a. Annotated a => a -> String -> Term v Ann
f Ann
d String
"SignatureInline") (Term v Ann -> Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ann
-> EmbedSignatureLink (Token (ReferenceType, HashQualified Name))
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
docEmbedSignatureLink Ann
d EmbedSignatureLink (Token (ReferenceType, HashQualified Name))
link
      Doc.Word' Word
word -> Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term v Ann
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a b. (a -> b) -> a -> b
$ Ann -> Word -> Term v Ann
docWord Ann
d Word
word
      Doc.Group' Group (Term v Ann)
group -> Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term v Ann
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a b. (a -> b) -> a -> b
$ Ann -> Group (Term v Ann) -> Term v Ann
docGroup Ann
d Group (Term v Ann)
group

    docEmbedLink :: Ann -> Doc.EmbedLink (L.Token (ReferenceType, HQ'.HashQualified Name)) -> TermP v m
    docEmbedLink :: Ann
-> EmbedLink (Token (ReferenceType, HashQualified Name))
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
docEmbedLink Ann
d (Doc.EmbedLink (L.Token (ReferenceType
level, HashQualified Name
ident) Pos
start Pos
end)) = case ReferenceType
level of
      ReferenceType
RtType ->
        Ann -> Term v Ann -> Term v Ann -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app (Ann -> Ann
forall a. Annotated a => a -> Ann
gann Ann
d) (Ann -> String -> Term v Ann
forall a. Annotated a => a -> String -> Term v Ann
f Ann
d String
"EmbedTypeLink") (Term v Ann -> Term v Ann)
-> (Token TypeReference -> Term v Ann)
-> Token TypeReference
-> Term v Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ann -> TypeReference -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> TypeReference -> Term2 vt at ap v a
Term.typeLink (Ann -> Ann
forall a. Annotated a => a -> Ann
ann Ann
d) (TypeReference -> Term v Ann)
-> (Token TypeReference -> TypeReference)
-> Token TypeReference
-> Term v Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token TypeReference -> TypeReference
forall a. Token a -> a
L.payload
          (Token TypeReference -> Term v Ann)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token TypeReference)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Token (HashQualified Name)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token TypeReference)
forall (m :: * -> *) v.
(Monad m, Var v) =>
Token (HashQualified Name) -> P v m (Token TypeReference)
findUniqueType (HashQualified Name -> Pos -> Pos -> Token (HashQualified Name)
forall a. a -> Pos -> Pos -> Token a
L.Token (HashQualified Name -> HashQualified Name
forall n. HashQualified n -> HashQualified n
HQ'.toHQ HashQualified Name
ident) Pos
start Pos
end)
      ReferenceType
RtTerm ->
        Ann -> Term v Ann -> Term v Ann -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app (Ann -> Ann
forall a. Annotated a => a -> Ann
gann Ann
d) (Ann -> String -> Term v Ann
forall a. Annotated a => a -> String -> Term v Ann
f Ann
d String
"EmbedTermLink") (Term v Ann -> Term v Ann)
-> (Term v Ann -> Term v Ann) -> Term v Ann -> Term v Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term v Ann -> Term v Ann
addDelay (Term v Ann -> Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Token (HashQualified Name)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (m :: * -> *) v.
(Monad m, Var v) =>
Token (HashQualified Name) -> TermP v m
resolveHashQualified (HashQualified Name -> Pos -> Pos -> Token (HashQualified Name)
forall a. a -> Pos -> Pos -> Token a
L.Token (HashQualified Name -> HashQualified Name
forall n. HashQualified n -> HashQualified n
HQ'.toHQ HashQualified Name
ident) Pos
start Pos
end)

    docTransclude :: Ann -> Doc.Transclude [L.Token L.Lexeme] -> TermP v m
    docTransclude :: Ann
-> Transclude [Token Lexeme]
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
docTransclude Ann
d (Doc.Transclude [Token Lexeme]
code) = Ann -> Term v Ann -> Term v Ann -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app (Ann -> Ann
forall a. Annotated a => a -> Ann
gann Ann
d) (Ann -> String -> Term v Ann
forall a. Annotated a => a -> String -> Term v Ann
f Ann
d String
"Transclude") (Term v Ann -> Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
-> [Token Lexeme]
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall v (m :: * -> *) a.
(Ord v, Monad m) =>
P v m a -> [Token Lexeme] -> P v m a
subParse ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
term [Token Lexeme]
code

    docSourceElement ::
      Ann ->
      Doc.SourceElement (L.Token (ReferenceType, HQ'.HashQualified Name)) (Doc.Transclude [L.Token L.Lexeme]) ->
      TermP v m
    docSourceElement :: Ann
-> SourceElement
     (Token (ReferenceType, HashQualified Name))
     (Transclude [Token Lexeme])
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
docSourceElement Ann
d (Doc.SourceElement EmbedLink (Token (ReferenceType, HashQualified Name))
link [EmbedAnnotation
   (Token (ReferenceType, HashQualified Name))
   (Transclude [Token Lexeme])]
anns) = do
      Term v Ann
link' <- Ann
-> EmbedLink (Token (ReferenceType, HashQualified Name))
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
docEmbedLink Ann
d EmbedLink (Token (ReferenceType, HashQualified Name))
link
      [Term v Ann]
anns' <- (EmbedAnnotation
   (Token (ReferenceType, HashQualified Name))
   (Transclude [Token Lexeme])
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> [EmbedAnnotation
      (Token (ReferenceType, HashQualified Name))
      (Transclude [Token Lexeme])]
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) [Term v Ann]
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) -> [a] -> f [b]
traverse (Ann
-> EmbedAnnotation
     (Token (ReferenceType, HashQualified Name))
     (Transclude [Token Lexeme])
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
docEmbedAnnotation Ann
d) [EmbedAnnotation
   (Token (ReferenceType, HashQualified Name))
   (Transclude [Token Lexeme])]
anns
      pure $ Term v Ann -> [Term v Ann] -> Term v Ann
forall v a vt at ap.
(Ord v, Semigroup a) =>
Term2 vt at ap v a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
Term.apps' (Ann -> String -> Term v Ann
forall a. Annotated a => a -> String -> Term v Ann
f Ann
d String
"SourceElement") [Term v Ann
link', Ann -> [Term v Ann] -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
Term.list Ann
d [Term v Ann]
anns']

    docEmbedSignatureLink ::
      Ann -> Doc.EmbedSignatureLink (L.Token (ReferenceType, HQ'.HashQualified Name)) -> TermP v m
    docEmbedSignatureLink :: Ann
-> EmbedSignatureLink (Token (ReferenceType, HashQualified Name))
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
docEmbedSignatureLink Ann
d (Doc.EmbedSignatureLink (L.Token (ReferenceType
level, HashQualified Name
ident) Pos
start Pos
end)) = case ReferenceType
level of
      ReferenceType
RtType -> Error v
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
P.customFailure (Error v
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> (Token (HashQualified Name) -> Error v)
-> Token (HashQualified Name)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token (HashQualified Name) -> Error v
forall v. Token (HashQualified Name) -> Error v
TypeNotAllowed (Token (HashQualified Name)
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> Token (HashQualified Name)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a b. (a -> b) -> a -> b
$ HashQualified Name -> Pos -> Pos -> Token (HashQualified Name)
forall a. a -> Pos -> Pos -> Token a
L.Token (HashQualified Name -> HashQualified Name
forall n. HashQualified n -> HashQualified n
HQ'.toHQ HashQualified Name
ident) Pos
start Pos
end
      ReferenceType
RtTerm ->
        Ann -> Term v Ann -> Term v Ann -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app (Ann -> Ann
forall a. Annotated a => a -> Ann
gann Ann
d) (Ann -> String -> Term v Ann
forall a. Annotated a => a -> String -> Term v Ann
f Ann
d String
"EmbedSignatureLink") (Term v Ann -> Term v Ann)
-> (Term v Ann -> Term v Ann) -> Term v Ann -> Term v Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term v Ann -> Term v Ann
addDelay
          (Term v Ann -> Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Token (HashQualified Name)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (m :: * -> *) v.
(Monad m, Var v) =>
Token (HashQualified Name) -> TermP v m
resolveHashQualified (HashQualified Name -> Pos -> Pos -> Token (HashQualified Name)
forall a. a -> Pos -> Pos -> Token a
L.Token (HashQualified Name -> HashQualified Name
forall n. HashQualified n -> HashQualified n
HQ'.toHQ HashQualified Name
ident) Pos
start Pos
end)

    docEmbedAnnotation ::
      Ann ->
      Doc.EmbedAnnotation (L.Token (ReferenceType, HQ'.HashQualified Name)) (Doc.Transclude [L.Token L.Lexeme]) ->
      TermP v m
    docEmbedAnnotation :: Ann
-> EmbedAnnotation
     (Token (ReferenceType, HashQualified Name))
     (Transclude [Token Lexeme])
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
docEmbedAnnotation Ann
d (Doc.EmbedAnnotation Either
  (Token (ReferenceType, HashQualified Name))
  (Transclude [Token Lexeme])
a) =
      -- This is the only place I’m not sure we’re doing the right thing. In the lexer, this can be an identifier or a
      -- DocLeaf, but here it could be either /text/ or a Doc element. And I don’t think there’s any way the lexemes
      -- produced for an identifier and the lexemes consumed for text line up. So, I think this is a bugfix I can’t
      -- avoid.
      Ann -> Term v Ann -> Term v Ann -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app (Ann -> Ann
forall a. Annotated a => a -> Ann
gann Ann
d) (Ann -> String -> Term v Ann
forall a. Annotated a => a -> String -> Term v Ann
f Ann
d String
"EmbedAnnotation")
        (Term v Ann -> Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Token (ReferenceType, HashQualified Name)
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> (Transclude [Token Lexeme]
    -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> Either
     (Token (ReferenceType, HashQualified Name))
     (Transclude [Token Lexeme])
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
          ( \(L.Token (ReferenceType
level, HashQualified Name
ident) Pos
start Pos
end) -> case ReferenceType
level of
              ReferenceType
RtType -> Error v
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
P.customFailure (Error v
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> (Token (HashQualified Name) -> Error v)
-> Token (HashQualified Name)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token (HashQualified Name) -> Error v
forall v. Token (HashQualified Name) -> Error v
TypeNotAllowed (Token (HashQualified Name)
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> Token (HashQualified Name)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a b. (a -> b) -> a -> b
$ HashQualified Name -> Pos -> Pos -> Token (HashQualified Name)
forall a. a -> Pos -> Pos -> Token a
L.Token (HashQualified Name -> HashQualified Name
forall n. HashQualified n -> HashQualified n
HQ'.toHQ HashQualified Name
ident) Pos
start Pos
end
              ReferenceType
RtTerm -> Token (HashQualified Name)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (m :: * -> *) v.
(Monad m, Var v) =>
Token (HashQualified Name) -> TermP v m
resolveHashQualified (Token (HashQualified Name)
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> Token (HashQualified Name)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a b. (a -> b) -> a -> b
$ HashQualified Name -> Pos -> Pos -> Token (HashQualified Name)
forall a. a -> Pos -> Pos -> Token a
L.Token (HashQualified Name -> HashQualified Name
forall n. HashQualified n -> HashQualified n
HQ'.toHQ HashQualified Name
ident) Pos
start Pos
end
          )
          (Ann
-> Transclude [Token Lexeme]
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
docTransclude Ann
d)
          Either
  (Token (ReferenceType, HashQualified Name))
  (Transclude [Token Lexeme])
a

    docWord :: Ann -> Doc.Word -> Term v Ann
    docWord :: Ann -> Word -> Term v Ann
docWord Ann
d (Doc.Word String
txt) = Ann -> Term v Ann -> Term v Ann -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app (Ann -> Ann
forall a. Annotated a => a -> Ann
gann Ann
d) (Ann -> String -> Term v Ann
forall a. Annotated a => a -> String -> Term v Ann
f Ann
d String
"Word") (Term v Ann -> Term v Ann)
-> (Text -> Term v Ann) -> Text -> Term v Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ann -> Text -> Term v Ann
forall v a vt at ap. Ord v => a -> Text -> Term2 vt at ap v a
Term.text Ann
d (Text -> Term v Ann) -> Text -> Term v Ann
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
txt

    docGroup :: Ann -> Doc.Group (Term v Ann) -> Term v Ann
    docGroup :: Ann -> Group (Term v Ann) -> Term v Ann
docGroup Ann
d (Doc.Group (Doc.Join NonEmpty (Term v Ann)
leaves)) =
      Ann -> Term v Ann -> Term v Ann -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app Ann
d (Ann -> String -> Term v Ann
forall a. Annotated a => a -> String -> Term v Ann
f Ann
d String
"Group") (Term v Ann -> Term v Ann)
-> ([Term v Ann] -> Term v Ann) -> [Term v Ann] -> Term v Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ann -> Term v Ann -> Term v Ann -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app Ann
d (Ann -> String -> Term v Ann
forall a. Annotated a => a -> String -> Term v Ann
f Ann
d String
"Join") (Term v Ann -> Term v Ann)
-> ([Term v Ann] -> Term v Ann) -> [Term v Ann] -> Term v Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ann -> [Term v Ann] -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
Term.list (NonEmpty (Term v Ann) -> Ann
forall a. Annotated a => a -> Ann
ann NonEmpty (Term v Ann)
leaves) ([Term v Ann] -> Term v Ann) -> [Term v Ann] -> Term v Ann
forall a b. (a -> b) -> a -> b
$ NonEmpty (Term v Ann) -> [Term v Ann]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (Term v Ann)
leaves

docBlock :: (Monad m, Var v) => TermP v m
docBlock :: forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
docBlock = do
  Token ()
openTok <- String -> P v m (Token ())
forall v (m :: * -> *). Ord v => String -> P v m (Token ())
openBlockWith String
"[:"
  [Term2 v Ann Ann v Ann]
segs <- TermP v m
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) [Term2 v Ann Ann v Ann]
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 TermP v m
segment
  Token ()
closeTok <- P v m (Token ())
forall v (m :: * -> *). Ord v => P v m (Token ())
closeBlock
  let a :: Ann
a = Token () -> Ann
forall a. Annotated a => a -> Ann
ann Token ()
openTok Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
<> Token () -> Ann
forall a. Annotated a => a -> Ann
ann Token ()
closeTok
  Term2 v Ann Ann v Ann -> TermP v m
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term2 v Ann Ann v Ann -> TermP v m)
-> (Term2 v Ann Ann v Ann -> Term2 v Ann Ann v Ann)
-> Term2 v Ann Ann v Ann
-> TermP v m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term2 v Ann Ann v Ann -> Term2 v Ann Ann v Ann
forall v a. (Ord v, Show v) => Term v a -> Term v a
docNormalize (Term2 v Ann Ann v Ann -> TermP v m)
-> Term2 v Ann Ann v Ann -> TermP v m
forall a b. (a -> b) -> a -> b
$ Ann
-> Term2 v Ann Ann v Ann
-> Term2 v Ann Ann v Ann
-> Term2 v Ann Ann v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app Ann
a (Ann -> ConstructorReference -> Term2 v Ann Ann v Ann
forall v a vt at ap.
Ord v =>
a -> ConstructorReference -> Term2 vt at ap v a
Term.constructor Ann
a (TypeReference -> ConstructorId -> ConstructorReference
forall r. r -> ConstructorId -> GConstructorReference r
ConstructorReference TypeReference
DD.docRef ConstructorId
DD.docJoinId)) (Ann -> [Term2 v Ann Ann v Ann] -> Term2 v Ann Ann v Ann
forall v a vt at ap.
Ord v =>
a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
Term.list Ann
a [Term2 v Ann Ann v Ann]
segs)
  where
    segment :: TermP v m
segment = TermP v m
forall {m :: * -> *} {vt} {at} {ap}.
ParsecT
  (Error v) Input (ReaderT (ParsingEnv m) m) (Term2 vt at ap v Ann)
blob TermP v m -> TermP v m -> TermP v 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
<|> TermP v m
linky
    blob :: ParsecT
  (Error v) Input (ReaderT (ParsingEnv m) m) (Term2 vt at ap v Ann)
blob = do
      Token Text
s <- P v m (Token Text)
forall v (m :: * -> *). Ord v => P v m (Token Text)
string
      pure $
        Ann
-> Term2 vt at ap v Ann
-> Term2 vt at ap v Ann
-> Term2 vt at ap v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app
          (Token Text -> Ann
forall a. Annotated a => a -> Ann
ann Token Text
s)
          (Ann -> ConstructorReference -> Term2 vt at ap v Ann
forall v a vt at ap.
Ord v =>
a -> ConstructorReference -> Term2 vt at ap v a
Term.constructor (Token Text -> Ann
forall a. Annotated a => a -> Ann
ann Token Text
s) (TypeReference -> ConstructorId -> ConstructorReference
forall r. r -> ConstructorId -> GConstructorReference r
ConstructorReference TypeReference
DD.docRef ConstructorId
DD.docBlobId))
          (Ann -> Text -> Term2 vt at ap v Ann
forall v a vt at ap. Ord v => a -> Text -> Term2 vt at ap v a
Term.text (Token Text -> Ann
forall a. Annotated a => a -> Ann
ann Token Text
s) (Token Text -> Text
forall a. Token a -> a
L.payload Token Text
s))
    linky :: TermP v m
linky = [TermP v m] -> TermP v m
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [TermP v m
include, TermP v m
forall {vt} {at} {ap}.
ParsecT
  (Error v) Input (ReaderT (ParsingEnv m) m) (Term2 vt at ap v Ann)
signature, TermP v m
forall {vt} {at} {ap}.
ParsecT
  (Error v) Input (ReaderT (ParsingEnv m) m) (Term2 vt at ap v Ann)
evaluate, TermP v m
source, TermP v m
link]
    include :: TermP v m
include = do
      Token String
_ <- ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token String)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) 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 (String
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token String)
forall v (m :: * -> *). Ord v => String -> P v m (Token String)
reserved String
"include")
      TermP v m
forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
hashQualifiedPrefixTerm
    signature :: ParsecT
  (Error v) Input (ReaderT (ParsingEnv m) m) (Term2 vt at ap v Ann)
signature = do
      Token String
_ <- ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token String)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) 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 (String
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token String)
forall v (m :: * -> *). Ord v => String -> P v m (Token String)
reserved String
"signature")
      Token Referent
tok <- P v m (Token Referent)
forall (m :: * -> *) v. (Monad m, Var v) => P v m (Token Referent)
termLink'
      pure $
        Ann
-> Term2 vt at ap v Ann
-> Term2 vt at ap v Ann
-> Term2 vt at ap v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app
          (Token Referent -> Ann
forall a. Annotated a => a -> Ann
ann Token Referent
tok)
          (Ann -> ConstructorReference -> Term2 vt at ap v Ann
forall v a vt at ap.
Ord v =>
a -> ConstructorReference -> Term2 vt at ap v a
Term.constructor (Token Referent -> Ann
forall a. Annotated a => a -> Ann
ann Token Referent
tok) (TypeReference -> ConstructorId -> ConstructorReference
forall r. r -> ConstructorId -> GConstructorReference r
ConstructorReference TypeReference
DD.docRef ConstructorId
DD.docSignatureId))
          (Ann -> Referent -> Term2 vt at ap v Ann
forall v a vt at ap. Ord v => a -> Referent -> Term2 vt at ap v a
Term.termLink (Token Referent -> Ann
forall a. Annotated a => a -> Ann
ann Token Referent
tok) (Token Referent -> Referent
forall a. Token a -> a
L.payload Token Referent
tok))
    evaluate :: ParsecT
  (Error v) Input (ReaderT (ParsingEnv m) m) (Term2 vt at ap v Ann)
evaluate = do
      Token String
_ <- ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token String)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) 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 (String
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token String)
forall v (m :: * -> *). Ord v => String -> P v m (Token String)
reserved String
"evaluate")
      Token Referent
tok <- P v m (Token Referent)
forall (m :: * -> *) v. (Monad m, Var v) => P v m (Token Referent)
termLink'
      pure $
        Ann
-> Term2 vt at ap v Ann
-> Term2 vt at ap v Ann
-> Term2 vt at ap v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app
          (Token Referent -> Ann
forall a. Annotated a => a -> Ann
ann Token Referent
tok)
          (Ann -> ConstructorReference -> Term2 vt at ap v Ann
forall v a vt at ap.
Ord v =>
a -> ConstructorReference -> Term2 vt at ap v a
Term.constructor (Token Referent -> Ann
forall a. Annotated a => a -> Ann
ann Token Referent
tok) (TypeReference -> ConstructorId -> ConstructorReference
forall r. r -> ConstructorId -> GConstructorReference r
ConstructorReference TypeReference
DD.docRef ConstructorId
DD.docEvaluateId))
          (Ann -> Referent -> Term2 vt at ap v Ann
forall v a vt at ap. Ord v => a -> Referent -> Term2 vt at ap v a
Term.termLink (Token Referent -> Ann
forall a. Annotated a => a -> Ann
ann Token Referent
tok) (Token Referent -> Referent
forall a. Token a -> a
L.payload Token Referent
tok))
    source :: TermP v m
source = do
      Token String
_ <- ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token String)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) 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 (String
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token String)
forall v (m :: * -> *). Ord v => String -> P v m (Token String)
reserved String
"source")
      Term2 v Ann Ann v Ann
l <- TermP v m
forall {vt} {at} {ap}.
ParsecT
  (Error v) Input (ReaderT (ParsingEnv m) m) (Term2 vt at ap v Ann)
link''
      pure $
        Ann
-> Term2 v Ann Ann v Ann
-> Term2 v Ann Ann v Ann
-> Term2 v Ann Ann v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app
          (Term2 v Ann Ann v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term2 v Ann Ann v Ann
l)
          (Ann -> ConstructorReference -> Term2 v Ann Ann v Ann
forall v a vt at ap.
Ord v =>
a -> ConstructorReference -> Term2 vt at ap v a
Term.constructor (Term2 v Ann Ann v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term2 v Ann Ann v Ann
l) (TypeReference -> ConstructorId -> ConstructorReference
forall r. r -> ConstructorId -> GConstructorReference r
ConstructorReference TypeReference
DD.docRef ConstructorId
DD.docSourceId))
          Term2 v Ann Ann v Ann
l
    link'' :: ParsecT
  (Error v) Input (ReaderT (ParsingEnv m) m) (Term2 vt at ap v Ann)
link'' = (Token TypeReference -> Term2 vt at ap v Ann)
-> (Token Referent -> Term2 vt at ap v Ann)
-> Either (Token TypeReference) (Token Referent)
-> Term2 vt at ap v Ann
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Token TypeReference -> Term2 vt at ap v Ann
forall {v} {vt} {at} {ap}.
Ord v =>
Token TypeReference -> Term2 vt at ap v Ann
ty Token Referent -> Term2 vt at ap v Ann
forall {v} {vt} {at} {ap}.
Ord v =>
Token Referent -> Term2 vt at ap v Ann
t (Either (Token TypeReference) (Token Referent)
 -> Term2 vt at ap v Ann)
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (Either (Token TypeReference) (Token Referent))
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Term2 vt at ap v Ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT
  (Error v)
  Input
  (ReaderT (ParsingEnv m) m)
  (Either (Token TypeReference) (Token Referent))
forall (m :: * -> *) v.
(Monad m, Var v) =>
P v m (Either (Token TypeReference) (Token Referent))
link'
      where
        t :: Token Referent -> Term2 vt at ap v Ann
t Token Referent
tok =
          Ann
-> Term2 vt at ap v Ann
-> Term2 vt at ap v Ann
-> Term2 vt at ap v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app
            (Token Referent -> Ann
forall a. Annotated a => a -> Ann
ann Token Referent
tok)
            (Ann -> ConstructorReference -> Term2 vt at ap v Ann
forall v a vt at ap.
Ord v =>
a -> ConstructorReference -> Term2 vt at ap v a
Term.constructor (Token Referent -> Ann
forall a. Annotated a => a -> Ann
ann Token Referent
tok) (TypeReference -> ConstructorId -> ConstructorReference
forall r. r -> ConstructorId -> GConstructorReference r
ConstructorReference TypeReference
DD.linkRef ConstructorId
DD.linkTermId))
            (Ann -> Referent -> Term2 vt at ap v Ann
forall v a vt at ap. Ord v => a -> Referent -> Term2 vt at ap v a
Term.termLink (Token Referent -> Ann
forall a. Annotated a => a -> Ann
ann Token Referent
tok) (Token Referent -> Referent
forall a. Token a -> a
L.payload Token Referent
tok))
        ty :: Token TypeReference -> Term2 vt at ap v Ann
ty Token TypeReference
tok =
          Ann
-> Term2 vt at ap v Ann
-> Term2 vt at ap v Ann
-> Term2 vt at ap v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app
            (Token TypeReference -> Ann
forall a. Annotated a => a -> Ann
ann Token TypeReference
tok)
            (Ann -> ConstructorReference -> Term2 vt at ap v Ann
forall v a vt at ap.
Ord v =>
a -> ConstructorReference -> Term2 vt at ap v a
Term.constructor (Token TypeReference -> Ann
forall a. Annotated a => a -> Ann
ann Token TypeReference
tok) (TypeReference -> ConstructorId -> ConstructorReference
forall r. r -> ConstructorId -> GConstructorReference r
ConstructorReference TypeReference
DD.linkRef ConstructorId
DD.linkTypeId))
            (Ann -> TypeReference -> Term2 vt at ap v Ann
forall v a vt at ap.
Ord v =>
a -> TypeReference -> Term2 vt at ap v a
Term.typeLink (Token TypeReference -> Ann
forall a. Annotated a => a -> Ann
ann Token TypeReference
tok) (Token TypeReference -> TypeReference
forall a. Token a -> a
L.payload Token TypeReference
tok))
    link :: TermP v m
link = Term2 v Ann Ann v Ann -> Term2 v Ann Ann v Ann
forall {v} {vt} {at} {ap}.
Ord v =>
Term (F vt at ap) v Ann -> Term (F vt at ap) v Ann
d (Term2 v Ann Ann v Ann -> Term2 v Ann Ann v Ann)
-> TermP v m -> TermP v m
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermP v m
forall {vt} {at} {ap}.
ParsecT
  (Error v) Input (ReaderT (ParsingEnv m) m) (Term2 vt at ap v Ann)
link''
      where
        d :: Term (F vt at ap) v Ann -> Term (F vt at ap) v Ann
d Term (F vt at ap) v Ann
tm = Ann
-> Term (F vt at ap) v Ann
-> Term (F vt at ap) v Ann
-> Term (F vt at ap) v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app (Term (F vt at ap) v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term (F vt at ap) v Ann
tm) (Ann -> ConstructorReference -> Term (F vt at ap) v Ann
forall v a vt at ap.
Ord v =>
a -> ConstructorReference -> Term2 vt at ap v a
Term.constructor (Term (F vt at ap) v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term (F vt at ap) v Ann
tm) (TypeReference -> ConstructorId -> ConstructorReference
forall r. r -> ConstructorId -> GConstructorReference r
ConstructorReference TypeReference
DD.docRef ConstructorId
DD.docLinkId)) Term (F vt at ap) v Ann
tm

-- Used by unbreakParas within docNormalize.  Doc literals are a joined sequence
-- segments.  This type describes a property of a segment.
data UnbreakCase
  = -- Finishes with a newline and hence does not determine whether the next
    -- line starts with whitespace.
    LineEnds
  | -- Ends with "\n something", i.e. introduces an indented line.
    StartsIndented
  | -- Ends with "\nsomething", i.e. introduces an unindented line.
    StartsUnindented
  deriving (UnbreakCase -> UnbreakCase -> Bool
(UnbreakCase -> UnbreakCase -> Bool)
-> (UnbreakCase -> UnbreakCase -> Bool) -> Eq UnbreakCase
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UnbreakCase -> UnbreakCase -> Bool
== :: UnbreakCase -> UnbreakCase -> Bool
$c/= :: UnbreakCase -> UnbreakCase -> Bool
/= :: UnbreakCase -> UnbreakCase -> Bool
Eq, Int -> UnbreakCase -> String -> String
[UnbreakCase] -> String -> String
UnbreakCase -> String
(Int -> UnbreakCase -> String -> String)
-> (UnbreakCase -> String)
-> ([UnbreakCase] -> String -> String)
-> Show UnbreakCase
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> UnbreakCase -> String -> String
showsPrec :: Int -> UnbreakCase -> String -> String
$cshow :: UnbreakCase -> String
show :: UnbreakCase -> String
$cshowList :: [UnbreakCase] -> String -> String
showList :: [UnbreakCase] -> String -> String
Show)

-- Doc literal normalization
--
-- This normalization allows the pretty-printer and doc display code to do
-- indenting, and to do line-wrap of paragraphs, but without the inserted
-- newlines being then frozen into the text for ever more over subsequent
-- edit/update cycles.
--
-- The alternative would be to stop line-wrapping docs on view/display by adding
-- newlines in the pretty-printer, and instead leave wrapping to the
-- terminal/editor.  Might be worth considering if this code ends up being
-- too buggy and fragile to maintain.  Maybe display could add newlines,
-- and view could refrain from doing so.
--
-- Operates on the text of the Blobs within a doc (as parsed by docBlock):
-- - reduces the whitespace after all newlines so that at least one of the
--   non-initial lines has zero indent (important because the pretty-printer adds
--   indenting when displaying doc literals)
-- - removes trailing whitespace from each line
-- - removes newlines between any sequence of non-empty zero-indent lines
--   (i.e. undo line-breaking within paragraphs).
--
-- Should be understood in tandem with Util.Pretty.paragraphyText, which
-- outputs doc text for display/edit/view.
-- See also unison-src/transcripts/doc-formatting.md.
--
-- There is some heuristic/approximate logic in here - see the comment flagged
-- with ** below.
--
-- This function is a bit painful - it's trying to act on a sequence of lines,
-- but that sequence is split up between the various blobs in the doc, which
-- are separated by the elements tracking things like @[source] etc.  It
-- would be simplified if the doc representation was something like
-- [Either Char EnrichedElement].
--
-- This function has some tracing which you can enable by deleting some calls to
-- 'const id' below.
docNormalize :: (Ord v, Show v) => Term v a -> Term v a
docNormalize :: forall v a. (Ord v, Show v) => Term v a -> Term v a
docNormalize Term v a
tm = case Term v a
tm of
  -- This pattern is just `DD.DocJoin seqs`, but exploded in order to grab
  -- the annotations.  The aim is just to map `normalize` over it.
  a :: Term v a
a@(Term.App' c :: Term v a
c@(Term.Constructor' (ConstructorReference TypeReference
DD.DocRef ConstructorId
DD.DocJoinId)) s :: Term v a
s@(Term.List' Seq (Term v a)
seqs)) ->
    a -> a -> a -> Seq (Term v a) -> Term v a
forall {v} {a} {vt} {at} {ap}.
Ord v =>
a -> a -> a -> Seq (Term2 vt at ap v a) -> Term2 vt at ap v a
join
      (Term v a -> a
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term v a
a)
      (Term v a -> a
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term v a
c)
      (Term v a -> a
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term v a
s)
      (Seq (Term v a) -> Seq (Term v a)
forall {a}. Seq (Term v a) -> Seq (Term v a)
normalize Seq (Term v a)
seqs)
    where

  Term v a
_ -> String -> Term v a
forall a. HasCallStack => String -> a
error (String -> Term v a) -> String -> Term v a
forall a b. (a -> b) -> a -> b
$ String
"unexpected doc structure: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term v a -> String
forall a. Show a => a -> String
show Term v a
tm
  where
    normalize :: Seq (Term v a) -> Seq (Term v a)
normalize =
      [Term v a] -> Seq (Term v a)
forall a. [a] -> Seq a
Sequence.fromList
        ([Term v a] -> Seq (Term v a))
-> (Seq (Term v a) -> [Term v a])
-> Seq (Term v a)
-> Seq (Term v a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((Term v a, UnbreakCase, Bool) -> Term v a)
-> [(Term v a, UnbreakCase, Bool)] -> [Term v a]
forall a b. (a -> b) -> [a] -> [b]
map (Term v a, UnbreakCase, Bool) -> Term v a
forall a b c. (a, b, c) -> a
TupleE.fst3)
        ([(Term v a, UnbreakCase, Bool)] -> [Term v a])
-> (Seq (Term v a) -> [(Term v a, UnbreakCase, Bool)])
-> Seq (Term v a)
-> [Term v a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
-> [(Term v a, UnbreakCase, Bool)]
-> [(Term v a, UnbreakCase, Bool)]
forall a. Show a => String -> a -> a
tracing String
"after unbreakParas")
        ([(Term v a, UnbreakCase, Bool)]
 -> [(Term v a, UnbreakCase, Bool)])
-> (Seq (Term v a) -> [(Term v a, UnbreakCase, Bool)])
-> Seq (Term v a)
-> [(Term v a, UnbreakCase, Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Term v a, UnbreakCase, Bool)] -> [(Term v a, UnbreakCase, Bool)]
forall v a.
(Show v, Ord v) =>
[(Term v a, UnbreakCase, Bool)] -> [(Term v a, UnbreakCase, Bool)]
unbreakParas
        ([(Term v a, UnbreakCase, Bool)]
 -> [(Term v a, UnbreakCase, Bool)])
-> (Seq (Term v a) -> [(Term v a, UnbreakCase, Bool)])
-> Seq (Term v a)
-> [(Term v a, UnbreakCase, Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
-> [(Term v a, UnbreakCase, Bool)]
-> [(Term v a, UnbreakCase, Bool)]
forall a. Show a => String -> a -> a
tracing String
"after full preprocess")
        ([(Term v a, UnbreakCase, Bool)]
 -> [(Term v a, UnbreakCase, Bool)])
-> (Seq (Term v a) -> [(Term v a, UnbreakCase, Bool)])
-> Seq (Term v a)
-> [(Term v a, UnbreakCase, Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Term v a, UnbreakCase)] -> [(Term v a, UnbreakCase, Bool)]
forall {v} {a} {b}.
Show v =>
[(Term v a, b)] -> [(Term v a, UnbreakCase, Bool)]
preProcess
        ([(Term v a, UnbreakCase)] -> [(Term v a, UnbreakCase, Bool)])
-> (Seq (Term v a) -> [(Term v a, UnbreakCase)])
-> Seq (Term v a)
-> [(Term v a, UnbreakCase, Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [(Term v a, UnbreakCase)] -> [(Term v a, UnbreakCase)]
forall a. Show a => String -> a -> a
tracing String
"after unindent")
        ([(Term v a, UnbreakCase)] -> [(Term v a, UnbreakCase)])
-> (Seq (Term v a) -> [(Term v a, UnbreakCase)])
-> Seq (Term v a)
-> [(Term v a, UnbreakCase)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Term v a, UnbreakCase)] -> [(Term v a, UnbreakCase)]
forall v a.
Ord v =>
[(Term v a, UnbreakCase)] -> [(Term v a, UnbreakCase)]
unIndent
        ([(Term v a, UnbreakCase)] -> [(Term v a, UnbreakCase)])
-> (Seq (Term v a) -> [(Term v a, UnbreakCase)])
-> Seq (Term v a)
-> [(Term v a, UnbreakCase)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [(Term v a, UnbreakCase)] -> [(Term v a, UnbreakCase)]
forall a. Show a => String -> a -> a
tracing String
"initial parse")
        ([(Term v a, UnbreakCase)] -> [(Term v a, UnbreakCase)])
-> (Seq (Term v a) -> [(Term v a, UnbreakCase)])
-> Seq (Term v a)
-> [(Term v a, UnbreakCase)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq (Term v a) -> [(Term v a, UnbreakCase)]
forall {v} {a}.
Show v =>
Seq (Term v a) -> [(Term v a, UnbreakCase)]
miniPreProcess
    preProcess :: [(Term v a, b)] -> [(Term v a, UnbreakCase, Bool)]
preProcess [(Term v a, b)]
xs =
      [Term v a]
-> [UnbreakCase] -> [Bool] -> [(Term v a, UnbreakCase, Bool)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3
        [Term v a]
seqs
        (Seq (Term v a) -> [UnbreakCase]
forall v a. Show v => Seq (Term v a) -> [UnbreakCase]
lineStarteds (Seq (Term v a) -> [UnbreakCase])
-> Seq (Term v a) -> [UnbreakCase]
forall a b. (a -> b) -> a -> b
$ [Term v a] -> Seq (Term v a)
forall a. [a] -> Seq a
Sequence.fromList [Term v a]
seqs)
        (Seq (Term v a) -> [Bool]
forall {v} {a}. Seq (Term v a) -> [Bool]
followingLines (Seq (Term v a) -> [Bool]) -> Seq (Term v a) -> [Bool]
forall a b. (a -> b) -> a -> b
$ [Term v a] -> Seq (Term v a)
forall a. [a] -> Seq a
Sequence.fromList [Term v a]
seqs)
      where
        seqs :: [Term v a]
seqs = ((Term v a, b) -> Term v a) -> [(Term v a, b)] -> [Term v a]
forall a b. (a -> b) -> [a] -> [b]
map (Term v a, b) -> Term v a
forall a b. (a, b) -> a
fst [(Term v a, b)]
xs
    miniPreProcess :: Seq (Term v a) -> [(Term v a, UnbreakCase)]
miniPreProcess Seq (Term v a)
seqs = [Term v a] -> [UnbreakCase] -> [(Term v a, UnbreakCase)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Seq (Term v a) -> [Term v a]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq (Term v a)
seqs) (Seq (Term v a) -> [UnbreakCase]
forall v a. Show v => Seq (Term v a) -> [UnbreakCase]
lineStarteds Seq (Term v a)
seqs)
    unIndent ::
      (Ord v) =>
      [(Term v a, UnbreakCase)] ->
      [(Term v a, UnbreakCase)]
    unIndent :: forall v a.
Ord v =>
[(Term v a, UnbreakCase)] -> [(Term v a, UnbreakCase)]
unIndent [(Term v a, UnbreakCase)]
tms = ((Term v a, UnbreakCase) -> (Term v a, UnbreakCase))
-> [(Term v a, UnbreakCase)] -> [(Term v a, UnbreakCase)]
forall a b. (a -> b) -> [a] -> [b]
map (Term v a, UnbreakCase) -> (Term v a, UnbreakCase)
forall {v} {a}.
Ord v =>
(Term v a, UnbreakCase) -> (Term v a, UnbreakCase)
go [(Term v a, UnbreakCase)]
tms
      where
        go :: (Term v a, UnbreakCase) -> (Term v a, UnbreakCase)
go (Term v a
b, UnbreakCase
previous) =
          (((Text -> Text) -> Term v a -> Term v a
forall v a. Ord v => (Text -> Text) -> Term v a -> Term v a
mapBlob ((Text -> Text) -> Term v a -> Term v a)
-> (Text -> Text) -> Term v a -> Term v a
forall a b. (a -> b) -> a -> b
$ (Bool -> Int -> Text -> Text
reduceIndent Bool
includeFirst Int
minIndent)) Term v a
b, UnbreakCase
previous)
          where
            -- Since previous was calculated before unindenting, it will often be wrongly
            -- StartsIndented instead of StartsUnindented - but that's OK just for the test
            -- below.  And we'll recalculate it later in preProcess.
            includeFirst :: Bool
includeFirst = UnbreakCase
previous UnbreakCase -> UnbreakCase -> Bool
forall a. Eq a => a -> a -> Bool
== UnbreakCase
LineEnds
        concatenatedBlobs :: Text
        concatenatedBlobs :: Text
concatenatedBlobs = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> [Text]
forall a. [a] -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (((Term v a, UnbreakCase) -> Text)
-> [(Term v a, UnbreakCase)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Term v a -> Text
forall {typeVar} {typeAnn} {patternAnn} {v} {a}.
Term (F typeVar typeAnn patternAnn) v a -> Text
getBlob (Term v a -> Text)
-> ((Term v a, UnbreakCase) -> Term v a)
-> (Term v a, UnbreakCase)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Term v a, UnbreakCase) -> Term v a
forall a b. (a, b) -> a
fst) [(Term v a, UnbreakCase)]
tms))
        getBlob :: Term (F typeVar typeAnn patternAnn) v a -> Text
getBlob (DD.DocBlob Text
txt) = Text
txt
        getBlob Term (F typeVar typeAnn patternAnn) v a
_ = Text
"."
        -- Note we exclude the first line when calculating the minimum indent - the lexer
        -- already stripped leading spaces from it, and anyway it would have been sharing
        -- its line with the [: and maybe other stuff.
        nonInitialNonEmptyLines :: [Text]
nonInitialNonEmptyLines =
          (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Text.null) ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$
            (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
Text.stripEnd ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$
              Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop Int
1 ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$
                Text -> [Text]
Text.lines
                  Text
concatenatedBlobs
        minIndent :: Int
minIndent =
          [Int] -> Int
forall {t :: * -> *} {a}. (Foldable t, Num a, Ord a) => t a -> a
minimumOrZero ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$
            (Text -> Int) -> [Text] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map
              (Text -> Int
Text.length (Text -> Int) -> (Text -> Text) -> Text -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Char -> Bool) -> Text -> Text
Text.takeWhile Char -> Bool
Char.isSpace))
              [Text]
nonInitialNonEmptyLines
        minimumOrZero :: t a -> a
minimumOrZero t a
xs = if t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
xs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then a
0 else t a -> a
forall a. Ord a => t a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum t a
xs
        reduceIndent :: Bool -> Int -> Text -> Text
        reduceIndent :: Bool -> Int -> Text -> Text
reduceIndent Bool
includeFirst Int
n Text
t =
          Text -> Text
fixup (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$
            [Text] -> Text
Text.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
              (Text -> Text) -> (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> (a -> b) -> [a] -> [b]
mapExceptFirst Text -> Text
reduceLineIndent Text -> Text
onFirst ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$
                Text -> [Text]
Text.lines Text
t
          where
            onFirst :: Text -> Text
onFirst = if Bool
includeFirst then Text -> Text
reduceLineIndent else Text -> Text
forall a. a -> a
id
            reduceLineIndent :: Text -> Text
reduceLineIndent Text
l = Text
result
              where
                currentIndent :: Int
currentIndent = Text -> Int
Text.length (Text -> Int) -> Text -> Int
forall a b. (a -> b) -> a -> b
$ ((Char -> Bool) -> Text -> Text
Text.takeWhile Char -> Bool
Char.isSpace) Text
l
                remainder :: Text
remainder = ((Char -> Bool) -> Text -> Text
Text.dropWhile Char -> Bool
Char.isSpace) Text
l
                newIndent :: Int
newIndent = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int
0, Int
currentIndent Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n]
                result :: Text
result = Int -> Text -> Text
Text.replicate Int
newIndent Text
" " Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text
remainder
            -- unlines . lines adds a trailing newline if one was not present: undo that.
            fixup :: Text -> Text
fixup = if Int -> Text -> Text
Text.takeEnd Int
1 Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"\n" then Text -> Text
forall a. a -> a
id else Int -> Text -> Text
Text.dropEnd Int
1
    -- Remove newlines between any sequence of non-empty zero-indent lines.
    -- This is made more complicated by Doc elements (e.g. links) which break up a
    -- blob but don't break a line of output text**.  We sometimes need to refer back to the
    -- previous blob to see whether a newline is between two zero-indented lines.
    -- For example...
    -- "This link to @foo makes it harder to see\n
    --  that the newline should be removed."
    -- Whether an element does this (breaks a blob but not a line of output text) really
    -- depends on some things we don't know here: does an @[include] target doc occupy
    -- just one line or several; whether this doc is going to be viewed or displayed.
    -- So we'll get it wrong sometimes.  The impact of this is that we may sometimes
    -- misjudge whether a newline is separating two non-indented lines, and should therefore
    -- be removed.
    unbreakParas ::
      (Show v, Ord v) =>
      [(Term v a, UnbreakCase, Bool)] ->
      [(Term v a, UnbreakCase, Bool)]
    unbreakParas :: forall v a.
(Show v, Ord v) =>
[(Term v a, UnbreakCase, Bool)] -> [(Term v a, UnbreakCase, Bool)]
unbreakParas = ((Term v a, UnbreakCase, Bool) -> (Term v a, UnbreakCase, Bool))
-> [(Term v a, UnbreakCase, Bool)]
-> [(Term v a, UnbreakCase, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (Term v a, UnbreakCase, Bool) -> (Term v a, UnbreakCase, Bool)
forall {v} {a}.
Ord v =>
(Term v a, UnbreakCase, Bool) -> (Term v a, UnbreakCase, Bool)
go
      where
        -- 'candidate' means 'candidate to be joined with an adjacent line as part of a
        -- paragraph'.
        go :: (Term v a, UnbreakCase, Bool) -> (Term v a, UnbreakCase, Bool)
go (Term v a
b, UnbreakCase
previous, Bool
nextIsCandidate) =
          ((Text -> Text) -> Term v a -> Term v a
forall v a. Ord v => (Text -> Text) -> Term v a -> Term v a
mapBlob Text -> Text
go Term v a
b, UnbreakCase
previous, Bool
nextIsCandidate)
          where
            go :: Text -> Text
go Text
txt = if Text -> Bool
Text.null Text
txt then Text
txt else Text -> Text
tr Text
result'
              where
                tr :: Text -> Text
tr =
                  (Text -> Text) -> (Any -> Any) -> Text -> Text
forall a b. a -> b -> a
const Text -> Text
forall a. a -> a
id ((Any -> Any) -> Text -> Text) -> (Any -> Any) -> Text -> Text
forall a b. (a -> b) -> a -> b
$
                    String -> Any -> Any
forall a. String -> a -> a
trace (String -> Any -> Any) -> String -> Any -> Any
forall a b. (a -> b) -> a -> b
$
                      String
"\nprocessElement on blob "
                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Text -> String
forall a. Show a => a -> String
show Text
txt)
                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", result' = "
                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Text -> String
forall a. Show a => a -> String
show Text
result')
                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", lines: "
                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ ([Text] -> String
forall a. Show a => a -> String
show [Text]
ls)
                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", candidates = "
                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ ([Bool] -> String
forall a. Show a => a -> String
show [Bool]
candidates)
                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", previous = "
                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ (UnbreakCase -> String
forall a. Show a => a -> String
show UnbreakCase
previous)
                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", firstIsCandidate = "
                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Bool -> String
forall a. Show a => a -> String
show Bool
firstIsCandidate)
                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n\n"
                -- remove trailing whitespace
                -- ls is non-empty thanks to the Text.null check above
                -- Don't cut the last line's trailing whitespace - there's an assumption here
                -- that it's followed by something which will put more text on the same line.
                ls :: [Text]
ls = (Text -> Text) -> (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> (a -> b) -> [a] -> [b]
mapExceptLast Text -> Text
Text.stripEnd Text -> Text
forall a. a -> a
id ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
Text.lines Text
txt
                -- Work out which lines are candidates to be joined as part of a paragraph, i.e.
                -- are not indented.
                candidate :: Text -> Bool
candidate Text
l = case Text -> Maybe (Char, Text)
Text.uncons Text
l of
                  Just (Char
initial, Text
_) -> Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
Char.isSpace (Char -> Bool) -> Char -> Bool
forall a b. (a -> b) -> a -> b
$ Char
initial
                  Maybe (Char, Text)
Nothing -> Bool
False -- empty line
                  -- The segment of this blob that runs up to the first newline may not itself
                  -- be the start of a line of the doc - for example if it's preceded by a link.
                  -- So work out whether the line of which it is a part is a candidate.
                firstIsCandidate :: Bool
firstIsCandidate = case UnbreakCase
previous of
                  UnbreakCase
LineEnds -> Text -> Bool
candidate ([Text] -> Text
forall a. HasCallStack => [a] -> a
head [Text]
ls)
                  UnbreakCase
StartsIndented -> Bool
False
                  UnbreakCase
StartsUnindented -> Bool
True
                candidates :: [Bool]
candidates = Bool
firstIsCandidate Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: ([Bool] -> [Bool]
forall a. HasCallStack => [a] -> [a]
tail ((Text -> Bool) -> [Text] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Bool
candidate [Text]
ls))
                result :: Text
result = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ ((Text, Bool) -> (Text, Bool) -> Text)
-> ((Text, Bool) -> Text) -> [(Text, Bool)] -> [Text]
forall a b. (a -> a -> b) -> (a -> b) -> [a] -> [b]
intercalateMapWith (Text, Bool) -> (Text, Bool) -> Text
forall {a} {a} {a}. IsString a => (a, Bool) -> (a, Bool) -> a
sep (Text, Bool) -> Text
forall a b. (a, b) -> a
fst ([Text] -> [Bool] -> [(Text, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
ls [Bool]
candidates)
                sep :: (a, Bool) -> (a, Bool) -> a
sep (a
_, Bool
candidate1) (a
_, Bool
candidate2) =
                  if Bool
candidate1 Bool -> Bool -> Bool
&& Bool
candidate2 then a
" " else a
"\n"
                -- Text.lines forgets whether there was a trailing newline.
                -- If there was one, then either add it back or convert it to a space.
                result' :: Text
result' =
                  if (Int -> Text -> Text
Text.takeEnd Int
1 Text
txt) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"\n"
                    then
                      if ([Bool] -> Bool
forall a. HasCallStack => [a] -> a
last [Bool]
candidates) Bool -> Bool -> Bool
&& Bool
nextIsCandidate
                        then Text
result Text -> Text -> Text
`Text.append` Text
" "
                        else Text
result Text -> Text -> Text
`Text.append` Text
"\n"
                    else Text
result
    -- A list whose entries match those of tms.  `Nothing` is used for elements
    -- which just continue a line, and so need to be ignored when looking back
    -- for how the last line started.  Otherwise describes whether the last
    -- line of this entry is indented (or maybe terminated by a newline.)
    -- A value of `Nothing` protects ensuing text from having its leading
    -- whitespace removed by `unindent`.
    -- Note that some elements render over multiple lines when displayed.
    -- See test2 in transcript doc-formatting.md for an example of how
    -- this looks when there is whitespace immediately following @[source]
    -- or @[evaluate].
    lastLines :: (Show v) => Sequence.Seq (Term v a) -> [Maybe UnbreakCase]
    lastLines :: forall v a. Show v => Seq (Term v a) -> [Maybe UnbreakCase]
lastLines Seq (Term v a)
tms = (((Term v a -> Maybe UnbreakCase)
 -> [Term v a] -> [Maybe UnbreakCase])
-> [Term v a]
-> (Term v a -> Maybe UnbreakCase)
-> [Maybe UnbreakCase]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Term v a -> Maybe UnbreakCase)
-> [Term v a] -> [Maybe UnbreakCase]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (Seq (Term v a) -> [Term v a]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq (Term v a)
tms) ((Term v a -> Maybe UnbreakCase) -> [Maybe UnbreakCase])
-> (Term v a -> Maybe UnbreakCase) -> [Maybe UnbreakCase]
forall a b. (a -> b) -> a -> b
$ \case
      DD.DocBlob Text
txt -> Text -> Maybe UnbreakCase
unbreakCase Text
txt
      DD.DocLink Term v a
_ -> Maybe UnbreakCase
forall a. Maybe a
Nothing
      DD.DocSource Term v a
_ -> Maybe UnbreakCase
forall a. Maybe a
Nothing
      DD.DocSignature Term v a
_ -> Maybe UnbreakCase
forall a. Maybe a
Nothing
      DD.DocEvaluate Term v a
_ -> Maybe UnbreakCase
forall a. Maybe a
Nothing
      Term.Var' v
_ -> Maybe UnbreakCase
forall a. Maybe a
Nothing -- @[include]
      e :: Term v a
e@Term v a
_ -> String -> Maybe UnbreakCase
forall a. HasCallStack => String -> a
error (String
"unexpected doc element: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term v a -> String
forall a. Show a => a -> String
show Term v a
e)
    -- Work out whether the last line of this blob is indented (or maybe
    -- terminated by a newline.)
    unbreakCase :: Text -> Maybe UnbreakCase
    unbreakCase :: Text -> Maybe UnbreakCase
unbreakCase Text
txt =
      let (Text
startAndNewline, Text
afterNewline) = HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
Text.breakOnEnd Text
"\n" Text
txt
       in if Text -> Bool
Text.null Text
startAndNewline
            then Maybe UnbreakCase
forall a. Maybe a
Nothing
            else
              if Text -> Bool
Text.null Text
afterNewline
                then UnbreakCase -> Maybe UnbreakCase
forall a. a -> Maybe a
Just UnbreakCase
LineEnds
                else
                  if Char -> Bool
Char.isSpace (HasCallStack => Text -> Char
Text -> Char
Text.head Text
afterNewline)
                    then UnbreakCase -> Maybe UnbreakCase
forall a. a -> Maybe a
Just UnbreakCase
StartsIndented
                    else UnbreakCase -> Maybe UnbreakCase
forall a. a -> Maybe a
Just UnbreakCase
StartsUnindented
    -- A list whose entries match those of tms.  Describes how the current
    -- line started (the line including the start of this entry) - or LineEnds
    -- if this entry is starting a line itself.
    -- Calculated as the UnbreakCase of the previous entry that included a newline.
    -- Really there's a function of type (a -> Bool) -> a -> [a] -> [a] in here
    -- fighting to break free - overwriting elements that are 'shadowed' by
    -- a preceding element for which the predicate is true, with a copy of
    -- that element.
    lineStarteds :: (Show v) => Sequence.Seq (Term v a) -> [UnbreakCase]
    lineStarteds :: forall v a. Show v => Seq (Term v a) -> [UnbreakCase]
lineStarteds Seq (Term v a)
tms = [UnbreakCase] -> [UnbreakCase]
forall a. a -> a
tr ([UnbreakCase] -> [UnbreakCase]) -> [UnbreakCase] -> [UnbreakCase]
forall a b. (a -> b) -> a -> b
$ UnbreakCase -> UnbreakCase -> [UnbreakCase] -> [UnbreakCase]
forall a. Eq a => a -> a -> [a] -> [a]
quenchRuns UnbreakCase
LineEnds UnbreakCase
StartsUnindented ([UnbreakCase] -> [UnbreakCase]) -> [UnbreakCase] -> [UnbreakCase]
forall a b. (a -> b) -> a -> b
$ [UnbreakCase]
xs''
      where
        tr :: a -> a
tr =
          (a -> a) -> (Any -> Any) -> a -> a
forall a b. a -> b -> a
const a -> a
forall a. a -> a
id ((Any -> Any) -> a -> a) -> (Any -> Any) -> a -> a
forall a b. (a -> b) -> a -> b
$
            String -> Any -> Any
forall a. String -> a -> a
trace (String -> Any -> Any) -> String -> Any -> Any
forall a b. (a -> b) -> a -> b
$
              String
"lineStarteds: xs = "
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ ([Maybe UnbreakCase] -> String
forall a. Show a => a -> String
show [Maybe UnbreakCase]
xs)
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", xss = "
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ ([[Maybe UnbreakCase]] -> String
forall a. Show a => a -> String
show [[Maybe UnbreakCase]]
xss)
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", xs' = "
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ ([UnbreakCase] -> String
forall a. Show a => a -> String
show [UnbreakCase]
xs')
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", xs'' = "
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ ([UnbreakCase] -> String
forall a. Show a => a -> String
show [UnbreakCase]
xs'')
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n\n"
        -- Make sure there's a Just at the start of the list so we always find
        -- one when searching back.
        -- Example: xs = [J1,N2,J3]
        xs :: [Maybe UnbreakCase]
        xs :: [Maybe UnbreakCase]
xs = UnbreakCase -> Maybe UnbreakCase
forall a. a -> Maybe a
Just UnbreakCase
LineEnds Maybe UnbreakCase -> [Maybe UnbreakCase] -> [Maybe UnbreakCase]
forall a. a -> [a] -> [a]
: (Seq (Term v a) -> [Maybe UnbreakCase]
forall v a. Show v => Seq (Term v a) -> [Maybe UnbreakCase]
lastLines Seq (Term v a)
tms)
        -- Example: xss = [[J1],[J1,N2],[J1,N2,J3]]
        xss :: [[Maybe UnbreakCase]]
        xss :: [[Maybe UnbreakCase]]
xss = Int -> [[Maybe UnbreakCase]] -> [[Maybe UnbreakCase]]
forall a. Int -> [a] -> [a]
drop Int
1 ([[Maybe UnbreakCase]] -> [[Maybe UnbreakCase]])
-> [[Maybe UnbreakCase]] -> [[Maybe UnbreakCase]]
forall a b. (a -> b) -> a -> b
$ [Maybe UnbreakCase] -> [[Maybe UnbreakCase]]
forall a. [a] -> [[a]]
List.inits [Maybe UnbreakCase]
xs
        -- Example: after each step of the map...
        --            [[J1],[N2,J1],[J3,N2,J1]]   -- after reverse
        --            [Just J1, Just J1, Just J3] -- after find
        --            ...
        --   result = [1,1,3]
        xs' :: [UnbreakCase]
xs' =
          ([Maybe UnbreakCase] -> UnbreakCase)
-> [[Maybe UnbreakCase]] -> [UnbreakCase]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe UnbreakCase -> UnbreakCase
forall a. HasCallStack => Maybe a -> a
Maybe.fromJust (Maybe UnbreakCase -> UnbreakCase)
-> ([Maybe UnbreakCase] -> Maybe UnbreakCase)
-> [Maybe UnbreakCase]
-> UnbreakCase
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Maybe UnbreakCase) -> Maybe UnbreakCase
forall a. HasCallStack => Maybe a -> a
Maybe.fromJust (Maybe (Maybe UnbreakCase) -> Maybe UnbreakCase)
-> ([Maybe UnbreakCase] -> Maybe (Maybe UnbreakCase))
-> [Maybe UnbreakCase]
-> Maybe UnbreakCase
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe UnbreakCase -> Bool)
-> [Maybe UnbreakCase] -> Maybe (Maybe UnbreakCase)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find Maybe UnbreakCase -> Bool
forall a. Maybe a -> Bool
isJust) ([Maybe UnbreakCase] -> Maybe (Maybe UnbreakCase))
-> ([Maybe UnbreakCase] -> [Maybe UnbreakCase])
-> [Maybe UnbreakCase]
-> Maybe (Maybe UnbreakCase)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe UnbreakCase] -> [Maybe UnbreakCase]
forall a. [a] -> [a]
reverse) [[Maybe UnbreakCase]]
xss
        xs'' :: [UnbreakCase]
xs'' = Int -> [UnbreakCase] -> [UnbreakCase]
forall a. Int -> [a] -> [a]
List.Extra.dropEnd Int
1 [UnbreakCase]
xs'
    -- For each element, can it be a line-continuation of a preceding blob?
    continuesLine :: Sequence.Seq (Term v a) -> [Bool]
    continuesLine :: forall {v} {a}. Seq (Term v a) -> [Bool]
continuesLine Seq (Term v a)
tms = (((Term v a -> Bool) -> [Term v a] -> [Bool])
-> [Term v a] -> (Term v a -> Bool) -> [Bool]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Term v a -> Bool) -> [Term v a] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (Seq (Term v a) -> [Term v a]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq (Term v a)
tms) \case
      DD.DocBlob Text
_ -> Bool
False -- value doesn't matter - you don't get adjacent blobs
      DD.DocLink Term v a
_ -> Bool
True
      DD.DocSource Term v a
_ -> Bool
False
      DD.DocSignature Term v a
_ -> Bool
False
      DD.DocEvaluate Term v a
_ -> Bool
False
      Term.Var' v
_ -> Bool
False -- @[include]
      Term v a
_ -> String -> Bool
forall a. HasCallStack => String -> a
error (String
"unexpected doc element" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term v a -> String
forall a. Show a => a -> String
show Term v a
tm)
    -- A list whose entries match those of tms.  Can the subsequent entry by a
    -- line continuation of this one?
    followingLines :: Seq (Term v a) -> [Bool]
followingLines Seq (Term v a)
tms = Int -> [Bool] -> [Bool]
forall a. Int -> [a] -> [a]
drop Int
1 ((Seq (Term v a) -> [Bool]
forall {v} {a}. Seq (Term v a) -> [Bool]
continuesLine Seq (Term v a)
tms) [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ [Bool
False])
    mapExceptFirst :: (a -> b) -> (a -> b) -> [a] -> [b]
    mapExceptFirst :: forall a b. (a -> b) -> (a -> b) -> [a] -> [b]
mapExceptFirst a -> b
fRest a -> b
fFirst = \case
      [] -> []
      a
x : [a]
rest -> (a -> b
fFirst a
x) b -> [b] -> [b]
forall a. a -> [a] -> [a]
: ((a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map a -> b
fRest [a]
rest)
    mapExceptLast :: (a -> a) -> (a -> a) -> [a] -> [a]
mapExceptLast a -> a
fRest a -> a
fLast = [a] -> [a]
forall a. [a] -> [a]
reverse ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a -> a) -> (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> (a -> b) -> [a] -> [b]
mapExceptFirst a -> a
fRest a -> a
fLast) ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
forall a. [a] -> [a]
reverse
    tracing :: (Show a) => [Char] -> a -> a
    tracing :: forall a. Show a => String -> a -> a
tracing String
when a
x =
      ((a -> a) -> (Any -> Any) -> a -> a
forall a b. a -> b -> a
const a -> a
forall a. a -> a
id ((Any -> Any) -> a -> a) -> (Any -> Any) -> a -> a
forall a b. (a -> b) -> a -> b
$ String -> Any -> Any
forall a. String -> a -> a
trace (String
"at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
when String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (a -> String
forall a. Show a => a -> String
show a
x) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n")) a
x
    blob :: a -> a -> a -> Text -> Term2 vt at ap v a
blob a
aa a
ac a
at Text
txt =
      a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app a
aa (a -> ConstructorReference -> Term2 vt at ap v a
forall v a vt at ap.
Ord v =>
a -> ConstructorReference -> Term2 vt at ap v a
Term.constructor a
ac (TypeReference -> ConstructorId -> ConstructorReference
forall r. r -> ConstructorId -> GConstructorReference r
ConstructorReference TypeReference
DD.docRef ConstructorId
DD.docBlobId)) (a -> Text -> Term2 vt at ap v a
forall v a vt at ap. Ord v => a -> Text -> Term2 vt at ap v a
Term.text a
at Text
txt)
    join :: a -> a -> a -> Seq (Term2 vt at ap v a) -> Term2 vt at ap v a
join a
aa a
ac a
as Seq (Term2 vt at ap v a)
segs =
      a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app a
aa (a -> ConstructorReference -> Term2 vt at ap v a
forall v a vt at ap.
Ord v =>
a -> ConstructorReference -> Term2 vt at ap v a
Term.constructor a
ac (TypeReference -> ConstructorId -> ConstructorReference
forall r. r -> ConstructorId -> GConstructorReference r
ConstructorReference TypeReference
DD.docRef ConstructorId
DD.docJoinId)) (a -> Seq (Term2 vt at ap v a) -> Term2 vt at ap v a
forall v a vt at ap.
Ord v =>
a -> Seq (Term2 vt at ap v a) -> Term2 vt at ap v a
Term.list' a
as Seq (Term2 vt at ap v a)
segs)
    mapBlob :: (Ord v) => (Text -> Text) -> Term v a -> Term v a
    -- this pattern is just `DD.DocBlob txt` but exploded to capture the annotations as well
    mapBlob :: forall v a. Ord v => (Text -> Text) -> Term v a -> Term v a
mapBlob Text -> Text
f (aa :: Term v a
aa@(Term.App' ac :: Term v a
ac@(Term.Constructor' (ConstructorReference TypeReference
DD.DocRef ConstructorId
DD.DocBlobId)) at :: Term v a
at@(Term.Text' Text
txt))) =
      a -> a -> a -> Text -> Term v a
forall {v} {a} {vt} {at} {ap}.
Ord v =>
a -> a -> a -> Text -> Term2 vt at ap v a
blob (Term v a -> a
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term v a
aa) (Term v a -> a
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term v a
ac) (Term v a -> a
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term v a
at) (Text -> Text
f Text
txt)
    mapBlob Text -> Text
_ Term v a
t = Term v a
t

delayQuote :: (Monad m, Var v) => TermP v m
delayQuote :: forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
delayQuote = String
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
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 String
"quote" do
  Token String
start <- String -> P v m (Token String)
forall v (m :: * -> *). Ord v => String -> P v m (Token String)
reserved String
"'"
  Term v Ann
e <- ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
termLeaf
  pure $ Ann -> Ann -> Term v Ann -> Term v Ann
forall v a. Var v => a -> a -> Term v a -> Term v a
DD.delayTerm (Token String -> Ann
forall a. Annotated a => a -> Ann
ann Token String
start Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
<> Term v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term v Ann
e) (Token String -> Ann
forall a. Annotated a => a -> Ann
ann Token String
start) Term v Ann
e

delayBlock :: (Monad m, Var v) => P v m (Ann {- Ann spanning the whole block -}, Term v Ann)
delayBlock :: forall (m :: * -> *) v. (Monad m, Var v) => P v m (Ann, Term v Ann)
delayBlock = String
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Ann, Term v Ann)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Ann, Term v Ann)
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 String
"do" do
  (Ann
spanAnn, Term v Ann
b) <- String
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Ann, Term v Ann)
forall (m :: * -> *) v.
(Monad m, Var v) =>
String -> P v m (Ann, Term v Ann)
layoutBlock String
"do"
  let argSpan :: Ann
argSpan = (Term v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term v Ann
b {- would be nice to use the annotation for 'do' here, but it's not terribly important -})
  (Ann, Term v Ann)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Ann, Term v Ann)
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Ann, Term v Ann)
 -> ParsecT
      (Error v) Input (ReaderT (ParsingEnv m) m) (Ann, Term v Ann))
-> (Ann, Term v Ann)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Ann, Term v Ann)
forall a b. (a -> b) -> a -> b
$ (Ann
spanAnn, Ann -> Ann -> Term v Ann -> Term v Ann
forall v a. Var v => a -> a -> Term v a -> Term v a
DD.delayTerm (Term v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term v Ann
b) Ann
argSpan Term v Ann
b)

bang :: (Monad m, Var v) => TermP v m
bang :: forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
bang = String
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
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 String
"bang" do
  Token String
start <- String -> P v m (Token String)
forall v (m :: * -> *). Ord v => String -> P v m (Token String)
reserved String
"!"
  Term v Ann
e <- ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
termLeaf
  pure $ Ann -> Ann -> Term v Ann -> Term v Ann
forall v a. Var v => a -> a -> Term v a -> Term v a
DD.forceTerm (Token String -> Ann
forall a. Annotated a => a -> Ann
ann Token String
start Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
<> Term v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term v Ann
e) (Token String -> Ann
forall a. Annotated a => a -> Ann
ann Token String
start) Term v Ann
e

force :: forall m v. (Monad m, Var v) => TermP v m
force :: forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
force = String
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
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 String
"force" (ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a b. (a -> b) -> a -> b
$ ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
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
  -- `forkAt pool() blah` parses as `forkAt (pool ()) blah`
  -- That is, empty parens immediately (no space) following a symbol
  -- is treated as high precedence function application of `Unit`
  Term v Ann
fn <- ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
hashQualifiedPrefixTerm
  Ann
tok <- Token () -> Ann
forall a. Annotated a => a -> Ann
ann (Token () -> Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token ())
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) Ann
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
"("
  Bool -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Pos -> Int
L.column (Ann -> Pos
Ann.start Ann
tok) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Pos -> Int
L.column (Ann -> Pos
Ann.end (Term v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term v Ann
fn)))
  Token ()
close <- ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token ())
forall v (m :: * -> *). Ord v => P v m (Token ())
closeBlock
  pure $ Ann -> Ann -> Term v Ann -> Term v Ann
forall v a. Var v => a -> a -> Term v a -> Term v a
DD.forceTerm (Term v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term v Ann
fn Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
<> Token () -> Ann
forall a. Annotated a => a -> Ann
ann Token ()
close) (Ann
tok Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
<> Token () -> Ann
forall a. Annotated a => a -> Ann
ann Token ()
close) Term v Ann
fn

seqOp :: (Ord v) => P v m Pattern.SeqOp
seqOp :: forall v (m :: * -> *). Ord v => P v m SeqOp
seqOp =
  SeqOp
Pattern.Snoc SeqOp
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token Lexeme)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) SeqOp
forall a b.
a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) b
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Lexeme
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token Lexeme)
forall v (m :: * -> *). Ord v => Lexeme -> P v m (Token Lexeme)
matchToken (HashQualified Name -> Lexeme
L.SymbolyId (Name -> HashQualified Name
forall n. n -> HashQualified n
HQ'.fromName (NameSegment -> Name
Name.fromSegment NameSegment
NameSegment.snocSegment)))
    ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) SeqOp
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) SeqOp
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) SeqOp
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
<|> SeqOp
Pattern.Cons SeqOp
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token Lexeme)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) SeqOp
forall a b.
a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) b
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Lexeme
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token Lexeme)
forall v (m :: * -> *). Ord v => Lexeme -> P v m (Token Lexeme)
matchToken (HashQualified Name -> Lexeme
L.SymbolyId (Name -> HashQualified Name
forall n. n -> HashQualified n
HQ'.fromName (NameSegment -> Name
Name.fromSegment NameSegment
NameSegment.consSegment)))
    ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) SeqOp
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) SeqOp
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) SeqOp
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
<|> SeqOp
Pattern.Concat SeqOp
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token Lexeme)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) SeqOp
forall a b.
a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) b
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Lexeme
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token Lexeme)
forall v (m :: * -> *). Ord v => Lexeme -> P v m (Token Lexeme)
matchToken (HashQualified Name -> Lexeme
L.SymbolyId (Name -> HashQualified Name
forall n. n -> HashQualified n
HQ'.fromName (NameSegment -> Name
Name.fromSegment NameSegment
NameSegment.concatSegment)))

term4 :: (Monad m, Var v) => TermP v m
term4 :: forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
term4 = [Term2 v Ann Ann v Ann] -> Term2 v Ann Ann v Ann
forall {v} {vt} {at} {ap}.
Ord v =>
[Term2 vt at ap v Ann] -> Term2 vt at ap v Ann
f ([Term2 v Ann Ann v Ann] -> Term2 v Ann Ann v Ann)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) [Term2 v Ann Ann v Ann]
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Term2 v Ann Ann v Ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT
  (Error v) Input (ReaderT (ParsingEnv m) m) (Term2 v Ann Ann v Ann)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) [Term2 v Ann Ann v Ann]
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]
some ParsecT
  (Error v) Input (ReaderT (ParsingEnv m) m) (Term2 v Ann Ann v Ann)
forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
termLeaf
  where
    f :: [Term2 vt at ap v Ann] -> Term2 vt at ap v Ann
f (Term2 vt at ap v Ann
func : [Term2 vt at ap v Ann]
args) = Term2 vt at ap v Ann
-> [(Ann, Term2 vt at ap v Ann)] -> Term2 vt at ap v Ann
forall v vt at ap a.
Ord v =>
Term2 vt at ap v a
-> [(a, Term2 vt at ap v a)] -> Term2 vt at ap v a
Term.apps Term2 vt at ap v Ann
func ((\Term2 vt at ap v Ann
a -> (Term2 vt at ap v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term2 vt at ap v Ann
func Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
<> Term2 vt at ap v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term2 vt at ap v Ann
a, Term2 vt at ap v Ann
a)) (Term2 vt at ap v Ann -> (Ann, Term2 vt at ap v Ann))
-> [Term2 vt at ap v Ann] -> [(Ann, Term2 vt at ap v Ann)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Term2 vt at ap v Ann]
args)
    f [] = String -> Term2 vt at ap v Ann
forall a. HasCallStack => String -> a
error String
"'some' shouldn't produce an empty list"

data InfixParse v
  = InfixOp (L.Token (HQ.HashQualified Name)) (Term v Ann) (InfixParse v) (InfixParse v)
  | InfixAnd (L.Token String) (InfixParse v) (InfixParse v)
  | InfixOr (L.Token String) (InfixParse v) (InfixParse v)
  | InfixOperand (Term v Ann)
  deriving (Int -> InfixParse v -> String -> String
[InfixParse v] -> String -> String
InfixParse v -> String
(Int -> InfixParse v -> String -> String)
-> (InfixParse v -> String)
-> ([InfixParse v] -> String -> String)
-> Show (InfixParse v)
forall v. Show v => Int -> InfixParse v -> String -> String
forall v. Show v => [InfixParse v] -> String -> String
forall v. Show v => InfixParse v -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: forall v. Show v => Int -> InfixParse v -> String -> String
showsPrec :: Int -> InfixParse v -> String -> String
$cshow :: forall v. Show v => InfixParse v -> String
show :: InfixParse v -> String
$cshowList :: forall v. Show v => [InfixParse v] -> String -> String
showList :: [InfixParse v] -> String -> String
Show, InfixParse v -> InfixParse v -> Bool
(InfixParse v -> InfixParse v -> Bool)
-> (InfixParse v -> InfixParse v -> Bool) -> Eq (InfixParse v)
forall v. Var v => InfixParse v -> InfixParse v -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall v. Var v => InfixParse v -> InfixParse v -> Bool
== :: InfixParse v -> InfixParse v -> Bool
$c/= :: forall v. Var v => InfixParse v -> InfixParse v -> Bool
/= :: InfixParse v -> InfixParse v -> Bool
Eq, Eq (InfixParse v)
Eq (InfixParse v) =>
(InfixParse v -> InfixParse v -> Ordering)
-> (InfixParse v -> InfixParse v -> Bool)
-> (InfixParse v -> InfixParse v -> Bool)
-> (InfixParse v -> InfixParse v -> Bool)
-> (InfixParse v -> InfixParse v -> Bool)
-> (InfixParse v -> InfixParse v -> InfixParse v)
-> (InfixParse v -> InfixParse v -> InfixParse v)
-> Ord (InfixParse v)
InfixParse v -> InfixParse v -> Bool
InfixParse v -> InfixParse v -> Ordering
InfixParse v -> InfixParse v -> InfixParse 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. Var v => Eq (InfixParse v)
forall v. Var v => InfixParse v -> InfixParse v -> Bool
forall v. Var v => InfixParse v -> InfixParse v -> Ordering
forall v. Var v => InfixParse v -> InfixParse v -> InfixParse v
$ccompare :: forall v. Var v => InfixParse v -> InfixParse v -> Ordering
compare :: InfixParse v -> InfixParse v -> Ordering
$c< :: forall v. Var v => InfixParse v -> InfixParse v -> Bool
< :: InfixParse v -> InfixParse v -> Bool
$c<= :: forall v. Var v => InfixParse v -> InfixParse v -> Bool
<= :: InfixParse v -> InfixParse v -> Bool
$c> :: forall v. Var v => InfixParse v -> InfixParse v -> Bool
> :: InfixParse v -> InfixParse v -> Bool
$c>= :: forall v. Var v => InfixParse v -> InfixParse v -> Bool
>= :: InfixParse v -> InfixParse v -> Bool
$cmax :: forall v. Var v => InfixParse v -> InfixParse v -> InfixParse v
max :: InfixParse v -> InfixParse v -> InfixParse v
$cmin :: forall v. Var v => InfixParse v -> InfixParse v -> InfixParse v
min :: InfixParse v -> InfixParse v -> InfixParse v
Ord)

-- e.g. term4 + term4 - term4
-- or term4 || term4 && term4
-- The algorithm works as follows:
-- 1. Parse the expression left-associated
-- 2. Starting at the leftmost operator subexpression, see if the next operator
--   has higher precedence. If so, rotate the expression to the right.
--   e.g. in `a + b * c`, we first parse `(a + b) * c` then rotate to `a + (b * c)`.
-- 3. Perform the algorithm on the right-hand side if necessary, as `b` might be
--   an infix expression with lower precedence than `*`.
-- 4. Proceed to the next operator to the right in the original expression and
--    repeat steps 2-3 until we reach the end.
infixAppOrBooleanOp :: forall m v. (Monad m, Var v) => TermP v m
infixAppOrBooleanOp :: forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
infixAppOrBooleanOp = do
  (InfixParse v
p, [InfixParse v -> InfixParse v]
ps) <- ParsecT
  (Error v)
  Input
  (ReaderT (ParsingEnv m) m)
  (InfixParse v, [InfixParse v -> InfixParse v])
prelimParse
  -- traceShowM ("orig" :: String, foldl' (flip ($)) p ps)
  let p' :: InfixParse v
p' = (InfixParse v, [InfixParse v -> InfixParse v]) -> InfixParse v
forall {t :: * -> *} {v}.
Foldable t =>
(InfixParse v, t (InfixParse v -> InfixParse v)) -> InfixParse v
reassociate (InfixParse v
p, [InfixParse v -> InfixParse v]
ps)
  -- traceShowM ("reassoc" :: String, p')
  Term v Ann -> TermP v m
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
return (InfixParse v -> Term v Ann
applyInfixOps InfixParse v
p')
  where
    -- To handle a mix of infix operators with and without precedence rules,
    -- we first parse the expression left-associated, then reassociate it
    -- according to the precedence rules.
    prelimParse :: ParsecT
  (Error v)
  Input
  (ReaderT (ParsingEnv m) m)
  (InfixParse v, [InfixParse v -> InfixParse v])
prelimParse =
      ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (InfixParse v)
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (InfixParse v -> InfixParse v -> InfixParse v)
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (InfixParse v, [InfixParse v -> InfixParse v])
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 (Term v Ann -> InfixParse v
forall v. Term v Ann -> InfixParse v
InfixOperand (Term v Ann -> InfixParse v)
-> TermP v m
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (InfixParse v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermP v m
forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
term4) ParsecT
  (Error v)
  Input
  (ReaderT (ParsingEnv m) m)
  (InfixParse v -> InfixParse v -> InfixParse v)
genericInfixApp
    genericInfixApp :: ParsecT
  (Error v)
  Input
  (ReaderT (ParsingEnv m) m)
  (InfixParse v -> InfixParse v -> InfixParse v)
genericInfixApp =
      (Token String -> InfixParse v -> InfixParse v -> InfixParse v
forall v.
Token String -> InfixParse v -> InfixParse v -> InfixParse v
InfixAnd (Token String -> InfixParse v -> InfixParse v -> InfixParse v)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token String)
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (InfixParse v -> InfixParse v -> InfixParse v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token String)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token String)
forall v a (m :: * -> *).
(Ord v, Show a) =>
String -> P v m a -> P v m a
label String
"and" (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)
  (InfixParse v -> InfixParse v -> InfixParse v)
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (InfixParse v -> InfixParse v -> InfixParse v)
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (InfixParse v -> InfixParse v -> InfixParse 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
<|> (Token String -> InfixParse v -> InfixParse v -> InfixParse v
forall v.
Token String -> InfixParse v -> InfixParse v -> InfixParse v
InfixOr (Token String -> InfixParse v -> InfixParse v -> InfixParse v)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token String)
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (InfixParse v -> InfixParse v -> InfixParse v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token String)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token String)
forall v a (m :: * -> *).
(Ord v, Show a) =>
String -> P v m a -> P v m a
label String
"or" (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)
  (InfixParse v -> InfixParse v -> InfixParse v)
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (InfixParse v -> InfixParse v -> InfixParse v)
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (InfixParse v -> InfixParse v -> InfixParse 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
<|> ((Token (HashQualified Name)
 -> Term v Ann -> InfixParse v -> InfixParse v -> InfixParse v)
-> (Token (HashQualified Name), Term v Ann)
-> InfixParse v
-> InfixParse v
-> InfixParse v
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Token (HashQualified Name)
-> Term v Ann -> InfixParse v -> InfixParse v -> InfixParse v
forall v.
Token (HashQualified Name)
-> Term v Ann -> InfixParse v -> InfixParse v -> InfixParse v
InfixOp ((Token (HashQualified Name), Term v Ann)
 -> InfixParse v -> InfixParse v -> InfixParse v)
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (Token (HashQualified Name), Term v Ann)
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (InfixParse v -> InfixParse v -> InfixParse v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT
  (Error v)
  Input
  (ReaderT (ParsingEnv m) m)
  (Token (HashQualified Name), Term v Ann)
parseInfix)
    shouldRotate :: Maybe a -> Maybe a -> Bool
shouldRotate Maybe a
child Maybe a
parent = case (Maybe a
child, Maybe a
parent) of
      (Just a
p1, Just a
p2) -> a
p1 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
p2
      (Maybe a, Maybe a)
_ -> Bool
False
    parseInfix :: ParsecT
  (Error v)
  Input
  (ReaderT (ParsingEnv m) m)
  (Token (HashQualified Name), Term v Ann)
parseInfix = String
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (Token (HashQualified Name), Term v Ann)
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (Token (HashQualified Name), Term v Ann)
forall v a (m :: * -> *).
(Ord v, Show a) =>
String -> P v m a -> P v m a
label String
"infixApp" do
      Token (HashQualified Name)
op <- P v m (Token (HashQualified Name))
forall v (m :: * -> *). Ord v => P v m (Token (HashQualified Name))
hqInfixId P v m (Token (HashQualified Name))
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Maybe (Token ()))
-> P v m (Token (HashQualified Name))
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 ())
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Maybe (Token ()))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token ())
forall v (m :: * -> *). Ord v => P v m (Token ())
semi
      Term v Ann
resolved <- Token (HashQualified Name) -> TermP v m
forall (m :: * -> *) v.
(Monad m, Var v) =>
Token (HashQualified Name) -> TermP v m
resolveHashQualified Token (HashQualified Name)
op
      pure (Token (HashQualified Name)
op, Term v Ann
resolved)
    reassociate :: (InfixParse v, t (InfixParse v -> InfixParse v)) -> InfixParse v
reassociate (InfixParse v
exp, t (InfixParse v -> InfixParse v)
ops) =
      (InfixParse v -> (InfixParse v -> InfixParse v) -> InfixParse v)
-> InfixParse v -> t (InfixParse v -> InfixParse v) -> InfixParse v
forall b a. (b -> a -> b) -> b -> t a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' InfixParse v -> (InfixParse v -> InfixParse v) -> InfixParse v
forall {t} {v}. t -> (t -> InfixParse v) -> InfixParse v
checkOp InfixParse v
exp t (InfixParse v -> InfixParse v)
ops
    checkOp :: t -> (t -> InfixParse v) -> InfixParse v
checkOp t
exp t -> InfixParse v
op = InfixParse v -> InfixParse v
forall {v}. InfixParse v -> InfixParse v
fixUp (t -> InfixParse v
op t
exp)
    fixUp :: InfixParse v -> InfixParse v
fixUp = \case
      InfixOp Token (HashQualified Name)
op Term v Ann
tm InfixParse v
lhs InfixParse v
rhs ->
        Text
-> (InfixParse v -> InfixParse v -> InfixParse v)
-> InfixParse v
-> InfixParse v
-> InfixParse v
rotate (Token (HashQualified Name) -> Text
unqualified Token (HashQualified Name)
op) (Token (HashQualified Name)
-> Term v Ann -> InfixParse v -> InfixParse v -> InfixParse v
forall v.
Token (HashQualified Name)
-> Term v Ann -> InfixParse v -> InfixParse v -> InfixParse v
InfixOp Token (HashQualified Name)
op Term v Ann
tm) InfixParse v
lhs InfixParse v
rhs
      InfixAnd Token String
op InfixParse v
lhs InfixParse v
rhs ->
        Text
-> (InfixParse v -> InfixParse v -> InfixParse v)
-> InfixParse v
-> InfixParse v
-> InfixParse v
rotate Text
"&&" (Token String -> InfixParse v -> InfixParse v -> InfixParse v
forall v.
Token String -> InfixParse v -> InfixParse v -> InfixParse v
InfixAnd Token String
op) InfixParse v
lhs InfixParse v
rhs
      InfixOr Token String
op InfixParse v
lhs InfixParse v
rhs ->
        Text
-> (InfixParse v -> InfixParse v -> InfixParse v)
-> InfixParse v
-> InfixParse v
-> InfixParse v
rotate Text
"||" (Token String -> InfixParse v -> InfixParse v -> InfixParse v
forall v.
Token String -> InfixParse v -> InfixParse v -> InfixParse v
InfixOr Token String
op) InfixParse v
lhs InfixParse v
rhs
      InfixParse v
x -> InfixParse v
x
    rotate :: Text
-> (InfixParse v -> InfixParse v -> InfixParse v)
-> InfixParse v
-> InfixParse v
-> InfixParse v
rotate Text
op InfixParse v -> InfixParse v -> InfixParse v
ctor InfixParse v
lhs InfixParse v
rhs =
      case InfixParse v
lhs of
        InfixOp Token (HashQualified Name)
lop Term v Ann
ltm InfixParse v
ll InfixParse v
lr
          | Maybe Precedence -> Maybe Precedence -> Bool
forall {a}. Ord a => Maybe a -> Maybe a -> Bool
shouldRotate (Text -> Maybe Precedence
operatorPrecedence (Token (HashQualified Name) -> Text
unqualified Token (HashQualified Name)
lop)) (Text -> Maybe Precedence
operatorPrecedence Text
op) ->
              Token (HashQualified Name)
-> Term v Ann -> InfixParse v -> InfixParse v -> InfixParse v
forall v.
Token (HashQualified Name)
-> Term v Ann -> InfixParse v -> InfixParse v -> InfixParse v
InfixOp Token (HashQualified Name)
lop Term v Ann
ltm InfixParse v
ll (InfixParse v -> InfixParse v
fixUp (InfixParse v -> InfixParse v -> InfixParse v
ctor InfixParse v
lr InfixParse v
rhs))
        InfixAnd Token String
lop InfixParse v
ll InfixParse v
lr
          | Maybe Precedence -> Maybe Precedence -> Bool
forall {a}. Ord a => Maybe a -> Maybe a -> Bool
shouldRotate (Text -> Maybe Precedence
operatorPrecedence Text
"&&") (Text -> Maybe Precedence
operatorPrecedence Text
op) ->
              Token String -> InfixParse v -> InfixParse v -> InfixParse v
forall v.
Token String -> InfixParse v -> InfixParse v -> InfixParse v
InfixAnd Token String
lop InfixParse v
ll (InfixParse v -> InfixParse v
fixUp (InfixParse v -> InfixParse v -> InfixParse v
ctor InfixParse v
lr InfixParse v
rhs))
        InfixOr Token String
lop InfixParse v
ll InfixParse v
lr
          | Maybe Precedence -> Maybe Precedence -> Bool
forall {a}. Ord a => Maybe a -> Maybe a -> Bool
shouldRotate (Text -> Maybe Precedence
operatorPrecedence Text
"||") (Text -> Maybe Precedence
operatorPrecedence Text
op) ->
              Token String -> InfixParse v -> InfixParse v -> InfixParse v
forall v.
Token String -> InfixParse v -> InfixParse v -> InfixParse v
InfixOr Token String
lop InfixParse v
ll (InfixParse v -> InfixParse v
fixUp (InfixParse v -> InfixParse v -> InfixParse v
ctor InfixParse v
lr InfixParse v
rhs))
        InfixParse v
_ -> InfixParse v -> InfixParse v -> InfixParse v
ctor InfixParse v
lhs InfixParse v
rhs
    unqualified :: Token (HashQualified Name) -> Text
unqualified Token (HashQualified Name)
t = Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
Maybe.fromJust (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ NameSegment -> Text
NameSegment.toEscapedText (NameSegment -> Text) -> (Name -> NameSegment) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> NameSegment
Name.lastSegment (Name -> Text) -> Maybe Name -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (HashQualified Name -> Maybe Name
forall n. HashQualified n -> Maybe n
HQ.toName (HashQualified Name -> Maybe Name)
-> HashQualified Name -> Maybe Name
forall a b. (a -> b) -> a -> b
$ Token (HashQualified Name) -> HashQualified Name
forall a. Token a -> a
L.payload Token (HashQualified Name)
t)
    applyInfixOps :: InfixParse v -> Term v Ann
    applyInfixOps :: InfixParse v -> Term v Ann
applyInfixOps InfixParse v
t = case InfixParse v
t of
      InfixOp Token (HashQualified Name)
_ Term v Ann
tm InfixParse v
lhs InfixParse v
rhs ->
        Term v Ann -> [Term v Ann] -> Term v Ann
forall v a vt at ap.
(Ord v, Semigroup a) =>
Term2 vt at ap v a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
Term.apps' Term v Ann
tm [InfixParse v -> Term v Ann
applyInfixOps InfixParse v
lhs, InfixParse v -> Term v Ann
applyInfixOps InfixParse v
rhs]
      InfixOperand Term v Ann
tm -> Term v Ann
tm
      InfixAnd Token String
op InfixParse v
lhs InfixParse v
rhs ->
        let lhs' :: Term v Ann
lhs' = InfixParse v -> Term v Ann
applyInfixOps InfixParse v
lhs
            rhs' :: Term v Ann
rhs' = InfixParse v -> Term v Ann
applyInfixOps InfixParse v
rhs
         in Ann -> Term v Ann -> Term v Ann -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.and (Term v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term v Ann
lhs' Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
<> Token String -> Ann
forall a. Annotated a => a -> Ann
ann Token String
op Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
<> Term v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term v Ann
rhs') Term v Ann
lhs' Term v Ann
rhs'
      InfixOr Token String
op InfixParse v
lhs InfixParse v
rhs ->
        let lhs' :: Term v Ann
lhs' = InfixParse v -> Term v Ann
applyInfixOps InfixParse v
lhs
            rhs' :: Term v Ann
rhs' = InfixParse v -> Term v Ann
applyInfixOps InfixParse v
rhs
         in Ann -> Term v Ann -> Term v Ann -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.or (Term v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term v Ann
lhs' Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
<> Token String -> Ann
forall a. Annotated a => a -> Ann
ann Token String
op Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
<> Term v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term v Ann
rhs') Term v Ann
lhs' Term v Ann
rhs'

typedecl :: (Monad m, Var v) => P v m (L.Token v, Type v Ann)
typedecl :: forall (m :: * -> *) v.
(Monad m, Var v) =>
P v m (Token v, Type v Ann)
typedecl =
  (,)
    (Token v -> Type v Ann -> (Token v, Type v Ann))
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token v)
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (Type v Ann -> (Token v, Type v Ann))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token v)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token v)
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) (Token v)
forall v (m :: * -> *). Var v => P v m (Token v)
prefixTermName ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token v)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token String)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token v)
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
<* 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)
  (Type v Ann -> (Token v, Type v Ann))
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Type v Ann)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token v, Type v Ann)
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) (Type v Ann)
forall (m :: * -> *) v. (Monad m, Var v) => TypeP v m
TypeParser.valueType
    ParsecT
  (Error v) Input (ReaderT (ParsingEnv m) m) (Token v, Type v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token ())
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token v, Type v Ann)
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 ())
semi

verifyRelativeVarName :: (Var v) => P v m (L.Token v) -> P v m (L.Token v)
verifyRelativeVarName :: forall v (m :: * -> *). Var v => P v m (Token v) -> P v m (Token v)
verifyRelativeVarName P v m (Token v)
p = do
  Token v
v <- P v m (Token v)
p
  Token Name -> P v m ()
forall v (m :: * -> *). Ord v => Token Name -> P v m ()
verifyRelativeName' (v -> Name
forall v. Var v => v -> Name
Name.unsafeParseVar (v -> Name) -> Token v -> Token Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Token v
v)
  pure Token v
v

verifyRelativeName' :: (Ord v) => L.Token Name -> P v m ()
verifyRelativeName' :: forall v (m :: * -> *). Ord v => Token Name -> P v m ()
verifyRelativeName' Token Name
name = do
  let txt :: Text
txt = Name -> Text
Name.toText (Name -> Text) -> (Token Name -> Name) -> Token Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token Name -> Name
forall a. Token a -> a
L.payload (Token Name -> Text) -> Token Name -> Text
forall a b. (a -> b) -> a -> b
$ Token Name
name
  Bool -> P v m () -> P v m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> Text -> Bool
Text.isPrefixOf Text
"." Text
txt Bool -> Bool -> Bool
&& Text
txt Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
".") (P v m () -> P v m ()) -> P v m () -> P v m ()
forall a b. (a -> b) -> a -> b
$
    Error v -> P v m ()
forall v (m :: * -> *) x. Ord v => Error v -> P v m x
failCommitted (Token Name -> Error v
forall v. Token Name -> Error v
DisallowedAbsoluteName Token Name
name)

-- example:
--   (x, y)   = foo
--   stuff
--
-- desugars to:
--
--   match foo with
--     (x,y) -> stuff
--
destructuringBind :: forall m v. (Monad m, Var v) => P v m (Ann, Term v Ann -> Term v Ann)
destructuringBind :: forall (m :: * -> *) v.
(Monad m, Var v) =>
P v m (Ann, Term v Ann -> Term v Ann)
destructuringBind = do
  -- We have to look ahead as far as the `=` to know if this is a bind or
  -- just an action, for instance:
  --   (Some 42)
  --   vs
  --   (Some 42) = List.head elems
  (Pattern Ann
p, [v]
boundVars) <- ParsecT
  (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann, [v])
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Pattern Ann, [v])
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
    (Pattern Ann
p, [(Ann, v)]
boundVars) <- P v m (Pattern Ann, [(Ann, v)])
forall (m :: * -> *) v.
(Monad m, Var v) =>
P v m (Pattern Ann, [(Ann, v)])
parsePattern
    let boundVars' :: [v]
boundVars' = (Ann, v) -> v
forall a b. (a, b) -> b
snd ((Ann, v) -> v) -> [(Ann, v)] -> [v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Ann, v)]
boundVars
    Token ()
_ <- ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token ())
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token ())
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 (String
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token ())
forall v (m :: * -> *). Ord v => String -> P v m (Token ())
openBlockWith String
"=")
    pure (Pattern Ann
p, [v]
boundVars')
  (Ann
_spanAnn, Term v Ann
scrute) <- String -> P v m (Ann, Term v Ann)
forall (m :: * -> *) v.
(Monad m, Var v) =>
String -> P v m (Ann, Term v Ann)
layoutBlock String
"=" -- Dwight K. Scrute ("The People's Scrutinee")
  let guard :: Maybe a
guard = Maybe a
forall a. Maybe a
Nothing
  let absChain :: t v -> Term f v Ann -> Term f v Ann
absChain t v
vs Term f v Ann
t = (v -> Term f v Ann -> Term f v Ann)
-> Term f v Ann -> t v -> Term f v Ann
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\v
v Term f v Ann
t -> Ann -> v -> Term f v Ann -> Term f v Ann
forall v a (f :: * -> *).
Ord v =>
a -> v -> Term f v a -> Term f v a
ABT.abs' (Term f v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term f v Ann
t) v
v Term f v Ann
t) Term f v Ann
t t v
vs
      thecase :: Term v Ann -> MatchCase Ann (Term v Ann)
thecase Term v Ann
t = Pattern Ann
-> Maybe (Term v Ann) -> Term v Ann -> MatchCase Ann (Term v Ann)
forall loc a. Pattern loc -> Maybe a -> a -> MatchCase loc a
Term.MatchCase Pattern Ann
p ((Term v Ann -> Term v Ann)
-> Maybe (Term v Ann) -> Maybe (Term v Ann)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([v] -> Term v Ann -> Term v Ann
forall {t :: * -> *} {v} {f :: * -> *}.
(Foldable t, Ord v) =>
t v -> Term f v Ann -> Term f v Ann
absChain [v]
boundVars) Maybe (Term v Ann)
forall a. Maybe a
guard) (Term v Ann -> MatchCase Ann (Term v Ann))
-> Term v Ann -> MatchCase Ann (Term v Ann)
forall a b. (a -> b) -> a -> b
$ [v] -> Term v Ann -> Term v Ann
forall {t :: * -> *} {v} {f :: * -> *}.
(Foldable t, Ord v) =>
t v -> Term f v Ann -> Term f v Ann
absChain [v]
boundVars Term v Ann
t
  (Ann, Term v Ann -> Term v Ann)
-> P v m (Ann, Term v Ann -> Term v Ann)
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( Pattern Ann -> Ann
forall a. Annotated a => a -> Ann
ann Pattern Ann
p,
      \Term v Ann
t ->
        let a :: Ann
a = Pattern Ann -> Ann
forall a. Annotated a => a -> Ann
ann Pattern Ann
p Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
<> Term v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term v Ann
t
         in Ann -> Term v Ann -> [MatchCase Ann (Term v Ann)] -> Term v Ann
forall v a vt at.
Ord v =>
a
-> Term2 vt at a v a
-> [MatchCase a (Term2 vt at a v a)]
-> Term2 vt at a v a
Term.match Ann
a Term v Ann
scrute [Term v Ann -> MatchCase Ann (Term v Ann)
thecase Term v Ann
t]
    )

-- | Rules for the annotation of the resulting binding is as follows:
-- * If the binding has a type signature, the top level scope of the annotation for the type
-- Ann node will contain the _entire_ binding, including the type signature.
-- * The body expression of the binding contains the entire lhs (including the name of the
-- binding) and the entire body.
-- * If the binding is a lambda, the  lambda node includes the entire LHS of the binding,
-- including the name as well.
binding :: forall m v. (Monad m, Var v) => P v m ((Ann, v), Term v Ann)
binding :: forall (m :: * -> *) v.
(Monad m, Var v) =>
P v m ((Ann, v), Term v Ann)
binding = String
-> P v m ((Ann, v), Term v Ann) -> P v m ((Ann, v), Term v Ann)
forall v a (m :: * -> *).
(Ord v, Show a) =>
String -> P v m a -> P v m a
label String
"binding" do
  Maybe (Token v, Type v Ann)
typ <- ParsecT
  (Error v) Input (ReaderT (ParsingEnv m) m) (Token v, Type v Ann)
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (Maybe (Token v, Type v Ann))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ParsecT
  (Error v) Input (ReaderT (ParsingEnv m) m) (Token v, Type v Ann)
forall (m :: * -> *) v.
(Monad m, Var v) =>
P v m (Token v, Type v Ann)
typedecl
  -- a ++ b = ...
  let infixLhs :: ParsecT
  (Error v)
  Input
  (ReaderT (ParsingEnv m) m)
  (Ann, Token v, [Token v])
infixLhs = do
        (Token v
arg1, Token v
op) <-
          ParsecT
  (Error v) Input (ReaderT (ParsingEnv m) m) (Token v, Token v)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token v, Token v)
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) (Token v, Token v)
 -> ParsecT
      (Error v) Input (ReaderT (ParsingEnv m) m) (Token v, Token v))
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token v, Token v)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token v, Token v)
forall a b. (a -> b) -> a -> b
$
            (,) (Token v -> Token v -> (Token v, Token v))
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token v)
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (Token v -> (Token v, Token v))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token v)
forall v (m :: * -> *). Var v => P v m (Token v)
prefixDefinitionName ParsecT
  (Error v)
  Input
  (ReaderT (ParsingEnv m) m)
  (Token v -> (Token v, Token v))
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token v)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token v, Token v)
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) (Token v)
forall v (m :: * -> *). Var v => P v m (Token v)
symbolyDefinitionName
        Token v
arg2 <- ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token v)
forall v (m :: * -> *). Var v => P v m (Token v)
prefixDefinitionName
        pure (Token v -> Ann
forall a. Annotated a => a -> Ann
ann Token v
arg1, Token v
op, [Token v
arg1, Token v
arg2])
  let prefixLhs :: ParsecT
  (Error v)
  Input
  (ReaderT (ParsingEnv m) m)
  (Ann, Token v, [Token v])
prefixLhs = do
        Token v
v <- P v m (Token v)
forall v (m :: * -> *). Var v => P v m (Token v)
prefixTermName
        [Token v]
vs <- P v m (Token v)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) [Token v]
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 P v m (Token v)
forall v (m :: * -> *). Var v => P v m (Token v)
prefixTermName
        pure (Token v -> Ann
forall a. Annotated a => a -> Ann
ann Token v
v, Token v
v, [Token v]
vs)
  let lhs :: P v m (Ann, L.Token v, [L.Token v])
      lhs :: P v m (Ann, Token v, [Token v])
lhs = P v m (Ann, Token v, [Token v])
forall {m :: * -> *}.
ParsecT
  (Error v)
  Input
  (ReaderT (ParsingEnv m) m)
  (Ann, Token v, [Token v])
infixLhs P v m (Ann, Token v, [Token v])
-> P v m (Ann, Token v, [Token v])
-> P v m (Ann, Token v, [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 (Ann, Token v, [Token v])
forall {m :: * -> *}.
ParsecT
  (Error v)
  Input
  (ReaderT (ParsingEnv m) m)
  (Ann, Token v, [Token v])
prefixLhs
  case Maybe (Token v, Type v Ann)
typ of
    Maybe (Token v, Type v Ann)
Nothing -> do
      -- we haven't seen a type annotation, so lookahead to '=' before commit
      (Ann
lhsLoc, Token v
name, [Token v]
args) <- P v m (Ann, Token v, [Token v]) -> P v m (Ann, Token v, [Token v])
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 (Ann, Token v, [Token v])
lhs P v m (Ann, Token v, [Token v])
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token ())
-> P v m (Ann, Token v, [Token v])
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 ())
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token ())
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 (String
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token ())
forall v (m :: * -> *). Ord v => String -> P v m (Token ())
openBlockWith String
"="))
      (Ann
_bodySpanAnn, Term v Ann
body) <- String -> P v m (Ann, Term v Ann)
forall (m :: * -> *) v.
(Monad m, Var v) =>
String -> P v m (Ann, Term v Ann)
block String
"="
      Token Name -> P v m ()
forall v (m :: * -> *). Ord v => Token Name -> P v m ()
verifyRelativeName' ((v -> Name) -> Token v -> Token Name
forall a b. (a -> b) -> Token a -> Token b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap v -> Name
forall v. Var v => v -> Name
Name.unsafeParseVar Token v
name)
      let binding :: Term v Ann
binding = Ann -> [Token v] -> Term v Ann -> Term v Ann
mkBinding Ann
lhsLoc [Token v]
args Term v Ann
body
      -- We don't actually use the span annotation from the block (yet) because it
      -- may contain a bunch of white-space and comments following a top-level-definition.
      let spanAnn :: Ann
spanAnn = Ann -> Ann
forall a. Annotated a => a -> Ann
ann Ann
lhsLoc Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
<> Term v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term v Ann
binding
      pure $ ((Ann
spanAnn, (Token v -> v
forall a. Token a -> a
L.payload Token v
name)), Term v Ann
binding)
    Just (Token v
nameT, Type v Ann
typ) -> do
      (Ann
lhsLoc, Token v
name, [Token v]
args) <- P v m (Ann, Token v, [Token v])
lhs
      Token Name -> P v m ()
forall v (m :: * -> *). Ord v => Token Name -> P v m ()
verifyRelativeName' ((v -> Name) -> Token v -> Token Name
forall a b. (a -> b) -> Token a -> Token b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap v -> Name
forall v. Var v => v -> Name
Name.unsafeParseVar Token v
name)
      Bool -> P v m () -> P v m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Token v -> v
forall a. Token a -> a
L.payload Token v
name v -> v -> Bool
forall a. Eq a => a -> a -> Bool
/= Token v -> v
forall a. Token a -> a
L.payload Token v
nameT) (P v m () -> P v m ()) -> P v m () -> P v m ()
forall a b. (a -> b) -> a -> b
$
        Error v -> P v m ()
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure (Error v -> P v m ()) -> Error v -> P v m ()
forall a b. (a -> b) -> a -> b
$
          Token v -> Error v
forall v. Token v -> Error v
SignatureNeedsAccompanyingBody Token v
nameT
      (Ann
_bodySpanAnn, Term v Ann
body) <- String -> P v m (Ann, Term v Ann)
forall (m :: * -> *) v.
(Monad m, Var v) =>
String -> P v m (Ann, Term v Ann)
block String
"="
      let binding :: Term v Ann
binding = Ann -> [Token v] -> Term v Ann -> Term v Ann
mkBinding Ann
lhsLoc [Token v]
args Term v Ann
body
      -- We don't actually use the span annotation from the block (yet) because it
      -- may contain a bunch of white-space and comments following a top-level-definition.
      let spanAnn :: Ann
spanAnn = Token v -> Ann
forall a. Annotated a => a -> Ann
ann Token v
nameT Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
<> Term v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term v Ann
binding
      pure $ ((Ann
spanAnn, Token v -> v
forall a. Token a -> a
L.payload Token v
name), Ann -> Term v Ann -> Type v Ann -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Type vt at -> Term2 vt at ap v a
Term.ann (Token v -> Ann
forall a. Annotated a => a -> Ann
ann Token v
nameT Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
<> Term v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term v Ann
binding) Term v Ann
binding Type v Ann
typ)
  where
    mkBinding :: Ann -> [L.Token v] -> Term.Term v Ann -> Term.Term v Ann
    mkBinding :: Ann -> [Token v] -> Term v Ann -> Term v Ann
mkBinding Ann
_lhsLoc [] Term v Ann
body = Term v Ann
body
    mkBinding Ann
lhsLoc [Token v]
args Term v Ann
body =
      let annotatedArgs :: [(Ann, v)]
annotatedArgs = [Token v]
args [Token v] -> (Token v -> (Ann, v)) -> [(Ann, v)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Token v
arg -> (Token v -> Ann
forall a. Annotated a => a -> Ann
ann Token v
arg, Token v -> v
forall a. Token a -> a
L.payload Token v
arg)
       in Ann -> [(Ann, v)] -> Term v Ann -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> [(a, v)] -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.lam' (Ann
lhsLoc Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
<> Term v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term v Ann
body) [(Ann, v)]
annotatedArgs Term v Ann
body

customFailure :: (P.MonadParsec e s m) => e -> m a
customFailure :: forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure = e -> m a
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
P.customFailure

block :: forall m v. (Monad m, Var v) => String -> P v m (Ann, Term v Ann)
block :: forall (m :: * -> *) v.
(Monad m, Var v) =>
String -> P v m (Ann, Term v Ann)
block String
s = Bool
-> Bool
-> String
-> P v m (Token ())
-> P v m (Token ())
-> P v m (Ann, Term v Ann)
forall (m :: * -> *) v end.
(Monad m, Var v, Annotated end) =>
Bool
-> Bool
-> String
-> P v m (Token ())
-> P v m end
-> P v m (Ann, Term v Ann)
block' Bool
False Bool
False String
s (String -> P v m (Token ())
forall v (m :: * -> *). Ord v => String -> P v m (Token ())
openBlockWith String
s) P v m (Token ())
forall v (m :: * -> *). Ord v => P v m (Token ())
closeBlock

layoutBlock :: forall m v. (Monad m, Var v) => String -> P v m (Ann, Term v Ann)
layoutBlock :: forall (m :: * -> *) v.
(Monad m, Var v) =>
String -> P v m (Ann, Term v Ann)
layoutBlock String
s = Bool
-> Bool
-> String
-> P v m (Token ())
-> P v m (Token ())
-> P v m (Ann, Term v Ann)
forall (m :: * -> *) v end.
(Monad m, Var v, Annotated end) =>
Bool
-> Bool
-> String
-> P v m (Token ())
-> P v m end
-> P v m (Ann, Term v Ann)
block' Bool
False Bool
False String
s (String -> P v m (Token ())
forall v (m :: * -> *). Ord v => String -> P v m (Token ())
openBlockWith String
s) P v m (Token ())
forall v (m :: * -> *). Ord v => P v m (Token ())
optionalCloseBlock

-- example: use Foo.bar.Baz + ++ x
-- + ++ and x are called the "suffixes" of the `use` statement, and
-- `Foo.bar.Baz` is called the prefix. A `use` statement has the effect
-- of allowing you to reference identifiers of the form <prefix>.<suffix>
-- using just <suffix>.
--
-- `use foo` by itself is equivalent to `use foo bar baz ...` for all
-- names in the environment prefixed by `foo`
--
-- todo: doesn't support use Foo.bar ++#abc, which lets you use `++` unqualified to refer to `Foo.bar.++#abc`
importp :: (Monad m, Ord v) => P v m [(Name, Name)]
importp :: forall (m :: * -> *) v. (Monad m, Ord v) => P v m [(Name, Name)]
importp = do
  Token String
kw <- String -> P v m (Token String)
forall v (m :: * -> *). Ord v => String -> P v m (Token String)
reserved String
"use"
  -- we allow symbolyId here and parse the suffix optionaly, so we can generate
  -- a nicer error message if the suffixes are empty
  Maybe (Either (Token Name) (Token Name))
prefix <-
    ParsecT
  (Error v)
  Input
  (ReaderT (ParsingEnv m) m)
  (Either (Token Name) (Token Name))
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (Maybe (Either (Token Name) (Token Name)))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ParsecT
   (Error v)
   Input
   (ReaderT (ParsingEnv m) m)
   (Either (Token Name) (Token Name))
 -> ParsecT
      (Error v)
      Input
      (ReaderT (ParsingEnv m) m)
      (Maybe (Either (Token Name) (Token Name))))
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (Either (Token Name) (Token Name))
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (Maybe (Either (Token Name) (Token Name)))
forall a b. (a -> b) -> a -> b
$
      (Token Name -> Either (Token Name) (Token Name))
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token Name)
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (Either (Token Name) (Token Name))
forall a b.
(a -> b)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Token Name -> Either (Token Name) (Token Name)
forall a b. b -> Either a b
Right ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token Name)
forall v (m :: * -> *). Ord v => P v m (Token Name)
importWordyId
        ParsecT
  (Error v)
  Input
  (ReaderT (ParsingEnv m) m)
  (Either (Token Name) (Token Name))
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (Either (Token Name) (Token Name))
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (Either (Token Name) (Token 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
<|> (Token Name -> Either (Token Name) (Token Name))
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token Name)
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (Either (Token Name) (Token Name))
forall a b.
(a -> b)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Token Name -> Either (Token Name) (Token Name)
forall a b. a -> Either a b
Left ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token Name)
forall v (m :: * -> *). Ord v => P v m (Token Name)
importSymbolyId
  Maybe [Token Name]
suffixes <- ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) [Token Name]
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Maybe [Token Name])
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token Name)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) [Token Name]
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]
some (ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token Name)
forall v (m :: * -> *). Ord v => P v m (Token Name)
importWordyId ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token Name)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token Name)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token 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
<|> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token Name)
forall v (m :: * -> *). Ord v => P v m (Token Name)
importSymbolyId))
  case (Maybe (Either (Token Name) (Token Name))
prefix, Maybe [Token Name]
suffixes) of
    (Maybe (Either (Token Name) (Token Name))
Nothing, Maybe [Token Name]
_) -> Error v -> P v m [(Name, Name)]
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
P.customFailure (Error v -> P v m [(Name, Name)])
-> Error v -> P v m [(Name, Name)]
forall a b. (a -> b) -> a -> b
$ Token String -> Error v
forall v. Token String -> Error v
UseEmpty Token String
kw
    (Just prefix :: Either (Token Name) (Token Name)
prefix@(Left Token Name
_), Maybe [Token Name]
_) -> Error v -> P v m [(Name, Name)]
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
P.customFailure (Error v -> P v m [(Name, Name)])
-> Error v -> P v m [(Name, Name)]
forall a b. (a -> b) -> a -> b
$ Either (Token Name) (Token Name) -> Maybe [Token Name] -> Error v
forall v.
Either (Token Name) (Token Name) -> Maybe [Token Name] -> Error v
UseInvalidPrefixSuffix Either (Token Name) (Token Name)
prefix Maybe [Token Name]
suffixes
    (Just (Right Token Name
prefix), Maybe [Token Name]
Nothing) -> do
      -- `wildcard import`
      Names
names <- (ParsingEnv m -> Names)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) Names
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ParsingEnv m -> Names
forall (m :: * -> *). ParsingEnv m -> Names
names
      pure $ Name -> Names -> [(Name, Name)]
Names.expandWildcardImport (Token Name -> Name
forall a. Token a -> a
L.payload Token Name
prefix) Names
names
    (Just (Right Token Name
prefix), Just [Token Name]
suffixes) -> [(Name, Name)] -> P v m [(Name, Name)]
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure do
      Name
suffix <- Token Name -> Name
forall a. Token a -> a
L.payload (Token Name -> Name) -> [Token Name] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Token Name]
suffixes
      pure (Name
suffix, HasCallStack => Name -> Name -> Name
Name -> Name -> Name
Name.joinDot (Token Name -> Name
forall a. Token a -> a
L.payload Token Name
prefix) Name
suffix)

data BlockElement v
  = Binding ((Ann, v), Term v Ann)
  | DestructuringBind (Ann, Term v Ann -> Term v Ann)
  | Action (Term v Ann)

instance (Show v) => Show (BlockElement v) where
  show :: BlockElement v -> String
show (Binding ((Ann
pos, v
name), Term v Ann
_)) = (Text, Ann, v) -> String
forall a. Show a => a -> String
show (Text
"binding: " :: Text, Ann
pos, v
name)
  show (DestructuringBind (Ann
pos, Term v Ann -> Term v Ann
_)) = (Text, Ann) -> String
forall a. Show a => a -> String
show (Text
"destructuring bind: " :: Text, Ann
pos)
  show (Action Term v Ann
tm) = (Text, Ann) -> String
forall a. Show a => a -> String
show (Text
"action: " :: Text, Term v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term v Ann
tm)

-- subst
-- use Foo.Bar + blah
-- use Bar.Baz zonk zazzle
imports :: (Monad m, Var v) => P v m (Names, [(v, v)])
imports :: forall (m :: * -> *) v. (Monad m, Var v) => P v m (Names, [(v, v)])
imports = do
  let sem :: ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token ())
sem = ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token ())
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token ())
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) (Token ())
forall v (m :: * -> *). Ord v => P v m (Token ())
semi ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token ())
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token String)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) 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) (Token String)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) 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.lookAhead (String
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token String)
forall v (m :: * -> *). Ord v => String -> P v m (Token String)
reserved String
"use"))
  [(Name, Name)]
imported <- [[(Name, Name)]] -> [(Name, Name)]
forall a. Monoid a => [a] -> a
mconcat ([[(Name, Name)]] -> [(Name, Name)])
-> ([[(Name, Name)]] -> [[(Name, Name)]])
-> [[(Name, Name)]]
-> [(Name, Name)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(Name, Name)]] -> [[(Name, Name)]]
forall a. [a] -> [a]
reverse ([[(Name, Name)]] -> [(Name, Name)])
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) [[(Name, Name)]]
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) [(Name, Name)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P v m (Token ())
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) [(Name, Name)]
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) [[(Name, Name)]]
forall v (m :: * -> *) a b.
Ord v =>
P v m a -> P v m b -> P v m [b]
sepBy P v m (Token ())
forall {m :: * -> *}.
ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token ())
sem ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) [(Name, Name)]
forall (m :: * -> *) v. (Monad m, Ord v) => P v m [(Name, Name)]
importp
  Names
ns' <- [(Name, Name)] -> Names -> Names
Names.importing [(Name, Name)]
imported (Names -> Names)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) Names
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) Names
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsingEnv m -> Names)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) Names
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ParsingEnv m -> Names
forall (m :: * -> *). ParsingEnv m -> Names
names
  pure (Names
ns', [(Name -> v
forall v. Var v => Name -> v
Name.toVar Name
suffix, Name -> v
forall v. Var v => Name -> v
Name.toVar Name
full) | (Name
suffix, Name
full) <- [(Name, Name)]
imported])

-- A key feature of imports is we want to be able to say:
-- `use foo.bar Baz qux` without having to specify whether `Baz` or `qux` are
-- terms or types.
substImports :: (Var v) => Names -> [(v, v)] -> Term v Ann -> Term v Ann
substImports :: forall v. Var v => Names -> [(v, v)] -> Term v Ann -> Term v Ann
substImports Names
ns [(v, v)]
imports =
  [(v, Term (F v Ann Ann) v ())]
-> Term (F v Ann Ann) v Ann -> Term (F v Ann Ann) v Ann
forall (f :: * -> *) v b a.
(Foldable f, Functor f, Var v) =>
[(v, Term f v b)] -> Term f v a -> Term f v a
ABT.substsInheritAnnotation
    [ (v
suffix, () -> v -> Term (F v Ann Ann) v ()
forall a v vt at ap. a -> v -> Term2 vt at ap v a
Term.var () v
full)
      | (v
suffix, v
full) <- [(v, v)]
imports
    ]
    (Term (F v Ann Ann) v Ann -> Term (F v Ann Ann) v Ann)
-> (Term (F v Ann Ann) v Ann -> Term (F v Ann Ann) v Ann)
-> Term (F v Ann Ann) v Ann
-> Term (F v Ann Ann) v Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(v, Type v ())]
-> Term (F v Ann Ann) v Ann -> Term (F v Ann Ann) v Ann
forall v vt b a.
(Ord v, Var vt) =>
[(vt, Type vt b)] -> Term' vt v a -> Term' vt v a
Term.substTypeVars -- no guard here, as `full` could be bound
    -- not in Names, but in a later term binding
      [ (v
suffix, () -> v -> Type v ()
forall v a. Ord v => a -> v -> Type v a
Type.var () v
full)
        | (v
suffix, v
full) <- [(v, v)]
imports,
          SearchType -> Name -> Names -> Bool
Names.hasTypeNamed SearchType
Names.IncludeSuffixes (v -> Name
forall v. Var v => v -> Name
Name.unsafeParseVar v
full) Names
ns
      ]

block' ::
  forall m v end.
  (Monad m, Var v, Annotated end) =>
  IsTop ->
  -- | `True` means insert `()` at end of block if it ends with a statement
  Bool ->
  String ->
  P v m (L.Token ()) ->
  P v m end ->
  P v m (Ann {- ann which spans the whole block -}, Term v Ann)
block' :: forall (m :: * -> *) v end.
(Monad m, Var v, Annotated end) =>
Bool
-> Bool
-> String
-> P v m (Token ())
-> P v m end
-> P v m (Ann, Term v Ann)
block' Bool
isTop Bool
implicitUnitAtEnd String
s P v m (Token ())
openBlock P v m end
closeBlock = do
  Token ()
open <- P v m (Token ())
openBlock
  (Names
names, [(v, v)]
imports) <- P v m (Names, [(v, v)])
forall (m :: * -> *) v. (Monad m, Var v) => P v m (Names, [(v, v)])
imports
  Maybe (Token ())
_ <- 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
  [BlockElement v]
statements <- (ParsingEnv m -> ParsingEnv m)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) [BlockElement v]
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) [BlockElement v]
forall a.
(ParsingEnv m -> ParsingEnv m)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\ParsingEnv m
e -> ParsingEnv m
e {names}) (ParsecT
   (Error v) Input (ReaderT (ParsingEnv m) m) [BlockElement v]
 -> ParsecT
      (Error v) Input (ReaderT (ParsingEnv m) m) [BlockElement v])
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) [BlockElement v]
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) [BlockElement v]
forall a b. (a -> b) -> a -> b
$ P v m (Token ())
-> P v m (BlockElement v)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) [BlockElement v]
forall v (m :: * -> *) a b.
Ord v =>
P v m a -> P v m b -> P v m [b]
sepBy P v m (Token ())
forall v (m :: * -> *). Ord v => P v m (Token ())
semi P v m (BlockElement v)
statement
  end
end <- P v m end
closeBlock
  Term v Ann
body <- Names -> [(v, v)] -> Term v Ann -> Term v Ann
forall v. Var v => Names -> [(v, v)] -> Term v Ann -> Term v Ann
substImports Names
names [(v, v)]
imports (Term v Ann -> Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Token ()
-> [BlockElement v]
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
go Token ()
open [BlockElement v]
statements
  pure (Token () -> Ann
forall a. Annotated a => a -> Ann
ann Token ()
open Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
<> end -> Ann
forall a. Annotated a => a -> Ann
ann end
end, Term v Ann
body)
  where
    statement :: P v m (BlockElement v)
statement = [P v m (BlockElement v)] -> P v m (BlockElement v)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [((Ann, v), Term v Ann) -> BlockElement v
forall v. ((Ann, v), Term v Ann) -> BlockElement v
Binding (((Ann, v), Term v Ann) -> BlockElement v)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) ((Ann, v), Term v Ann)
-> P v m (BlockElement v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT
  (Error v) Input (ReaderT (ParsingEnv m) m) ((Ann, v), Term v Ann)
forall (m :: * -> *) v.
(Monad m, Var v) =>
P v m ((Ann, v), Term v Ann)
binding, (Ann, Term v Ann -> Term v Ann) -> BlockElement v
forall v. (Ann, Term v Ann -> Term v Ann) -> BlockElement v
DestructuringBind ((Ann, Term v Ann -> Term v Ann) -> BlockElement v)
-> ParsecT
     (Error v)
     Input
     (ReaderT (ParsingEnv m) m)
     (Ann, Term v Ann -> Term v Ann)
-> P v m (BlockElement v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT
  (Error v)
  Input
  (ReaderT (ParsingEnv m) m)
  (Ann, Term v Ann -> Term v Ann)
forall (m :: * -> *) v.
(Monad m, Var v) =>
P v m (Ann, Term v Ann -> Term v Ann)
destructuringBind, Term v Ann -> BlockElement v
forall v. Term v Ann -> BlockElement v
Action (Term v Ann -> BlockElement v)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
-> P v m (BlockElement v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
blockTerm]
    go :: L.Token () -> [BlockElement v] -> P v m (Term v Ann)
    go :: Token ()
-> [BlockElement v]
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
go Token ()
open =
      let finish :: Term.Term v Ann -> TermP v m
          finish :: Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
finish Term v Ann
tm = case Term v Ann -> Either (NonEmpty (v, [Ann])) (Term v Ann)
forall v vt a.
Var v =>
Term' vt v a -> Either (NonEmpty (v, [a])) (Term' vt v a)
Components.minimize' Term v Ann
tm of
            Left NonEmpty (v, [Ann])
dups -> Error v
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure (Error v
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> Error v
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a b. (a -> b) -> a -> b
$ [(v, [Ann])] -> Error v
forall v. [(v, [Ann])] -> Error v
DuplicateTermNames (NonEmpty (v, [Ann]) -> [(v, [Ann])]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (v, [Ann])
dups)
            Right Term v Ann
tm -> Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term v Ann
tm
          toTm :: [BlockElement v] -> TermP v m
          toTm :: [BlockElement v]
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
toTm [] = Error v
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure (Error v
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> Error v
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a b. (a -> b) -> a -> b
$ Token String -> Error v
forall v. Token String -> Error v
EmptyBlock (String -> () -> String
forall a b. a -> b -> a
const String
s (() -> String) -> Token () -> Token String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Token ()
open)
          toTm (BlockElement v
be : [BlockElement v]
bes) = do
            let ([BlockElement v]
bs, Term v Ann
blockResult) = NonEmpty (BlockElement v) -> ([BlockElement v], Term v Ann)
determineBlockResult (BlockElement v
be BlockElement v -> [BlockElement v] -> NonEmpty (BlockElement v)
forall a. a -> [a] -> NonEmpty a
:| [BlockElement v]
bes)
            Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
finish (Term v Ann
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (BlockElement v
 -> Term v Ann
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> Term v Ann
-> [BlockElement v]
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM BlockElement v
-> Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
step Term v Ann
blockResult [BlockElement v]
bs
            where
              step :: BlockElement v -> Term v Ann -> TermP v m
              step :: BlockElement v
-> Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
step BlockElement v
elem Term v Ann
result = case BlockElement v
elem of
                Binding ((Ann
a, v
v), Term v Ann
tm) ->
                  Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term v Ann
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a b. (a -> b) -> a -> b
$
                    Bool -> Ann -> (Ann, v, Term v Ann) -> Term v Ann -> Term v Ann
forall v a vt.
(Ord v, Semigroup a) =>
Bool -> a -> (a, v, Term' vt v a) -> Term' vt v a -> Term' vt v a
Term.consLetRec
                      Bool
isTop
                      (Ann -> Ann
forall a. Annotated a => a -> Ann
ann Ann
a Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
<> Term v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term v Ann
result)
                      (Ann
a, v
v, Term v Ann
tm)
                      Term v Ann
result
                Action Term v Ann
tm ->
                  Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term v Ann
 -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann))
-> Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall a b. (a -> b) -> a -> b
$
                    Bool -> Ann -> (Ann, v, Term v Ann) -> Term v Ann -> Term v Ann
forall v a vt.
(Ord v, Semigroup a) =>
Bool -> a -> (a, v, Term' vt v a) -> Term' vt v a -> Term' vt v a
Term.consLetRec
                      Bool
isTop
                      (Term v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term v Ann
tm Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
<> Term v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term v Ann
result)
                      (Term v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term v Ann
tm, Ann -> v -> v
forall a v. (Annotated a, Var v) => a -> v -> v
positionalVar (Term v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term v Ann
tm) (Text -> v
forall v. Var v => Text -> v
Var.named Text
"_"), Term v Ann
tm)
                      Term v Ann
result
                DestructuringBind (Ann
_, Term v Ann -> Term v Ann
f) ->
                  Term v Ann -> Term v Ann
f (Term v Ann -> Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term v Ann
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
finish Term v Ann
result
          determineBlockResult :: NonEmpty (BlockElement v) -> ([BlockElement v], Term v Ann)
          determineBlockResult :: NonEmpty (BlockElement v) -> ([BlockElement v], Term v Ann)
determineBlockResult NonEmpty (BlockElement v)
bs = case NonEmpty (BlockElement v) -> NonEmpty (BlockElement v)
forall a. NonEmpty a -> NonEmpty a
NonEmpty.reverse NonEmpty (BlockElement v)
bs of
            Binding ((Ann
a, v
_v), Term v Ann
_) :| [BlockElement v]
_ ->
              if Bool
implicitUnitAtEnd
                then (NonEmpty (BlockElement v) -> [BlockElement v]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (BlockElement v)
bs, Ann -> Term v Ann
forall v a vt at ap. Var v => a -> Term2 vt at ap v a
DD.unitTerm Ann
a)
                else (NonEmpty (BlockElement v) -> [BlockElement v]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (BlockElement v)
bs, Ann -> v -> Term v Ann
forall a v vt at ap. a -> v -> Term2 vt at ap v a
Term.var Ann
a (Ann -> v -> v
forall a v. (Annotated a, Var v) => a -> v -> v
positionalVar Ann
a v
forall v. Var v => v
Var.missingResult))
            Action Term v Ann
e :| [BlockElement v]
bs -> ([BlockElement v] -> [BlockElement v]
forall a. [a] -> [a]
reverse ([BlockElement v] -> [BlockElement v]
forall a. [a] -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [BlockElement v]
bs), Term v Ann
e)
            DestructuringBind (Ann
a, Term v Ann -> Term v Ann
_) :| [BlockElement v]
_ ->
              if Bool
implicitUnitAtEnd
                then (NonEmpty (BlockElement v) -> [BlockElement v]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (BlockElement v)
bs, Ann -> Term v Ann
forall v a vt at ap. Var v => a -> Term2 vt at ap v a
DD.unitTerm Ann
a)
                else (NonEmpty (BlockElement v) -> [BlockElement v]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (BlockElement v)
bs, Ann -> v -> Term v Ann
forall a v vt at ap. a -> v -> Term2 vt at ap v a
Term.var Ann
a (Ann -> v -> v
forall a v. (Annotated a, Var v) => a -> v -> v
positionalVar Ann
a v
forall v. Var v => v
Var.missingResult))
       in [BlockElement v]
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Term v Ann)
toTm

number :: (Var v) => TermP v m
number :: forall v (m :: * -> *). Var v => TermP v m
number = (Token Int64 -> Term v Ann)
-> (Token ConstructorId -> Term v Ann)
-> (Token Double -> Term v Ann)
-> P v m (Term v Ann)
forall v a (m :: * -> *).
Ord v =>
(Token Int64 -> a)
-> (Token ConstructorId -> a) -> (Token Double -> a) -> P v m a
number' ((Ann -> Int64 -> Term v Ann) -> Token Int64 -> Term v Ann
forall a b. (Ann -> a -> b) -> Token a -> b
tok Ann -> Int64 -> Term v Ann
forall v a vt at ap. Ord v => a -> Int64 -> Term2 vt at ap v a
Term.int) ((Ann -> ConstructorId -> Term v Ann)
-> Token ConstructorId -> Term v Ann
forall a b. (Ann -> a -> b) -> Token a -> b
tok Ann -> ConstructorId -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> ConstructorId -> Term2 vt at ap v a
Term.nat) ((Ann -> Double -> Term v Ann) -> Token Double -> Term v Ann
forall a b. (Ann -> a -> b) -> Token a -> b
tok Ann -> Double -> Term v Ann
forall v a vt at ap. Ord v => a -> Double -> Term2 vt at ap v a
Term.float)

bytes :: (Var v) => TermP v m
bytes :: forall v (m :: * -> *). Var v => TermP v m
bytes = do
  Token Bytes
b <- P v m (Token Bytes)
forall v (m :: * -> *). Ord v => P v m (Token Bytes)
bytesToken
  let a :: Ann
a = Token Bytes -> Ann
forall a. Annotated a => a -> Ann
ann Token Bytes
b
  Term v Ann -> TermP v m
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term v Ann -> TermP v m) -> Term v Ann -> TermP v m
forall a b. (a -> b) -> a -> b
$
    Ann -> Term v Ann -> Term v Ann -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app
      Ann
a
      (Ann -> Text -> Term v Ann
forall v a vt at ap. Ord v => a -> Text -> Term2 vt at ap v a
Term.builtin Ann
a Text
"Bytes.fromList")
      (Ann -> [Term v Ann] -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
Term.list Ann
a ([Term v Ann] -> Term v Ann) -> [Term v Ann] -> Term v Ann
forall a b. (a -> b) -> a -> b
$ Ann -> ConstructorId -> Term v Ann
forall v a vt at ap.
Ord v =>
a -> ConstructorId -> Term2 vt at ap v a
Term.nat Ann
a (ConstructorId -> Term v Ann)
-> (Word8 -> ConstructorId) -> Word8 -> Term v Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> ConstructorId
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Term v Ann) -> [Word8] -> [Term v Ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bytes -> [Word8]
Bytes.toWord8s (Token Bytes -> Bytes
forall a. Token a -> a
L.payload Token Bytes
b))

number' ::
  (Ord v) =>
  (L.Token Int64 -> a) ->
  (L.Token Word64 -> a) ->
  (L.Token Double -> a) ->
  P v m a
number' :: forall v a (m :: * -> *).
Ord v =>
(Token Int64 -> a)
-> (Token ConstructorId -> a) -> (Token Double -> a) -> P v m a
number' Token Int64 -> a
i Token ConstructorId -> a
u Token Double -> a
f = (Token String -> a)
-> ParsecT
     (Error v) Input (ReaderT (ParsingEnv m) m) (Token String)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall a b.
(a -> b)
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
-> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Token String -> a
go ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) (Token String)
forall v (m :: * -> *). Ord v => P v m (Token String)
numeric
  where
    go :: Token String -> a
go num :: Token String
num@(Token String -> String
forall a. Token a -> a
L.payload -> String
p)
      | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'e') String
p Bool -> Bool -> Bool
&& Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
1 String
p String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"+" = Token Double -> a
f (String -> Double
forall a. Read a => String -> a
read (String -> Double) -> (String -> String) -> String -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 (String -> Double) -> Token String -> Token Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Token String
num)
      | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'e') String
p = Token Double -> a
f (String -> Double
forall a. Read a => String -> a
read (String -> Double) -> Token String -> Token Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Token String
num)
      | Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
1 String
p String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"+" = Token Int64 -> a
i (String -> Int64
forall a. Read a => String -> a
read (String -> Int64) -> (String -> String) -> String -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 (String -> Int64) -> Token String -> Token Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Token String
num)
      | Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
1 String
p String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"-" = Token Int64 -> a
i (String -> Int64
forall a. Read a => String -> a
read (String -> Int64) -> Token String -> Token Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Token String
num)
      | Bool
otherwise = Token ConstructorId -> a
u (String -> ConstructorId
forall a. Read a => String -> a
read (String -> ConstructorId) -> Token String -> Token ConstructorId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Token String
num)

tupleOrParenthesizedTerm :: (Monad m, Var v) => TermP v m
tupleOrParenthesizedTerm :: forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
tupleOrParenthesizedTerm = String -> P v m (Term v Ann) -> P v m (Term v Ann)
forall v a (m :: * -> *).
(Ord v, Show a) =>
String -> P v m a -> P v m a
label String
"tuple" (P v m (Term v Ann) -> P v m (Term v Ann))
-> P v m (Term v Ann) -> P v m (Term v Ann)
forall a b. (a -> b) -> a -> b
$ do
  (Ann
spanAnn, Term v Ann
tm) <- P v m (Term v Ann)
-> (Ann -> Term v Ann)
-> (Term v Ann -> Term v Ann -> Term v Ann)
-> P v m (Ann, Term v Ann)
forall v (m :: * -> *) a.
Ord v =>
P v m a -> (Ann -> a) -> (a -> a -> a) -> P v m (Ann, a)
tupleOrParenthesized P v m (Term v Ann)
forall (m :: * -> *) v. (Monad m, Var v) => TermP v m
term Ann -> Term v Ann
forall v a vt at ap. Var v => a -> Term2 vt at ap v a
DD.unitTerm Term v Ann -> Term v Ann -> Term v Ann
forall {v} {vt} {at} {ap}.
Ord v =>
Term (F vt at ap) v Ann
-> Term (F vt at ap) v Ann -> Term (F vt at ap) v Ann
pair
  Term v Ann -> P v m (Term v Ann)
forall a. a -> ParsecT (Error v) Input (ReaderT (ParsingEnv m) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term v Ann -> P v m (Term v Ann))
-> Term v Ann -> P v m (Term v Ann)
forall a b. (a -> b) -> a -> b
$ Term v Ann
tm {ABT.annotation = spanAnn}
  where
    pair :: Term (F vt at ap) v Ann
-> Term (F vt at ap) v Ann -> Term (F vt at ap) v Ann
pair Term (F vt at ap) v Ann
t1 Term (F vt at ap) v Ann
t2 =
      Ann
-> Term (F vt at ap) v Ann
-> Term (F vt at ap) v Ann
-> Term (F vt at ap) v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app
        (Term (F vt at ap) v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term (F vt at ap) v Ann
t1 Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
<> Term (F vt at ap) v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term (F vt at ap) v Ann
t2)
        ( Ann
-> Term (F vt at ap) v Ann
-> Term (F vt at ap) v Ann
-> Term (F vt at ap) v Ann
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app
            (Term (F vt at ap) v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term (F vt at ap) v Ann
t1)
            (Ann -> ConstructorReference -> Term (F vt at ap) v Ann
forall v a vt at ap.
Ord v =>
a -> ConstructorReference -> Term2 vt at ap v a
Term.constructor (Term (F vt at ap) v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term (F vt at ap) v Ann
t1 Ann -> Ann -> Ann
forall a. Semigroup a => a -> a -> a
<> Term (F vt at ap) v Ann -> Ann
forall a. Annotated a => a -> Ann
ann Term (F vt at ap) v Ann
t2) (TypeReference -> ConstructorId -> ConstructorReference
forall r. r -> ConstructorId -> GConstructorReference r
ConstructorReference TypeReference
DD.pairRef ConstructorId
0))
            Term (F vt at ap) v Ann
t1
        )
        Term (F vt at ap) v Ann
t2