{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans #-}
{-# LANGUAGE DeriveFoldable    #-}
{-# LANGUAGE DeriveFunctor     #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
module Rzk.TypeCheck where

import           Control.Applicative      ((<|>))
import           Control.Monad            (forM, forM_, join, unless, when)
import           Control.Monad.Except
import           Control.Monad.Reader
-- An explicit list: a bare 'Control.Monad.Writer' import also re-exports
-- 'Data.Monoid' (incl. 'First'/'Last') on some mtl versions, which clashes with
-- the 'First'/'Last' term patterns from 'Language.Rzk.Free.Syntax'.
import           Control.Monad.Writer     (WriterT, censor, runWriterT, tell)
import           Data.Bifoldable          (bifoldr)
import           Data.Bifunctor           (first)
import           Data.List                (intercalate, intersect, nub, partition,
                                           tails, (\\))
import           Data.Maybe               (catMaybes, fromMaybe, isNothing,
                                           mapMaybe)
import           Data.String              (IsString (..))
import           Data.Tuple               (swap)

import           Free.Scoped
import           Language.Rzk.Free.Syntax
import qualified Language.Rzk.Syntax      as Rzk

import           Debug.Trace
import           Unsafe.Coerce

-- $setup
-- >>> :set -XOverloadedStrings


-- | Parse and 'unsafeInferStandalone''.
instance IsString TermT' where
  fromString :: String -> TermT VarIdent
fromString = Term VarIdent -> TermT VarIdent
unsafeInferStandalone' (Term VarIdent -> TermT VarIdent)
-> (String -> Term VarIdent) -> String -> TermT VarIdent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Term VarIdent
forall a. IsString a => String -> a
fromString

defaultTypeCheck
  :: TypeCheck var a
  -> Either (TypeErrorInScopedContext var) a
defaultTypeCheck :: forall var a.
TypeCheck var a -> Either (TypeErrorInScopedContext var) a
defaultTypeCheck = ((a, [HoleInfo]) -> a)
-> Either (TypeErrorInScopedContext var) (a, [HoleInfo])
-> Either (TypeErrorInScopedContext var) a
forall a b.
(a -> b)
-> Either (TypeErrorInScopedContext var) a
-> Either (TypeErrorInScopedContext var) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, [HoleInfo]) -> a
forall a b. (a, b) -> a
fst (Either (TypeErrorInScopedContext var) (a, [HoleInfo])
 -> Either (TypeErrorInScopedContext var) a)
-> (TypeCheck var a
    -> Either (TypeErrorInScopedContext var) (a, [HoleInfo]))
-> TypeCheck var a
-> Either (TypeErrorInScopedContext var) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context var
-> TypeCheck var a
-> Either (TypeErrorInScopedContext var) (a, [HoleInfo])
forall var a.
Context var
-> TypeCheck var a
-> Either (TypeErrorInScopedContext var) (a, [HoleInfo])
defaultTypeCheckWithHoles' Context var
forall var. Context var
emptyContext

-- | Like 'defaultTypeCheck', but runs in lenient hole mode ('allowHoles') and
-- also returns the holes recorded during checking (with their goal and context).
defaultTypeCheckWithHoles
  :: TypeCheck var a
  -> Either (TypeErrorInScopedContext var) (a, [HoleInfo])
defaultTypeCheckWithHoles :: forall var a.
TypeCheck var a
-> Either (TypeErrorInScopedContext var) (a, [HoleInfo])
defaultTypeCheckWithHoles = Context var
-> TypeCheck var a
-> Either (TypeErrorInScopedContext var) (a, [HoleInfo])
forall var a.
Context var
-> TypeCheck var a
-> Either (TypeErrorInScopedContext var) (a, [HoleInfo])
defaultTypeCheckWithHoles' (Context var -> Context var
forall var. Context var -> Context var
allowHoles Context var
forall var. Context var
emptyContext)

defaultTypeCheckWithHoles'
  :: Context var
  -> TypeCheck var a
  -> Either (TypeErrorInScopedContext var) (a, [HoleInfo])
defaultTypeCheckWithHoles' :: forall var a.
Context var
-> TypeCheck var a
-> Either (TypeErrorInScopedContext var) (a, [HoleInfo])
defaultTypeCheckWithHoles' Context var
ctx TypeCheck var a
tc =
  Except (TypeErrorInScopedContext var) (a, [HoleInfo])
-> Either (TypeErrorInScopedContext var) (a, [HoleInfo])
forall e a. Except e a -> Either e a
runExcept (WriterT
  [HoleInfo] (ExceptT (TypeErrorInScopedContext var) Identity) a
-> Except (TypeErrorInScopedContext var) (a, [HoleInfo])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (TypeCheck var a
-> Context var
-> WriterT
     [HoleInfo] (ExceptT (TypeErrorInScopedContext var) Identity) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT TypeCheck var a
tc Context var
ctx))

-- FIXME: merge with VarInfo
data Decl var = Decl
  { forall var. Decl var -> var
declName         :: var
  , forall var. Decl var -> TermT var
declType         :: TermT var
  , forall var. Decl var -> Maybe (TermT var)
declValue        :: Maybe (TermT var)
  , forall var. Decl var -> Bool
declIsAssumption :: Bool
  , forall var. Decl var -> [var]
declUsedVars     :: [var]
  , forall var. Decl var -> Maybe LocationInfo
declLocation     :: Maybe LocationInfo
  } deriving Decl var -> Decl var -> Bool
(Decl var -> Decl var -> Bool)
-> (Decl var -> Decl var -> Bool) -> Eq (Decl var)
forall var. Eq var => Decl var -> Decl var -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall var. Eq var => Decl var -> Decl var -> Bool
== :: Decl var -> Decl var -> Bool
$c/= :: forall var. Eq var => Decl var -> Decl var -> Bool
/= :: Decl var -> Decl var -> Bool
Eq

type Decl' = Decl VarIdent

typecheckModulesWithLocationIncremental
  :: [(FilePath, [Decl'])]    -- ^ Cached declarations (only those that do not need rechecking).
  -> [(FilePath, Rzk.Module)] -- ^ New modules to check
  -> TypeCheck VarIdent ([(FilePath, [Decl'])], [TypeErrorInScopedContext VarIdent])
typecheckModulesWithLocationIncremental :: [(String, [Decl'])]
-> [(String, Module)]
-> TypeCheck
     VarIdent ([(String, [Decl'])], [TypeErrorInScopedContext VarIdent])
typecheckModulesWithLocationIncremental [(String, [Decl'])]
cached [(String, Module)]
modulesToTypecheck = do
  let decls :: [Decl']
decls = ((String, [Decl']) -> [Decl']) -> [(String, [Decl'])] -> [Decl']
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (String, [Decl']) -> [Decl']
forall a b. (a, b) -> b
snd [(String, [Decl'])]
cached
  [Decl']
-> TypeCheck
     VarIdent ([(String, [Decl'])], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([(String, [Decl'])], [TypeErrorInScopedContext VarIdent])
forall a. [Decl'] -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclsPrepared [Decl']
decls (TypeCheck
   VarIdent ([(String, [Decl'])], [TypeErrorInScopedContext VarIdent])
 -> TypeCheck
      VarIdent
      ([(String, [Decl'])], [TypeErrorInScopedContext VarIdent]))
-> TypeCheck
     VarIdent ([(String, [Decl'])], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([(String, [Decl'])], [TypeErrorInScopedContext VarIdent])
forall a b. (a -> b) -> a -> b
$ do
    (checked, errors) <- [(String, Module)]
-> TypeCheck
     VarIdent ([(String, [Decl'])], [TypeErrorInScopedContext VarIdent])
typecheckModulesWithLocation' [(String, Module)]
modulesToTypecheck
    return (cached <> checked, errors)

typecheckModulesWithLocation' :: [(FilePath, Rzk.Module)] -> TypeCheck VarIdent ([(FilePath, [Decl'])], [TypeErrorInScopedContext VarIdent])
typecheckModulesWithLocation' :: [(String, Module)]
-> TypeCheck
     VarIdent ([(String, [Decl'])], [TypeErrorInScopedContext VarIdent])
typecheckModulesWithLocation' = \case
  [] -> ([(String, [Decl'])], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([(String, [Decl'])], [TypeErrorInScopedContext VarIdent])
forall a.
a
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
  m :: (String, Module)
m@(String
path, Module
_) : [(String, Module)]
ms -> do
    (decls, errs) <- (String, Module)
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
typecheckModuleWithLocation (String, Module)
m
    case errs of
      TypeErrorInScopedContext VarIdent
_:[TypeErrorInScopedContext VarIdent]
_ -> ([(String, [Decl'])], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([(String, [Decl'])], [TypeErrorInScopedContext VarIdent])
forall a.
a
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String
path, [Decl']
decls)], [TypeErrorInScopedContext VarIdent]
errs)
      [TypeErrorInScopedContext VarIdent]
_ -> do
        [Decl']
-> TypeCheck
     VarIdent ([(String, [Decl'])], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([(String, [Decl'])], [TypeErrorInScopedContext VarIdent])
forall a. [Decl'] -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclsPrepared [Decl']
decls (TypeCheck
   VarIdent ([(String, [Decl'])], [TypeErrorInScopedContext VarIdent])
 -> TypeCheck
      VarIdent
      ([(String, [Decl'])], [TypeErrorInScopedContext VarIdent]))
-> TypeCheck
     VarIdent ([(String, [Decl'])], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([(String, [Decl'])], [TypeErrorInScopedContext VarIdent])
forall a b. (a -> b) -> a -> b
$ do
          (decls', errors) <- [(String, Module)]
-> TypeCheck
     VarIdent ([(String, [Decl'])], [TypeErrorInScopedContext VarIdent])
typecheckModulesWithLocation' [(String, Module)]
ms
          return ((path, decls) : decls', errors)

-- | Typecheck modules in lenient hole mode, returning the elaborated
-- declarations, any type errors, and the holes recorded (each with its goal and
-- local context). This is the structured goal/context query consumed by the
-- LSP and the game. Strict callers (the default CLI path, CI) keep using
-- 'typecheckModulesWithLocation', where holes are 'TypeErrorUnsolvedHole'.
typecheckModulesWithHoles
  :: [(FilePath, Rzk.Module)]
  -> Either (TypeErrorInScopedContext VarIdent)
            ([(FilePath, [Decl'])], [TypeErrorInScopedContext VarIdent], [HoleInfo])
typecheckModulesWithHoles :: [(String, Module)]
-> Either
     (TypeErrorInScopedContext VarIdent)
     ([(String, [Decl'])], [TypeErrorInScopedContext VarIdent],
      [HoleInfo])
typecheckModulesWithHoles = [VarIdent]
-> [(String, Module)]
-> Either
     (TypeErrorInScopedContext VarIdent)
     ([(String, [Decl'])], [TypeErrorInScopedContext VarIdent],
      [HoleInfo])
typecheckModulesWithHolesAndLemmas []

-- | Like 'typecheckModulesWithHoles', but additionally offers the given named
-- top-level definitions as hole candidates (each applied to holes when its type
-- fits the goal). The game passes a level's allow-list of relevant lemmas so
-- they surface as moves; an empty list reproduces 'typecheckModulesWithHoles'.
typecheckModulesWithHolesAndLemmas
  :: [VarIdent]
  -> [(FilePath, Rzk.Module)]
  -> Either (TypeErrorInScopedContext VarIdent)
            ([(FilePath, [Decl'])], [TypeErrorInScopedContext VarIdent], [HoleInfo])
typecheckModulesWithHolesAndLemmas :: [VarIdent]
-> [(String, Module)]
-> Either
     (TypeErrorInScopedContext VarIdent)
     ([(String, [Decl'])], [TypeErrorInScopedContext VarIdent],
      [HoleInfo])
typecheckModulesWithHolesAndLemmas [VarIdent]
lemmas [(String, Module)]
modules =
  (([(String, [Decl'])], [TypeErrorInScopedContext VarIdent]),
 [HoleInfo])
-> ([(String, [Decl'])], [TypeErrorInScopedContext VarIdent],
    [HoleInfo])
forall {a} {b} {c}. ((a, b), c) -> (a, b, c)
flatten ((([(String, [Decl'])], [TypeErrorInScopedContext VarIdent]),
  [HoleInfo])
 -> ([(String, [Decl'])], [TypeErrorInScopedContext VarIdent],
     [HoleInfo]))
-> Either
     (TypeErrorInScopedContext VarIdent)
     (([(String, [Decl'])], [TypeErrorInScopedContext VarIdent]),
      [HoleInfo])
-> Either
     (TypeErrorInScopedContext VarIdent)
     ([(String, [Decl'])], [TypeErrorInScopedContext VarIdent],
      [HoleInfo])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context VarIdent
-> TypeCheck
     VarIdent ([(String, [Decl'])], [TypeErrorInScopedContext VarIdent])
-> Either
     (TypeErrorInScopedContext VarIdent)
     (([(String, [Decl'])], [TypeErrorInScopedContext VarIdent]),
      [HoleInfo])
forall var a.
Context var
-> TypeCheck var a
-> Either (TypeErrorInScopedContext var) (a, [HoleInfo])
defaultTypeCheckWithHoles'
    ([VarIdent] -> Context VarIdent -> Context VarIdent
forall var. [VarIdent] -> Context var -> Context var
withHintLemmas [VarIdent]
lemmas (Context VarIdent -> Context VarIdent
forall var. Context var -> Context var
allowHoles Context VarIdent
forall var. Context var
emptyContext))
    ([(String, Module)]
-> TypeCheck
     VarIdent ([(String, [Decl'])], [TypeErrorInScopedContext VarIdent])
typecheckModulesWithLocation' [(String, Module)]
modules)
  where
    flatten :: ((a, b), c) -> (a, b, c)
flatten ((a
decls, b
errs), c
holes) = (a
decls, b
errs, c
holes)

typecheckModulesWithLocation :: [(FilePath, Rzk.Module)] -> TypeCheck VarIdent [(FilePath, [Decl'])]
typecheckModulesWithLocation :: [(String, Module)] -> TypeCheck VarIdent [(String, [Decl'])]
typecheckModulesWithLocation = \case
  [] -> [(String, [Decl'])] -> TypeCheck VarIdent [(String, [Decl'])]
forall a.
a
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  m :: (String, Module)
m@(String
path, Module
_) : [(String, Module)]
ms -> do
    (decls, errs) <- (String, Module)
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
typecheckModuleWithLocation (String, Module)
m
    case errs of
      TypeErrorInScopedContext VarIdent
err : [TypeErrorInScopedContext VarIdent]
_ -> do
        TypeErrorInScopedContext VarIdent
-> TypeCheck VarIdent [(String, [Decl'])]
forall a.
TypeErrorInScopedContext VarIdent
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError TypeErrorInScopedContext VarIdent
err
      [] -> [Decl']
-> TypeCheck VarIdent [(String, [Decl'])]
-> TypeCheck VarIdent [(String, [Decl'])]
forall a. [Decl'] -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclsPrepared [Decl']
decls (TypeCheck VarIdent [(String, [Decl'])]
 -> TypeCheck VarIdent [(String, [Decl'])])
-> TypeCheck VarIdent [(String, [Decl'])]
-> TypeCheck VarIdent [(String, [Decl'])]
forall a b. (a -> b) -> a -> b
$
        ((String
path, [Decl']
decls) (String, [Decl']) -> [(String, [Decl'])] -> [(String, [Decl'])]
forall a. a -> [a] -> [a]
:) ([(String, [Decl'])] -> [(String, [Decl'])])
-> TypeCheck VarIdent [(String, [Decl'])]
-> TypeCheck VarIdent [(String, [Decl'])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, Module)] -> TypeCheck VarIdent [(String, [Decl'])]
typecheckModulesWithLocation [(String, Module)]
ms

typecheckModules :: [Rzk.Module] -> TypeCheck VarIdent [Decl']
typecheckModules :: [Module] -> TypeCheck VarIdent [Decl']
typecheckModules = \case
  [] -> [Decl'] -> TypeCheck VarIdent [Decl']
forall a.
a
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  Module
m : [Module]
ms -> do
    (decls, errs) <- Maybe String
-> Module
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
typecheckModule Maybe String
forall a. Maybe a
Nothing Module
m
    case errs of
      TypeErrorInScopedContext VarIdent
err : [TypeErrorInScopedContext VarIdent]
_ -> do
        TypeErrorInScopedContext VarIdent -> TypeCheck VarIdent [Decl']
forall a.
TypeErrorInScopedContext VarIdent
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError TypeErrorInScopedContext VarIdent
err
      [TypeErrorInScopedContext VarIdent]
_ -> do
        [Decl'] -> TypeCheck VarIdent [Decl'] -> TypeCheck VarIdent [Decl']
forall a. [Decl'] -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclsPrepared [Decl']
decls (TypeCheck VarIdent [Decl'] -> TypeCheck VarIdent [Decl'])
-> TypeCheck VarIdent [Decl'] -> TypeCheck VarIdent [Decl']
forall a b. (a -> b) -> a -> b
$
          ([Decl']
decls [Decl'] -> [Decl'] -> [Decl']
forall a. Semigroup a => a -> a -> a
<>) ([Decl'] -> [Decl'])
-> TypeCheck VarIdent [Decl'] -> TypeCheck VarIdent [Decl']
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Module] -> TypeCheck VarIdent [Decl']
typecheckModules [Module]
ms

typecheckModuleWithLocation :: (FilePath, Rzk.Module) -> TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
typecheckModuleWithLocation :: (String, Module)
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
typecheckModuleWithLocation (String
path, Module
module_) = do
  Verbosity
-> String
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall var a.
Verbosity -> String -> TypeCheck var a -> TypeCheck var a
traceTypeCheck Verbosity
Normal (String
"Checking module from " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
path) (TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
 -> TypeCheck
      VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a b. (a -> b) -> a -> b
$ do
    LocationInfo
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall var a. LocationInfo -> TypeCheck var a -> TypeCheck var a
withLocation (LocationInfo { locationFilePath :: Maybe String
locationFilePath = String -> Maybe String
forall a. a -> Maybe a
Just String
path, locationLine :: Maybe Int
locationLine = Maybe Int
forall a. Maybe a
Nothing }) (TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
 -> TypeCheck
      VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a b. (a -> b) -> a -> b
$
      Maybe String
-> Module
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
typecheckModule (String -> Maybe String
forall a. a -> Maybe a
Just String
path) Module
module_

countCommands :: Integral a => [Rzk.Command] -> a
countCommands :: forall a. Integral a => [Command] -> a
countCommands = Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> a) -> ([Command] -> Int) -> [Command] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Command] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length

typecheckModule :: Maybe FilePath -> Rzk.Module -> TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
typecheckModule :: Maybe String
-> Module
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
typecheckModule Maybe String
path (Rzk.Module BNFC'Position
_moduleLoc LanguageDecl' BNFC'Position
_lang [Command]
commands) =
  Maybe SectionName
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
withSection Maybe SectionName
forall a. Maybe a
Nothing (Integer
-> [Command]
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
go Integer
1 [Command]
commands) (TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
 -> TypeCheck
      VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a b. (a -> b) -> a -> b
$ -- FIXME: use module name? or anonymous section?
    ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a.
a
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
  where
    totalCommands :: Integer
totalCommands = [Command] -> Integer
forall a. Integral a => [Command] -> a
countCommands [Command]
commands

    go :: Integer -> [Rzk.Command] -> TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
    go :: Integer
-> [Command]
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
go Integer
_i [] = ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a.
a
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])

    go  Integer
i (command :: Command
command@(Rzk.CommandUnsetOption BNFC'Position
_loc String
optionName) : [Command]
moreCommands) = do
      Verbosity
-> String
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall var a.
Verbosity -> String -> TypeCheck var a -> TypeCheck var a
traceTypeCheck Verbosity
Normal (String
"[ " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
i String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" out of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
totalCommands String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" ]"
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" Unsetting option " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
optionName) (TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
 -> TypeCheck
      VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a b. (a -> b) -> a -> b
$ do
        Command
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
withCommand Command
command (TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
 -> TypeCheck
      VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a b. (a -> b) -> a -> b
$ do
          String
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall var a. String -> TypeCheck var a -> TypeCheck var a
unsetOption String
optionName (TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
 -> TypeCheck
      VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a b. (a -> b) -> a -> b
$
            Integer
-> [Command]
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
go (Integer
i Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) [Command]
moreCommands

    go  Integer
i (command :: Command
command@(Rzk.CommandSetOption BNFC'Position
_loc String
optionName String
optionValue) : [Command]
moreCommands) = do
      Verbosity
-> String
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall var a.
Verbosity -> String -> TypeCheck var a -> TypeCheck var a
traceTypeCheck Verbosity
Normal (String
"[ " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
i String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" out of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
totalCommands String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" ]"
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" Setting option " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
optionName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" = " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
optionValue ) (TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
 -> TypeCheck
      VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a b. (a -> b) -> a -> b
$ do
        Command
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
withCommand Command
command (TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
 -> TypeCheck
      VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a b. (a -> b) -> a -> b
$ do
          String
-> String
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall var a.
String -> String -> TypeCheck var a -> TypeCheck var a
setOption String
optionName String
optionValue (TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
 -> TypeCheck
      VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a b. (a -> b) -> a -> b
$
            Integer
-> [Command]
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
go (Integer
i Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) [Command]
moreCommands

    go  Integer
i (command :: Command
command@(Rzk.CommandDefine BNFC'Position
_loc VarIdent' BNFC'Position
name (Rzk.DeclUsedVars BNFC'Position
_ [VarIdent' BNFC'Position]
vars) [Param' BNFC'Position]
params Term' BNFC'Position
ty Term' BNFC'Position
term) : [Command]
moreCommands) =
      Verbosity
-> String
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall var a.
Verbosity -> String -> TypeCheck var a -> TypeCheck var a
traceTypeCheck Verbosity
Normal (String
"[ " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
i String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" out of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
totalCommands String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" ]"
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" Checking #define " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> VarIdent' BNFC'Position -> String
forall a. Print a => a -> String
Rzk.printTree VarIdent' BNFC'Position
name ) (TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
 -> TypeCheck
      VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a b. (a -> b) -> a -> b
$ do
        Command
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
withCommand Command
command (TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
 -> TypeCheck
      VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a b. (a -> b) -> a -> b
$ do
          (VarIdent
 -> ReaderT
      (Context VarIdent)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
      ())
-> [VarIdent]
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ VarIdent
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     ()
checkDefinedVar (Maybe String -> VarIdent' BNFC'Position -> VarIdent
varIdentAt Maybe String
path (VarIdent' BNFC'Position -> VarIdent)
-> [VarIdent' BNFC'Position] -> [VarIdent]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VarIdent' BNFC'Position]
vars)
          paramDecls <- [[ParamDecl]] -> [ParamDecl]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[ParamDecl]] -> [ParamDecl])
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     [[ParamDecl]]
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     [ParamDecl]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Param' BNFC'Position
 -> ReaderT
      (Context VarIdent)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
      [ParamDecl])
-> [Param' BNFC'Position]
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     [[ParamDecl]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Param' BNFC'Position
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     [ParamDecl]
forall var. Param' BNFC'Position -> TypeCheck var [ParamDecl]
paramToParamDecl [Param' BNFC'Position]
params
          -- Store the elaborated type and term unreduced, but memoise their
          -- WHNF on the top node (see 'memoizeWHNF'). Reducing in place would
          -- discard or expose a variable occurrence, so the section
          -- unused/implicit-assumption checks (run over the stored type and
          -- value) would disagree with the term the user wrote; keeping the
          -- WHNF cached preserves the original one-shot reduction.
          ty' <- memoizeWHNF =<< typecheck (toTerm' (addParamDecls paramDecls ty)) universeT
          term' <- memoizeWHNF =<< typecheck (toTerm' (addParams params term)) ty'
          loc <- asks location
          let decl = VarIdent
-> TermT VarIdent
-> Maybe (TermT VarIdent)
-> Bool
-> [VarIdent]
-> Maybe LocationInfo
-> Decl'
forall var.
var
-> TermT var
-> Maybe (TermT var)
-> Bool
-> [var]
-> Maybe LocationInfo
-> Decl var
Decl (Maybe String -> VarIdent' BNFC'Position -> VarIdent
varIdentAt Maybe String
path VarIdent' BNFC'Position
name) TermT VarIdent
ty' (TermT VarIdent -> Maybe (TermT VarIdent)
forall a. a -> Maybe a
Just TermT VarIdent
term') Bool
False (Maybe String -> VarIdent' BNFC'Position -> VarIdent
varIdentAt Maybe String
path (VarIdent' BNFC'Position -> VarIdent)
-> [VarIdent' BNFC'Position] -> [VarIdent]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VarIdent' BNFC'Position]
vars) Maybe LocationInfo
loc
          fmap (first (decl :)) $
            localDeclPrepared decl $ do
              Context{..} <- ask
              termSVG <-
                case renderBackend of
                  Just RenderBackend
RenderSVG -> TermT VarIdent
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     (Maybe String)
forall var. Eq var => TermT var -> TypeCheck var (Maybe String)
renderTermSVG (VarIdent -> TermT VarIdent
forall (t :: * -> * -> *) a. a -> FS t a
Pure (Maybe String -> VarIdent' BNFC'Position -> VarIdent
varIdentAt Maybe String
path VarIdent' BNFC'Position
name))
                  Just RenderBackend
RenderLaTeX -> TypeError VarIdent
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     (Maybe String)
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError VarIdent
 -> ReaderT
      (Context VarIdent)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
      (Maybe String))
-> TypeError VarIdent
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> TypeError VarIdent
forall var. String -> TypeError var
TypeErrorOther String
"\"latex\" rendering is not yet supported"
                  Maybe RenderBackend
Nothing -> Maybe String
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     (Maybe String)
forall a.
a
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
              maybe id trace termSVG $ do
                go (i + 1) moreCommands

    go  Integer
i (command :: Command
command@(Rzk.CommandPostulate BNFC'Position
_loc VarIdent' BNFC'Position
name (Rzk.DeclUsedVars BNFC'Position
_ [VarIdent' BNFC'Position]
vars) [Param' BNFC'Position]
params Term' BNFC'Position
ty) : [Command]
moreCommands) =
      Verbosity
-> String
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall var a.
Verbosity -> String -> TypeCheck var a -> TypeCheck var a
traceTypeCheck Verbosity
Normal (String
"[ " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
i String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" out of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
totalCommands String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" ]"
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" Checking #postulate " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> VarIdent' BNFC'Position -> String
forall a. Print a => a -> String
Rzk.printTree VarIdent' BNFC'Position
name) (TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
 -> TypeCheck
      VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a b. (a -> b) -> a -> b
$ do
        Command
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
withCommand Command
command (TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
 -> TypeCheck
      VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a b. (a -> b) -> a -> b
$ do
          (VarIdent
 -> ReaderT
      (Context VarIdent)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
      ())
-> [VarIdent]
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ VarIdent
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     ()
checkDefinedVar (Maybe String -> VarIdent' BNFC'Position -> VarIdent
varIdentAt Maybe String
path (VarIdent' BNFC'Position -> VarIdent)
-> [VarIdent' BNFC'Position] -> [VarIdent]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VarIdent' BNFC'Position]
vars)
          paramDecls <- [[ParamDecl]] -> [ParamDecl]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[ParamDecl]] -> [ParamDecl])
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     [[ParamDecl]]
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     [ParamDecl]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Param' BNFC'Position
 -> ReaderT
      (Context VarIdent)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
      [ParamDecl])
-> [Param' BNFC'Position]
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     [[ParamDecl]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Param' BNFC'Position
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     [ParamDecl]
forall var. Param' BNFC'Position -> TypeCheck var [ParamDecl]
paramToParamDecl [Param' BNFC'Position]
params
          ty' <- memoizeWHNF =<< typecheck (toTerm' (addParamDecls paramDecls ty)) universeT
          loc <- asks location
          let decl = VarIdent
-> TermT VarIdent
-> Maybe (TermT VarIdent)
-> Bool
-> [VarIdent]
-> Maybe LocationInfo
-> Decl'
forall var.
var
-> TermT var
-> Maybe (TermT var)
-> Bool
-> [var]
-> Maybe LocationInfo
-> Decl var
Decl (Maybe String -> VarIdent' BNFC'Position -> VarIdent
varIdentAt Maybe String
path VarIdent' BNFC'Position
name) TermT VarIdent
ty' Maybe (TermT VarIdent)
forall a. Maybe a
Nothing Bool
False (Maybe String -> VarIdent' BNFC'Position -> VarIdent
varIdentAt Maybe String
path (VarIdent' BNFC'Position -> VarIdent)
-> [VarIdent' BNFC'Position] -> [VarIdent]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VarIdent' BNFC'Position]
vars) Maybe LocationInfo
loc
          fmap (first (decl :)) $
            localDeclPrepared decl $
              go (i + 1) moreCommands

    go  Integer
i (command :: Command
command@(Rzk.CommandCheck BNFC'Position
_loc Term' BNFC'Position
term Term' BNFC'Position
ty) : [Command]
moreCommands) =
      Verbosity
-> String
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall var a.
Verbosity -> String -> TypeCheck var a -> TypeCheck var a
traceTypeCheck Verbosity
Normal (String
"[ " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
i String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" out of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
totalCommands String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" ]"
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" Checking " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term' BNFC'Position -> String
forall a. Print a => a -> String
Rzk.printTree Term' BNFC'Position
term String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" : " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term' BNFC'Position -> String
forall a. Print a => a -> String
Rzk.printTree Term' BNFC'Position
ty ) (TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
 -> TypeCheck
      VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a b. (a -> b) -> a -> b
$ do
        Command
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
withCommand Command
command (TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
 -> TypeCheck
      VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a b. (a -> b) -> a -> b
$ do
          ty' <- Term VarIdent
-> TermT VarIdent -> TypeCheck VarIdent (TermT VarIdent)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck (Term' BNFC'Position -> Term VarIdent
toTerm' Term' BNFC'Position
ty) TermT VarIdent
forall var. TermT var
universeT TypeCheck VarIdent (TermT VarIdent)
-> (TermT VarIdent -> TypeCheck VarIdent (TermT VarIdent))
-> TypeCheck VarIdent (TermT VarIdent)
forall a b.
ReaderT
  (Context VarIdent)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
  a
-> (a
    -> ReaderT
         (Context VarIdent)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
         b)
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TermT VarIdent -> TypeCheck VarIdent (TermT VarIdent)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT
          _term' <- typecheck (toTerm' term) ty'
          go (i + 1) moreCommands

    go  Integer
i (Rzk.CommandCompute BNFC'Position
loc Term' BNFC'Position
term : [Command]
moreCommands) =
      Integer
-> [Command]
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
go Integer
i (BNFC'Position -> Term' BNFC'Position -> Command
forall a. a -> Term' a -> Command' a
Rzk.CommandComputeWHNF BNFC'Position
loc Term' BNFC'Position
term Command -> [Command] -> [Command]
forall a. a -> [a] -> [a]
: [Command]
moreCommands)

    go  Integer
i (command :: Command
command@(Rzk.CommandComputeNF BNFC'Position
_loc Term' BNFC'Position
term) : [Command]
moreCommands) =
      Verbosity
-> String
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall var a.
Verbosity -> String -> TypeCheck var a -> TypeCheck var a
traceTypeCheck Verbosity
Normal (String
"[ " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
i String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" out of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
totalCommands String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" ]"
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" Computing NF for " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term' BNFC'Position -> String
forall a. Print a => a -> String
Rzk.printTree Term' BNFC'Position
term) (TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
 -> TypeCheck
      VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a b. (a -> b) -> a -> b
$ do
        Command
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
withCommand Command
command (TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
 -> TypeCheck
      VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a b. (a -> b) -> a -> b
$ do
          term' <- Term VarIdent -> TypeCheck VarIdent (TermT VarIdent)
forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer (Term' BNFC'Position -> Term VarIdent
toTerm' Term' BNFC'Position
term) TypeCheck VarIdent (TermT VarIdent)
-> (TermT VarIdent -> TypeCheck VarIdent (TermT VarIdent))
-> TypeCheck VarIdent (TermT VarIdent)
forall a b.
ReaderT
  (Context VarIdent)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
  a
-> (a
    -> ReaderT
         (Context VarIdent)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
         b)
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TermT VarIdent -> TypeCheck VarIdent (TermT VarIdent)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT
          traceTypeCheck Normal ("  " <> show (untyped term')) $ do
            go (i + 1) moreCommands

    go  Integer
i (command :: Command
command@(Rzk.CommandComputeWHNF BNFC'Position
_loc Term' BNFC'Position
term) : [Command]
moreCommands) =
      Verbosity
-> String
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall var a.
Verbosity -> String -> TypeCheck var a -> TypeCheck var a
traceTypeCheck Verbosity
Normal (String
"[ " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
i String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" out of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
totalCommands String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" ]"
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" Computing WHNF for " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term' BNFC'Position -> String
forall a. Print a => a -> String
Rzk.printTree Term' BNFC'Position
term) (TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
 -> TypeCheck
      VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a b. (a -> b) -> a -> b
$ do
        Command
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
withCommand Command
command (TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
 -> TypeCheck
      VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a b. (a -> b) -> a -> b
$ do
          term' <- Term VarIdent -> TypeCheck VarIdent (TermT VarIdent)
forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer (Term' BNFC'Position -> Term VarIdent
toTerm' Term' BNFC'Position
term) TypeCheck VarIdent (TermT VarIdent)
-> (TermT VarIdent -> TypeCheck VarIdent (TermT VarIdent))
-> TypeCheck VarIdent (TermT VarIdent)
forall a b.
ReaderT
  (Context VarIdent)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
  a
-> (a
    -> ReaderT
         (Context VarIdent)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
         b)
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TermT VarIdent -> TypeCheck VarIdent (TermT VarIdent)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT
          traceTypeCheck Normal ("  " <> show (untyped term')) $ do
            go (i + 1) moreCommands

    go  Integer
i (command :: Command
command@(Rzk.CommandAssume BNFC'Position
_loc [VarIdent' BNFC'Position]
names Term' BNFC'Position
ty) : [Command]
moreCommands) =
      Verbosity
-> String
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall var a.
Verbosity -> String -> TypeCheck var a -> TypeCheck var a
traceTypeCheck Verbosity
Normal (String
"[ " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
i String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" out of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
totalCommands String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" ]"
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" Checking #assume " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" " [ VarIdent' BNFC'Position -> String
forall a. Print a => a -> String
Rzk.printTree VarIdent' BNFC'Position
name | VarIdent' BNFC'Position
name <- [VarIdent' BNFC'Position]
names ] ) (TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
 -> TypeCheck
      VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a b. (a -> b) -> a -> b
$ do
        Command
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
withCommand Command
command (TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
 -> TypeCheck
      VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a b. (a -> b) -> a -> b
$ do
          ty' <- Term VarIdent
-> TermT VarIdent -> TypeCheck VarIdent (TermT VarIdent)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck (Term' BNFC'Position -> Term VarIdent
toTerm' Term' BNFC'Position
ty) TermT VarIdent
forall var. TermT var
universeT
          loc <- asks location
          let decls = [ VarIdent
-> TermT VarIdent
-> Maybe (TermT VarIdent)
-> Bool
-> [VarIdent]
-> Maybe LocationInfo
-> Decl'
forall var.
var
-> TermT var
-> Maybe (TermT var)
-> Bool
-> [var]
-> Maybe LocationInfo
-> Decl var
Decl (Maybe String -> VarIdent' BNFC'Position -> VarIdent
varIdentAt Maybe String
path VarIdent' BNFC'Position
name) TermT VarIdent
ty' Maybe (TermT VarIdent)
forall a. Maybe a
Nothing Bool
True [] Maybe LocationInfo
loc | VarIdent' BNFC'Position
name <- [VarIdent' BNFC'Position]
names ]
          fmap (first (decls <>)) $
            localDeclsPrepared decls $
              go (i + 1) moreCommands

    go  Integer
i (command :: Command
command@(Rzk.CommandSection BNFC'Position
_loc SectionName
name) : [Command]
moreCommands) = do
      Command
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
withCommand Command
command (TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
 -> TypeCheck
      VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a b. (a -> b) -> a -> b
$ do
        (sectionCommands, moreCommands') <- SectionName
-> [Command] -> TypeCheck VarIdent ([Command], [Command])
forall var.
SectionName -> [Command] -> TypeCheck var ([Command], [Command])
splitSectionCommands SectionName
name [Command]
moreCommands
        withSection (Just name) (go i sectionCommands) $ do
          go (i + countCommands sectionCommands) moreCommands'

    go  Integer
_i (command :: Command
command@(Rzk.CommandSectionEnd BNFC'Position
_loc SectionName
endName) : [Command]
_moreCommands) = do
      Command
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
withCommand Command
command (TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
 -> TypeCheck
      VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a b. (a -> b) -> a -> b
$
        TypeError VarIdent
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError VarIdent
 -> TypeCheck
      VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> TypeError VarIdent
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a b. (a -> b) -> a -> b
$ String -> TypeError VarIdent
forall var. String -> TypeError var
TypeErrorOther (String -> TypeError VarIdent) -> String -> TypeError VarIdent
forall a b. (a -> b) -> a -> b
$
          String
"unexpected #end " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SectionName -> String
forall a. Print a => a -> String
Rzk.printTree SectionName
endName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", no section was declared!"


splitSectionCommands :: Rzk.SectionName -> [Rzk.Command] -> TypeCheck var ([Rzk.Command], [Rzk.Command])
splitSectionCommands :: forall var.
SectionName -> [Command] -> TypeCheck var ([Command], [Command])
splitSectionCommands SectionName
name [] =
  TypeError var -> TypeCheck var ([Command], [Command])
forall var a. TypeError var -> TypeCheck var a
issueTypeError (String -> TypeError var
forall var. String -> TypeError var
TypeErrorOther (String -> TypeError var) -> String -> TypeError var
forall a b. (a -> b) -> a -> b
$ String
"Section " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SectionName -> String
forall a. Print a => a -> String
Rzk.printTree SectionName
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is not closed with an #end")
splitSectionCommands SectionName
name (Rzk.CommandSection BNFC'Position
_loc SectionName
name' : [Command]
moreCommands) = do
  (cs1, cs2) <- SectionName -> [Command] -> TypeCheck var ([Command], [Command])
forall var.
SectionName -> [Command] -> TypeCheck var ([Command], [Command])
splitSectionCommands SectionName
name' [Command]
moreCommands
  (cs3, cs4) <- splitSectionCommands name cs2
  return (cs1 <> cs3, cs4)
splitSectionCommands SectionName
name (Rzk.CommandSectionEnd BNFC'Position
_loc SectionName
endName : [Command]
moreCommands) = do
  Bool
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     ()
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SectionName -> String
forall a. Print a => a -> String
Rzk.printTree SectionName
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= SectionName -> String
forall a. Print a => a -> String
Rzk.printTree SectionName
endName) (ReaderT
   (Context var)
   (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
   ()
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      ())
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     ()
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     ()
forall a b. (a -> b) -> a -> b
$
    TypeError var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     ()
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      ())
-> TypeError var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     ()
forall a b. (a -> b) -> a -> b
$ String -> TypeError var
forall var. String -> TypeError var
TypeErrorOther (String -> TypeError var) -> String -> TypeError var
forall a b. (a -> b) -> a -> b
$
      String
"unexpected #end " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SectionName -> String
forall a. Print a => a -> String
Rzk.printTree SectionName
endName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", expecting #end " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SectionName -> String
forall a. Print a => a -> String
Rzk.printTree SectionName
name
  ([Command], [Command]) -> TypeCheck var ([Command], [Command])
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [Command]
moreCommands)
splitSectionCommands SectionName
name (Command
command : [Command]
moreCommands) = do
  (cs1, cs2) <- SectionName -> [Command] -> TypeCheck var ([Command], [Command])
forall var.
SectionName -> [Command] -> TypeCheck var ([Command], [Command])
splitSectionCommands SectionName
name [Command]
moreCommands
  return (command : cs1, cs2)

setOption :: String -> String -> TypeCheck var a -> TypeCheck var a
setOption :: forall var a.
String -> String -> TypeCheck var a -> TypeCheck var a
setOption String
"verbosity" = \case
  String
"debug"   -> Verbosity -> TypeCheck var a -> TypeCheck var a
forall var a. Verbosity -> TypeCheck var a -> TypeCheck var a
localVerbosity Verbosity
Debug
  String
"normal"  -> Verbosity -> TypeCheck var a -> TypeCheck var a
forall var a. Verbosity -> TypeCheck var a -> TypeCheck var a
localVerbosity Verbosity
Normal
  String
"silent"  -> Verbosity -> TypeCheck var a -> TypeCheck var a
forall var a. Verbosity -> TypeCheck var a -> TypeCheck var a
localVerbosity Verbosity
Silent
  String
_ -> TypeCheck var a -> TypeCheck var a -> TypeCheck var a
forall a b. a -> b -> a
const (TypeCheck var a -> TypeCheck var a -> TypeCheck var a)
-> TypeCheck var a -> TypeCheck var a -> TypeCheck var a
forall a b. (a -> b) -> a -> b
$
    TypeError var -> TypeCheck var a
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var -> TypeCheck var a)
-> TypeError var -> TypeCheck var a
forall a b. (a -> b) -> a -> b
$ String -> TypeError var
forall var. String -> TypeError var
TypeErrorOther String
"unknown verbosity level (use \"debug\", \"normal\", or \"silent\")"
setOption String
"render" = \case
  String
"svg"   -> Maybe RenderBackend -> TypeCheck var a -> TypeCheck var a
forall var a.
Maybe RenderBackend -> TypeCheck var a -> TypeCheck var a
localRenderBackend (RenderBackend -> Maybe RenderBackend
forall a. a -> Maybe a
Just RenderBackend
RenderSVG)
  String
"latex" -> Maybe RenderBackend -> TypeCheck var a -> TypeCheck var a
forall var a.
Maybe RenderBackend -> TypeCheck var a -> TypeCheck var a
localRenderBackend (RenderBackend -> Maybe RenderBackend
forall a. a -> Maybe a
Just RenderBackend
RenderLaTeX)
  String
"none"  -> Maybe RenderBackend -> TypeCheck var a -> TypeCheck var a
forall var a.
Maybe RenderBackend -> TypeCheck var a -> TypeCheck var a
localRenderBackend Maybe RenderBackend
forall a. Maybe a
Nothing
  String
_ -> TypeCheck var a -> TypeCheck var a -> TypeCheck var a
forall a b. a -> b -> a
const (TypeCheck var a -> TypeCheck var a -> TypeCheck var a)
-> TypeCheck var a -> TypeCheck var a -> TypeCheck var a
forall a b. (a -> b) -> a -> b
$
    TypeError var -> TypeCheck var a
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var -> TypeCheck var a)
-> TypeError var -> TypeCheck var a
forall a b. (a -> b) -> a -> b
$ String -> TypeError var
forall var. String -> TypeError var
TypeErrorOther String
"unknown render backend (use \"svg\", \"latex\", or \"none\")"
-- | Render the shape only, hiding the proof term (drop the @\<title\>@
-- everywhere and blank interior labels), so a worked term can be shown as the
-- cell it builds without giving the term away (see 'renderHideTerm').
setOption String
"render-hide-term" = \case
  String
"yes" -> Bool -> TypeCheck var a -> TypeCheck var a
forall var a. Bool -> TypeCheck var a -> TypeCheck var a
localHideTerm Bool
True
  String
"no"  -> Bool -> TypeCheck var a -> TypeCheck var a
forall var a. Bool -> TypeCheck var a -> TypeCheck var a
localHideTerm Bool
False
  String
_ -> TypeCheck var a -> TypeCheck var a -> TypeCheck var a
forall a b. a -> b -> a
const (TypeCheck var a -> TypeCheck var a -> TypeCheck var a)
-> TypeCheck var a -> TypeCheck var a -> TypeCheck var a
forall a b. (a -> b) -> a -> b
$
    TypeError var -> TypeCheck var a
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var -> TypeCheck var a)
-> TypeError var -> TypeCheck var a
forall a b. (a -> b) -> a -> b
$ String -> TypeError var
forall var. String -> TypeError var
TypeErrorOther String
"unknown value for \"render-hide-term\" (use \"yes\" or \"no\")"
setOption String
optionName = (TypeCheck var a -> TypeCheck var a)
-> String -> TypeCheck var a -> TypeCheck var a
forall a b. a -> b -> a
const ((TypeCheck var a -> TypeCheck var a)
 -> String -> TypeCheck var a -> TypeCheck var a)
-> (TypeCheck var a -> TypeCheck var a)
-> String
-> TypeCheck var a
-> TypeCheck var a
forall a b. (a -> b) -> a -> b
$ TypeCheck var a -> TypeCheck var a -> TypeCheck var a
forall a b. a -> b -> a
const (TypeCheck var a -> TypeCheck var a -> TypeCheck var a)
-> TypeCheck var a -> TypeCheck var a -> TypeCheck var a
forall a b. (a -> b) -> a -> b
$
  TypeError var -> TypeCheck var a
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var -> TypeCheck var a)
-> TypeError var -> TypeCheck var a
forall a b. (a -> b) -> a -> b
$ String -> TypeError var
forall var. String -> TypeError var
TypeErrorOther (String
"unknown option " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
optionName)

unsetOption :: String -> TypeCheck var a -> TypeCheck var a
unsetOption :: forall var a. String -> TypeCheck var a -> TypeCheck var a
unsetOption String
"verbosity" = Verbosity -> TypeCheck var a -> TypeCheck var a
forall var a. Verbosity -> TypeCheck var a -> TypeCheck var a
localVerbosity (Context (ZonkAny 0) -> Verbosity
forall var. Context var -> Verbosity
verbosity Context (ZonkAny 0)
forall var. Context var
emptyContext)
unsetOption String
"render" = Maybe RenderBackend -> TypeCheck var a -> TypeCheck var a
forall var a.
Maybe RenderBackend -> TypeCheck var a -> TypeCheck var a
localRenderBackend (Context (ZonkAny 1) -> Maybe RenderBackend
forall var. Context var -> Maybe RenderBackend
renderBackend Context (ZonkAny 1)
forall var. Context var
emptyContext)
unsetOption String
"render-hide-term" = Bool -> TypeCheck var a -> TypeCheck var a
forall var a. Bool -> TypeCheck var a -> TypeCheck var a
localHideTerm (Context (ZonkAny 2) -> Bool
forall var. Context var -> Bool
renderHideTerm Context (ZonkAny 2)
forall var. Context var
emptyContext)
unsetOption String
optionName = TypeCheck var a -> TypeCheck var a -> TypeCheck var a
forall a b. a -> b -> a
const (TypeCheck var a -> TypeCheck var a -> TypeCheck var a)
-> TypeCheck var a -> TypeCheck var a -> TypeCheck var a
forall a b. (a -> b) -> a -> b
$
  TypeError var -> TypeCheck var a
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var -> TypeCheck var a)
-> TypeError var -> TypeCheck var a
forall a b. (a -> b) -> a -> b
$ String -> TypeError var
forall var. String -> TypeError var
TypeErrorOther (String
"unknown option " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
optionName)

paramToParamDecl :: Rzk.Param -> TypeCheck var [Rzk.ParamDecl]
paramToParamDecl :: forall var. Param' BNFC'Position -> TypeCheck var [ParamDecl]
paramToParamDecl (Rzk.ParamPatternShapeDeprecated BNFC'Position
loc Pattern' BNFC'Position
pat Term' BNFC'Position
cube Term' BNFC'Position
tope) = [ParamDecl]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [ParamDecl]
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  [ BNFC'Position
-> Term' BNFC'Position
-> Term' BNFC'Position
-> Term' BNFC'Position
-> ParamDecl
forall a. a -> Term' a -> Term' a -> Term' a -> ParamDecl' a
Rzk.ParamTermShape BNFC'Position
loc (Pattern' BNFC'Position -> Term' BNFC'Position
patternToTerm Pattern' BNFC'Position
pat) Term' BNFC'Position
cube Term' BNFC'Position
tope ]
paramToParamDecl (Rzk.ParamPatternShape BNFC'Position
loc [Pattern' BNFC'Position]
pats Term' BNFC'Position
cube Term' BNFC'Position
tope) = [ParamDecl]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [ParamDecl]
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  [ BNFC'Position
-> Term' BNFC'Position
-> Term' BNFC'Position
-> Term' BNFC'Position
-> ParamDecl
forall a. a -> Term' a -> Term' a -> Term' a -> ParamDecl' a
Rzk.ParamTermShape BNFC'Position
loc (Pattern' BNFC'Position -> Term' BNFC'Position
patternToTerm Pattern' BNFC'Position
pat) Term' BNFC'Position
cube Term' BNFC'Position
tope | Pattern' BNFC'Position
pat <- [Pattern' BNFC'Position]
pats]
paramToParamDecl (Rzk.ParamPatternType BNFC'Position
loc [Pattern' BNFC'Position]
pats Term' BNFC'Position
ty) = [ParamDecl]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [ParamDecl]
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  [ BNFC'Position
-> Term' BNFC'Position -> Term' BNFC'Position -> ParamDecl
forall a. a -> Term' a -> Term' a -> ParamDecl' a
Rzk.ParamTermType BNFC'Position
loc (Pattern' BNFC'Position -> Term' BNFC'Position
patternToTerm Pattern' BNFC'Position
pat) Term' BNFC'Position
ty | Pattern' BNFC'Position
pat <- [Pattern' BNFC'Position]
pats ]
paramToParamDecl Rzk.ParamPattern{} = TypeError var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [ParamDecl]
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      [ParamDecl])
-> TypeError var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [ParamDecl]
forall a b. (a -> b) -> a -> b
$
  String -> TypeError var
forall var. String -> TypeError var
TypeErrorOther String
"untyped pattern in parameters"
paramToParamDecl (Rzk.ParamPatternModalType BNFC'Position
loc [Pattern' BNFC'Position]
pats ModalColon' BNFC'Position
mc Term' BNFC'Position
ty) = [ParamDecl]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [ParamDecl]
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  [ BNFC'Position
-> Term' BNFC'Position
-> ModalColon' BNFC'Position
-> Term' BNFC'Position
-> ParamDecl
forall a. a -> Term' a -> ModalColon' a -> Term' a -> ParamDecl' a
Rzk.ParamTermModalType BNFC'Position
loc (Pattern' BNFC'Position -> Term' BNFC'Position
patternToTerm Pattern' BNFC'Position
pat) ModalColon' BNFC'Position
mc Term' BNFC'Position
ty | Pattern' BNFC'Position
pat <- [Pattern' BNFC'Position]
pats ]
paramToParamDecl (Rzk.ParamPatternModalShape BNFC'Position
loc [Pattern' BNFC'Position]
pats ModalColon' BNFC'Position
mc Term' BNFC'Position
cube Term' BNFC'Position
tope) = [ParamDecl]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [ParamDecl]
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  [ BNFC'Position
-> Term' BNFC'Position
-> ModalColon' BNFC'Position
-> Term' BNFC'Position
-> Term' BNFC'Position
-> ParamDecl
forall a.
a -> Term' a -> ModalColon' a -> Term' a -> Term' a -> ParamDecl' a
Rzk.ParamTermModalShape BNFC'Position
loc (Pattern' BNFC'Position -> Term' BNFC'Position
patternToTerm Pattern' BNFC'Position
pat) ModalColon' BNFC'Position
mc Term' BNFC'Position
cube Term' BNFC'Position
tope | Pattern' BNFC'Position
pat <- [Pattern' BNFC'Position]
pats ]

addParamDecls :: [Rzk.ParamDecl] -> Rzk.Term -> Rzk.Term
addParamDecls :: [ParamDecl] -> Term' BNFC'Position -> Term' BNFC'Position
addParamDecls [] = Term' BNFC'Position -> Term' BNFC'Position
forall a. a -> a
id
addParamDecls (ParamDecl
paramDecl : [ParamDecl]
paramDecls)
  = BNFC'Position
-> ParamDecl -> Term' BNFC'Position -> Term' BNFC'Position
forall a. a -> ParamDecl' a -> Term' a -> Term' a
Rzk.TypeFun BNFC'Position
forall a. Maybe a
Nothing ParamDecl
paramDecl (Term' BNFC'Position -> Term' BNFC'Position)
-> (Term' BNFC'Position -> Term' BNFC'Position)
-> Term' BNFC'Position
-> Term' BNFC'Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ParamDecl] -> Term' BNFC'Position -> Term' BNFC'Position
addParamDecls [ParamDecl]
paramDecls

addParams :: [Rzk.Param] -> Rzk.Term -> Rzk.Term
addParams :: [Param' BNFC'Position]
-> Term' BNFC'Position -> Term' BNFC'Position
addParams []     = Term' BNFC'Position -> Term' BNFC'Position
forall a. a -> a
id
addParams [Param' BNFC'Position]
params = BNFC'Position
-> [Param' BNFC'Position]
-> Term' BNFC'Position
-> Term' BNFC'Position
forall a. a -> [Param' a] -> Term' a -> Term' a
Rzk.Lambda BNFC'Position
forall a. Maybe a
Nothing [Param' BNFC'Position]
params

data TypeError var
  = TypeErrorOther String
  | TypeErrorUnify (TermT var) (TermT var) (TermT var)
  | TypeErrorUnifyTerms (TermT var) (TermT var)
  | TypeErrorNotPair (TermT var) (TermT var)
  | TypeErrorNotModal (Term var) TModality (TermT var)
  | TypeErrorModalityMismatch TModality TModality (Term var)
  | TypeErrorUnaccessibleVar var TModality TModality
  | TypeErrorNotTypeInModal (TermT var)
  | TypeErrorNotFunction (TermT var) (TermT var)
  | TypeErrorUnexpectedLambda (Term var) (TermT var)
  | TypeErrorUnexpectedPair (Term var) (TermT var)
  | TypeErrorUnexpectedRefl (Term var) (TermT var)
  | TypeErrorCannotInferBareLambda (Term var)
  | TypeErrorCannotInferBareRefl (Term var)
  | TypeErrorCannotInferHole (Term var)
  | TypeErrorUnsolvedHole (Maybe VarIdent) (TermT var)
  | TypeErrorUndefined var
  | TypeErrorTopeNotSatisfied [TermT var] (TermT var)
  | TypeErrorTopeContextDisjoint (TermT var) [TermT var]
  | TypeErrorTopesNotEquivalent (TermT var) (TermT var)
  | TypeErrorInvalidArgumentType (Term var) (TermT var)
  | TypeErrorDuplicateTopLevel [VarIdent] VarIdent
  | TypeErrorUnusedVariable var (TermT var)
  | TypeErrorUnusedUsedVariables [var] var
  | TypeErrorImplicitAssumption (var, TermT var) var
  deriving ((forall a b. (a -> b) -> TypeError a -> TypeError b)
-> (forall a b. a -> TypeError b -> TypeError a)
-> Functor TypeError
forall a b. a -> TypeError b -> TypeError a
forall a b. (a -> b) -> TypeError a -> TypeError b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> TypeError a -> TypeError b
fmap :: forall a b. (a -> b) -> TypeError a -> TypeError b
$c<$ :: forall a b. a -> TypeError b -> TypeError a
<$ :: forall a b. a -> TypeError b -> TypeError a
Functor, (forall m. Monoid m => TypeError m -> m)
-> (forall m a. Monoid m => (a -> m) -> TypeError a -> m)
-> (forall m a. Monoid m => (a -> m) -> TypeError a -> m)
-> (forall a b. (a -> b -> b) -> b -> TypeError a -> b)
-> (forall a b. (a -> b -> b) -> b -> TypeError a -> b)
-> (forall b a. (b -> a -> b) -> b -> TypeError a -> b)
-> (forall b a. (b -> a -> b) -> b -> TypeError a -> b)
-> (forall a. (a -> a -> a) -> TypeError a -> a)
-> (forall a. (a -> a -> a) -> TypeError a -> a)
-> (forall a. TypeError a -> [a])
-> (forall a. TypeError a -> Bool)
-> (forall a. TypeError a -> Int)
-> (forall a. Eq a => a -> TypeError a -> Bool)
-> (forall a. Ord a => TypeError a -> a)
-> (forall a. Ord a => TypeError a -> a)
-> (forall a. Num a => TypeError a -> a)
-> (forall a. Num a => TypeError a -> a)
-> Foldable TypeError
forall a. Eq a => a -> TypeError a -> Bool
forall a. Num a => TypeError a -> a
forall a. Ord a => TypeError a -> a
forall m. Monoid m => TypeError m -> m
forall a. TypeError a -> Bool
forall a. TypeError a -> Int
forall a. TypeError a -> [a]
forall a. (a -> a -> a) -> TypeError a -> a
forall m a. Monoid m => (a -> m) -> TypeError a -> m
forall b a. (b -> a -> b) -> b -> TypeError a -> b
forall a b. (a -> b -> b) -> b -> TypeError a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => TypeError m -> m
fold :: forall m. Monoid m => TypeError m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> TypeError a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> TypeError a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> TypeError a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> TypeError a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> TypeError a -> b
foldr :: forall a b. (a -> b -> b) -> b -> TypeError a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> TypeError a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> TypeError a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> TypeError a -> b
foldl :: forall b a. (b -> a -> b) -> b -> TypeError a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> TypeError a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> TypeError a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> TypeError a -> a
foldr1 :: forall a. (a -> a -> a) -> TypeError a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> TypeError a -> a
foldl1 :: forall a. (a -> a -> a) -> TypeError a -> a
$ctoList :: forall a. TypeError a -> [a]
toList :: forall a. TypeError a -> [a]
$cnull :: forall a. TypeError a -> Bool
null :: forall a. TypeError a -> Bool
$clength :: forall a. TypeError a -> Int
length :: forall a. TypeError a -> Int
$celem :: forall a. Eq a => a -> TypeError a -> Bool
elem :: forall a. Eq a => a -> TypeError a -> Bool
$cmaximum :: forall a. Ord a => TypeError a -> a
maximum :: forall a. Ord a => TypeError a -> a
$cminimum :: forall a. Ord a => TypeError a -> a
minimum :: forall a. Ord a => TypeError a -> a
$csum :: forall a. Num a => TypeError a -> a
sum :: forall a. Num a => TypeError a -> a
$cproduct :: forall a. Num a => TypeError a -> a
product :: forall a. Num a => TypeError a -> a
Foldable)

data TypeErrorInContext var = TypeErrorInContext
  { forall var. TypeErrorInContext var -> TypeError var
typeErrorError   :: TypeError var
  , forall var. TypeErrorInContext var -> Context var
typeErrorContext :: Context var
  } deriving ((forall a b.
 (a -> b) -> TypeErrorInContext a -> TypeErrorInContext b)
-> (forall a b. a -> TypeErrorInContext b -> TypeErrorInContext a)
-> Functor TypeErrorInContext
forall a b. a -> TypeErrorInContext b -> TypeErrorInContext a
forall a b.
(a -> b) -> TypeErrorInContext a -> TypeErrorInContext b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b.
(a -> b) -> TypeErrorInContext a -> TypeErrorInContext b
fmap :: forall a b.
(a -> b) -> TypeErrorInContext a -> TypeErrorInContext b
$c<$ :: forall a b. a -> TypeErrorInContext b -> TypeErrorInContext a
<$ :: forall a b. a -> TypeErrorInContext b -> TypeErrorInContext a
Functor, (forall m. Monoid m => TypeErrorInContext m -> m)
-> (forall m a. Monoid m => (a -> m) -> TypeErrorInContext a -> m)
-> (forall m a. Monoid m => (a -> m) -> TypeErrorInContext a -> m)
-> (forall a b. (a -> b -> b) -> b -> TypeErrorInContext a -> b)
-> (forall a b. (a -> b -> b) -> b -> TypeErrorInContext a -> b)
-> (forall b a. (b -> a -> b) -> b -> TypeErrorInContext a -> b)
-> (forall b a. (b -> a -> b) -> b -> TypeErrorInContext a -> b)
-> (forall a. (a -> a -> a) -> TypeErrorInContext a -> a)
-> (forall a. (a -> a -> a) -> TypeErrorInContext a -> a)
-> (forall a. TypeErrorInContext a -> [a])
-> (forall a. TypeErrorInContext a -> Bool)
-> (forall a. TypeErrorInContext a -> Int)
-> (forall a. Eq a => a -> TypeErrorInContext a -> Bool)
-> (forall a. Ord a => TypeErrorInContext a -> a)
-> (forall a. Ord a => TypeErrorInContext a -> a)
-> (forall a. Num a => TypeErrorInContext a -> a)
-> (forall a. Num a => TypeErrorInContext a -> a)
-> Foldable TypeErrorInContext
forall a. Eq a => a -> TypeErrorInContext a -> Bool
forall a. Num a => TypeErrorInContext a -> a
forall a. Ord a => TypeErrorInContext a -> a
forall m. Monoid m => TypeErrorInContext m -> m
forall a. TypeErrorInContext a -> Bool
forall a. TypeErrorInContext a -> Int
forall a. TypeErrorInContext a -> [a]
forall a. (a -> a -> a) -> TypeErrorInContext a -> a
forall m a. Monoid m => (a -> m) -> TypeErrorInContext a -> m
forall b a. (b -> a -> b) -> b -> TypeErrorInContext a -> b
forall a b. (a -> b -> b) -> b -> TypeErrorInContext a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => TypeErrorInContext m -> m
fold :: forall m. Monoid m => TypeErrorInContext m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> TypeErrorInContext a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> TypeErrorInContext a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> TypeErrorInContext a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> TypeErrorInContext a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> TypeErrorInContext a -> b
foldr :: forall a b. (a -> b -> b) -> b -> TypeErrorInContext a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> TypeErrorInContext a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> TypeErrorInContext a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> TypeErrorInContext a -> b
foldl :: forall b a. (b -> a -> b) -> b -> TypeErrorInContext a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> TypeErrorInContext a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> TypeErrorInContext a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> TypeErrorInContext a -> a
foldr1 :: forall a. (a -> a -> a) -> TypeErrorInContext a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> TypeErrorInContext a -> a
foldl1 :: forall a. (a -> a -> a) -> TypeErrorInContext a -> a
$ctoList :: forall a. TypeErrorInContext a -> [a]
toList :: forall a. TypeErrorInContext a -> [a]
$cnull :: forall a. TypeErrorInContext a -> Bool
null :: forall a. TypeErrorInContext a -> Bool
$clength :: forall a. TypeErrorInContext a -> Int
length :: forall a. TypeErrorInContext a -> Int
$celem :: forall a. Eq a => a -> TypeErrorInContext a -> Bool
elem :: forall a. Eq a => a -> TypeErrorInContext a -> Bool
$cmaximum :: forall a. Ord a => TypeErrorInContext a -> a
maximum :: forall a. Ord a => TypeErrorInContext a -> a
$cminimum :: forall a. Ord a => TypeErrorInContext a -> a
minimum :: forall a. Ord a => TypeErrorInContext a -> a
$csum :: forall a. Num a => TypeErrorInContext a -> a
sum :: forall a. Num a => TypeErrorInContext a -> a
$cproduct :: forall a. Num a => TypeErrorInContext a -> a
product :: forall a. Num a => TypeErrorInContext a -> a
Foldable)

data TypeErrorInScopedContext var
  = PlainTypeError (TypeErrorInContext var)
  | ScopedTypeError (Maybe VarIdent) (TypeErrorInScopedContext (Inc var))
  deriving ((forall a b.
 (a -> b)
 -> TypeErrorInScopedContext a -> TypeErrorInScopedContext b)
-> (forall a b.
    a -> TypeErrorInScopedContext b -> TypeErrorInScopedContext a)
-> Functor TypeErrorInScopedContext
forall a b.
a -> TypeErrorInScopedContext b -> TypeErrorInScopedContext a
forall a b.
(a -> b)
-> TypeErrorInScopedContext a -> TypeErrorInScopedContext b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b.
(a -> b)
-> TypeErrorInScopedContext a -> TypeErrorInScopedContext b
fmap :: forall a b.
(a -> b)
-> TypeErrorInScopedContext a -> TypeErrorInScopedContext b
$c<$ :: forall a b.
a -> TypeErrorInScopedContext b -> TypeErrorInScopedContext a
<$ :: forall a b.
a -> TypeErrorInScopedContext b -> TypeErrorInScopedContext a
Functor, (forall m. Monoid m => TypeErrorInScopedContext m -> m)
-> (forall m a.
    Monoid m =>
    (a -> m) -> TypeErrorInScopedContext a -> m)
-> (forall m a.
    Monoid m =>
    (a -> m) -> TypeErrorInScopedContext a -> m)
-> (forall a b.
    (a -> b -> b) -> b -> TypeErrorInScopedContext a -> b)
-> (forall a b.
    (a -> b -> b) -> b -> TypeErrorInScopedContext a -> b)
-> (forall b a.
    (b -> a -> b) -> b -> TypeErrorInScopedContext a -> b)
-> (forall b a.
    (b -> a -> b) -> b -> TypeErrorInScopedContext a -> b)
-> (forall a. (a -> a -> a) -> TypeErrorInScopedContext a -> a)
-> (forall a. (a -> a -> a) -> TypeErrorInScopedContext a -> a)
-> (forall a. TypeErrorInScopedContext a -> [a])
-> (forall a. TypeErrorInScopedContext a -> Bool)
-> (forall a. TypeErrorInScopedContext a -> Int)
-> (forall a. Eq a => a -> TypeErrorInScopedContext a -> Bool)
-> (forall a. Ord a => TypeErrorInScopedContext a -> a)
-> (forall a. Ord a => TypeErrorInScopedContext a -> a)
-> (forall a. Num a => TypeErrorInScopedContext a -> a)
-> (forall a. Num a => TypeErrorInScopedContext a -> a)
-> Foldable TypeErrorInScopedContext
forall a. Eq a => a -> TypeErrorInScopedContext a -> Bool
forall a. Num a => TypeErrorInScopedContext a -> a
forall a. Ord a => TypeErrorInScopedContext a -> a
forall m. Monoid m => TypeErrorInScopedContext m -> m
forall a. TypeErrorInScopedContext a -> Bool
forall a. TypeErrorInScopedContext a -> Int
forall a. TypeErrorInScopedContext a -> [a]
forall a. (a -> a -> a) -> TypeErrorInScopedContext a -> a
forall m a. Monoid m => (a -> m) -> TypeErrorInScopedContext a -> m
forall b a. (b -> a -> b) -> b -> TypeErrorInScopedContext a -> b
forall a b. (a -> b -> b) -> b -> TypeErrorInScopedContext a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => TypeErrorInScopedContext m -> m
fold :: forall m. Monoid m => TypeErrorInScopedContext m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> TypeErrorInScopedContext a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> TypeErrorInScopedContext a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> TypeErrorInScopedContext a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> TypeErrorInScopedContext a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> TypeErrorInScopedContext a -> b
foldr :: forall a b. (a -> b -> b) -> b -> TypeErrorInScopedContext a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> TypeErrorInScopedContext a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> TypeErrorInScopedContext a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> TypeErrorInScopedContext a -> b
foldl :: forall b a. (b -> a -> b) -> b -> TypeErrorInScopedContext a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> TypeErrorInScopedContext a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> TypeErrorInScopedContext a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> TypeErrorInScopedContext a -> a
foldr1 :: forall a. (a -> a -> a) -> TypeErrorInScopedContext a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> TypeErrorInScopedContext a -> a
foldl1 :: forall a. (a -> a -> a) -> TypeErrorInScopedContext a -> a
$ctoList :: forall a. TypeErrorInScopedContext a -> [a]
toList :: forall a. TypeErrorInScopedContext a -> [a]
$cnull :: forall a. TypeErrorInScopedContext a -> Bool
null :: forall a. TypeErrorInScopedContext a -> Bool
$clength :: forall a. TypeErrorInScopedContext a -> Int
length :: forall a. TypeErrorInScopedContext a -> Int
$celem :: forall a. Eq a => a -> TypeErrorInScopedContext a -> Bool
elem :: forall a. Eq a => a -> TypeErrorInScopedContext a -> Bool
$cmaximum :: forall a. Ord a => TypeErrorInScopedContext a -> a
maximum :: forall a. Ord a => TypeErrorInScopedContext a -> a
$cminimum :: forall a. Ord a => TypeErrorInScopedContext a -> a
minimum :: forall a. Ord a => TypeErrorInScopedContext a -> a
$csum :: forall a. Num a => TypeErrorInScopedContext a -> a
sum :: forall a. Num a => TypeErrorInScopedContext a -> a
$cproduct :: forall a. Num a => TypeErrorInScopedContext a -> a
product :: forall a. Num a => TypeErrorInScopedContext a -> a
Foldable)

type TypeError' = TypeError VarIdent

ppModality :: TModality -> String
ppModality :: TModality -> String
ppModality = \case
  TModality
Flat  -> String
"♭"
  TModality
Sharp -> String
"♯"
  TModality
Op    -> String
"ᵒᵖ"
  TModality
Id    -> String
"_id"

-- | Render a type error, folding pattern-binder projections (e.g. @π₁ x@ back to
-- the user's @t@) and showing a bare pattern point as the pattern, using the
-- context's freshened binders (see 'contextBinders').
ppTypeError' :: [(VarIdent, Binder)] -> TypeError' -> String
ppTypeError' :: [(VarIdent, Binder)] -> TypeError VarIdent -> String
ppTypeError' [(VarIdent, Binder)]
fbs = \case
  TypeErrorOther String
msg -> String
msg
  TypeErrorUnify TermT VarIdent
term TermT VarIdent
expected TermT VarIdent
actual -> OutputDirection -> [String] -> String
block OutputDirection
TopDown
    [ String
"cannot unify expected type"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
expected)
    , String
"with actual type"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
actual)
    , String
"for term"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
term) ]
  TypeErrorUnifyTerms TermT VarIdent
expected TermT VarIdent
actual -> OutputDirection -> [String] -> String
block OutputDirection
TopDown
    [ String
"cannot unify term"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
expected)
    , String
"with term"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
actual) ]
  TypeErrorNotPair TermT VarIdent
term TermT VarIdent
ty -> OutputDirection -> [String] -> String
block OutputDirection
TopDown
    [ String
"expected a cube product or dependent pair"
    , String
"but got type"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
ty)
    , String
"for term"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
term)
    , case TermT VarIdent
ty of
        TypeFunT{} -> String
"\nPerhaps the term is applied to too few arguments?"
        TermT VarIdent
_          -> String
""
    ]
  TypeErrorNotModal Term VarIdent
term TModality
m TermT VarIdent
ty -> OutputDirection -> [String] -> String
block OutputDirection
TopDown
    [ String
"expected modal type " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TModality -> String
ppModality TModality
m String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" ?"
    , String
"but got type"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
ty)
    , String
"for term"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU Term VarIdent
term
    ]
  TypeErrorModalityMismatch TModality
expected TModality
actual Term VarIdent
term -> OutputDirection -> [String] -> String
block OutputDirection
TopDown
    [ String
"modality mismatch"
    , String
"  expected " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TModality -> String
ppModality TModality
expected
    , String
"  but got  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TModality -> String
ppModality TModality
actual
    , String
"for term"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU Term VarIdent
term
    ]
  TypeErrorUnaccessibleVar VarIdent
_var TModality
varMod TModality
locks -> OutputDirection -> [String] -> String
block OutputDirection
TopDown
    [ String
"unaccessible var with modality " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TModality -> String
ppModality TModality
varMod
    , String
"  under locks " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TModality -> String
ppModality TModality
locks
    ]
  TypeErrorNotTypeInModal TermT VarIdent
ty -> OutputDirection -> [String] -> String
block OutputDirection
TopDown
    [ String
"expected a type inside modal type"
    , String
"but got"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
ty)
    ]

  TypeErrorUnexpectedLambda Term VarIdent
term TermT VarIdent
ty -> OutputDirection -> [String] -> String
block OutputDirection
TopDown
    [ String
"unexpected lambda abstraction"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU Term VarIdent
term
    , String
"when typechecking against a non-function type"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TermT VarIdent -> String
ppTyped TermT VarIdent
ty
    ]
  TypeErrorUnexpectedPair Term VarIdent
term TermT VarIdent
ty -> OutputDirection -> [String] -> String
block OutputDirection
TopDown
    [ String
"unexpected pair"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU Term VarIdent
term
    , String
"when typechecking against a type that is not a product or a dependent sum"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TermT VarIdent -> String
ppTyped TermT VarIdent
ty
    ]
  TypeErrorUnexpectedRefl Term VarIdent
term TermT VarIdent
ty -> OutputDirection -> [String] -> String
block OutputDirection
TopDown
    [ String
"unexpected refl"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU Term VarIdent
term
    , String
"when typechecking against a type that is not an identity type"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TermT VarIdent -> String
ppTyped TermT VarIdent
ty
    ]

  TypeErrorNotFunction TermT VarIdent
term TermT VarIdent
ty -> OutputDirection -> [String] -> String
block OutputDirection
TopDown
    [ String
"expected a function or extension type"
    , String
"but got type"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
ty)
    , String
"for term"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
term)
    , case TermT VarIdent
term of
        AppT TypeInfo (TermT VarIdent)
_ty TermT VarIdent
f TermT VarIdent
_x -> String
"\nPerhaps the term\n  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
f) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\nis applied to too many arguments?"
        TermT VarIdent
_ -> String
""
    ]
  TypeErrorCannotInferBareLambda Term VarIdent
term -> OutputDirection -> [String] -> String
block OutputDirection
TopDown
    [ String
"cannot infer the type of the argument"
    , String
"in lambda abstraction"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU Term VarIdent
term
    ]
  TypeErrorCannotInferBareRefl Term VarIdent
term -> OutputDirection -> [String] -> String
block OutputDirection
TopDown
    [ String
"cannot infer the type of term"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU Term VarIdent
term
    ]
  TypeErrorCannotInferHole Term VarIdent
term -> OutputDirection -> [String] -> String
block OutputDirection
TopDown
    [ String
"cannot infer the type of a hole"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU Term VarIdent
term
    , String
"a hole is only allowed where its type is already known (checking position)"
    ]
  TypeErrorUnsolvedHole Maybe VarIdent
mname TermT VarIdent
goal -> OutputDirection -> [String] -> String
block OutputDirection
TopDown
    [ String
"found an unsolved hole" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> (VarIdent -> String) -> Maybe VarIdent -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\VarIdent
name -> String
" ?" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> VarIdent -> String
forall a. Show a => a -> String
show VarIdent
name) Maybe VarIdent
mname
    , String
"expected type (goal):"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
goal)
    ]
  TypeErrorUndefined VarIdent
var -> OutputDirection -> [String] -> String
block OutputDirection
TopDown
    [ String
"undefined variable: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
forall a. Show a => a -> String
show (VarIdent -> Term VarIdent
forall (t :: * -> * -> *) a. a -> FS t a
Pure VarIdent
var :: Term') ]
  TypeErrorTopeNotSatisfied [TermT VarIdent]
topes TermT VarIdent
tope -> OutputDirection -> [String] -> String
block OutputDirection
TopDown
    [ String
"local context is not included in (does not entail) the tope"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
tope)
    , String
"in local context (normalised)"
    , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) ((TermT VarIdent -> String) -> [TermT VarIdent] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map TermT VarIdent -> String
ppTyped [TermT VarIdent]
topes))] -- FIXME: remove
  TypeErrorTopeContextDisjoint TermT VarIdent
tope [TermT VarIdent]
topes -> OutputDirection -> [String] -> String
block OutputDirection
TopDown
    [ String
"the tope"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
tope)
    , String
"is disjoint from the local tope context (their conjunction is the empty tope ⊥),"
    , String
"so this restriction face or recOR branch is vacuous everywhere"
    , String
"in local context (normalised)"
    , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) ((TermT VarIdent -> String) -> [TermT VarIdent] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map TermT VarIdent -> String
ppTyped [TermT VarIdent]
topes))]
  TypeErrorTopesNotEquivalent TermT VarIdent
expected TermT VarIdent
actual -> OutputDirection -> [String] -> String
block OutputDirection
TopDown
    [ String
"expected tope"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
expected)
    , String
"but got"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
actual) ]

  TypeErrorInvalidArgumentType Term VarIdent
argType TermT VarIdent
argKind -> OutputDirection -> [String] -> String
block OutputDirection
TopDown
    [ String
"invalid function parameter type"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU Term VarIdent
argType
    , String
"function parameter can be a cube, a shape, or a type"
    , String
"but given parameter type has type"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
argKind)
    ]

  TypeErrorDuplicateTopLevel [VarIdent]
previous VarIdent
lastName -> OutputDirection -> [String] -> String
block OutputDirection
TopDown
    [ String
"duplicate top-level definition"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> VarIdent -> String
ppVarIdentWithLocation VarIdent
lastName
    , String
"previous top-level definitions found at"
    , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n"
      [ String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> VarIdent -> String
ppVarIdentWithLocation VarIdent
name
      | VarIdent
name <- [VarIdent]
previous ]
    ]

  TypeErrorUnusedVariable VarIdent
name TermT VarIdent
type_ -> OutputDirection -> [String] -> String
block OutputDirection
TopDown
    [ String
"unused variable"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> VarIdent' RzkPosition -> String
forall a. Print a => a -> String
Rzk.printTree (VarIdent -> VarIdent' RzkPosition
getVarIdent VarIdent
name) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" : " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
type_)
    ]

  TypeErrorUnusedUsedVariables [VarIdent]
vars VarIdent
name -> OutputDirection -> [String] -> String
block OutputDirection
TopDown
    [ String
"unused variables"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" " ((VarIdent -> String) -> [VarIdent] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (VarIdent' RzkPosition -> String
forall a. Print a => a -> String
Rzk.printTree (VarIdent' RzkPosition -> String)
-> (VarIdent -> VarIdent' RzkPosition) -> VarIdent -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarIdent -> VarIdent' RzkPosition
getVarIdent) [VarIdent]
vars)
    , String
"declared as used in definition of"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> VarIdent' RzkPosition -> String
forall a. Print a => a -> String
Rzk.printTree (VarIdent -> VarIdent' RzkPosition
getVarIdent VarIdent
name)
    ]

  TypeErrorImplicitAssumption (VarIdent
a, TermT VarIdent
aType) VarIdent
name -> OutputDirection -> [String] -> String
block OutputDirection
TopDown
    [ String
"implicit assumption"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> VarIdent' RzkPosition -> String
forall a. Print a => a -> String
Rzk.printTree (VarIdent -> VarIdent' RzkPosition
getVarIdent VarIdent
a) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" : " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
aType)
    , String
"used in definition of"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> VarIdent' RzkPosition -> String
forall a. Print a => a -> String
Rzk.printTree (VarIdent -> VarIdent' RzkPosition
getVarIdent VarIdent
name)
    ]
  where
    ppU :: Term' -> String
    ppU :: Term VarIdent -> String
ppU = [(VarIdent, Binder)] -> Term VarIdent -> String
ppFoldU [(VarIdent, Binder)]
fbs
    ppTyped :: TermT' -> String
    ppTyped :: TermT VarIdent -> String
ppTyped = [(VarIdent, Binder)] -> TermT VarIdent -> String
ppFoldT [(VarIdent, Binder)]
fbs


-- | The pattern binders in scope, freshened and keyed by their (current) name,
-- together with the projection-folding map derived from them. Both share the
-- same freshened component names, so a term's projections and the binder shown
-- in the context agree.
contextBinders
  :: Context VarIdent
  -> ([(VarIdent, Binder)], [(VarIdent, [([Proj], VarIdent)])])
contextBinders :: Context VarIdent
-> ([(VarIdent, Binder)], [(VarIdent, [([Proj], VarIdent)])])
contextBinders Context VarIdent
ctx = ([(VarIdent, Binder)]
fbs, (VarIdent -> VarIdent)
-> [(VarIdent, Binder)] -> [(VarIdent, [([Proj], VarIdent)])]
forall var.
(var -> VarIdent)
-> [(var, Binder)] -> [(VarIdent, [([Proj], VarIdent)])]
binderProjMap VarIdent -> VarIdent
forall a. a -> a
id [(VarIdent, Binder)]
fbs)
  where
    mapping :: [(VarIdent, VarIdent)]
mapping = [ (VarIdent
v, VarIdent
v) | (VarIdent
v, TermT VarIdent
_) <- Context VarIdent -> [(VarIdent, TermT VarIdent)]
forall var. Context var -> [(var, TermT var)]
varTypes Context VarIdent
ctx ]
    fbs :: [(VarIdent, Binder)]
fbs     = (VarIdent -> VarIdent)
-> [(VarIdent, VarIdent)]
-> [(VarIdent, Binder)]
-> [(VarIdent, Binder)]
forall var.
Eq var =>
(var -> VarIdent)
-> [(var, VarIdent)] -> [(var, Binder)] -> [(var, Binder)]
freshBinders VarIdent -> VarIdent
forall a. a -> a
id [(VarIdent, VarIdent)]
mapping (Context VarIdent -> [(VarIdent, Binder)]
forall var. Context var -> [(var, Binder)]
varBinders Context VarIdent
ctx)

-- | Render an (untyped) term for an error or diagnostic message, given the
-- context's freshened pattern binders: fold a pattern-binder variable's
-- projections to their component names, then expand a bare use of the variable
-- to the pattern itself (see 'foldBinderProjections' and 'restorePatternVars').
-- An empty binder list renders the term as-is.
ppFoldU :: [(VarIdent, Binder)] -> Term' -> String
ppFoldU :: [(VarIdent, Binder)] -> Term VarIdent -> String
ppFoldU [(VarIdent, Binder)]
fbs =
  Term VarIdent -> String
forall a. Show a => a -> String
show (Term VarIdent -> String)
-> (Term VarIdent -> Term VarIdent) -> Term VarIdent -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(VarIdent, Binder)] -> Term VarIdent -> Term VarIdent
restorePatternVars [(VarIdent, Binder)]
fbs (Term VarIdent -> Term VarIdent)
-> (Term VarIdent -> Term VarIdent)
-> Term VarIdent
-> Term VarIdent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(VarIdent, [([Proj], VarIdent)])]
-> Term VarIdent -> Term VarIdent
forall a. Eq a => [(a, [([Proj], a)])] -> Term a -> Term a
foldBinderProjections ((VarIdent -> VarIdent)
-> [(VarIdent, Binder)] -> [(VarIdent, [([Proj], VarIdent)])]
forall var.
(var -> VarIdent)
-> [(var, Binder)] -> [(VarIdent, [([Proj], VarIdent)])]
binderProjMap VarIdent -> VarIdent
forall a. a -> a
id [(VarIdent, Binder)]
fbs)

-- | Like 'ppFoldU' for a type-annotated term, shown as @term : type@ with the
-- same folding and pattern restoration applied to both halves.
ppFoldT :: [(VarIdent, Binder)] -> TermT' -> String
ppFoldT :: [(VarIdent, Binder)] -> TermT VarIdent -> String
ppFoldT [(VarIdent, Binder)]
fbs TermT VarIdent
t0 =
  case [(VarIdent, [([Proj], VarIdent)])]
-> TermT VarIdent -> TermT VarIdent
forall a. Eq a => [(a, [([Proj], a)])] -> TermT a -> TermT a
foldBinderProjectionsT ((VarIdent -> VarIdent)
-> [(VarIdent, Binder)] -> [(VarIdent, [([Proj], VarIdent)])]
forall var.
(var -> VarIdent)
-> [(var, Binder)] -> [(VarIdent, [([Proj], VarIdent)])]
binderProjMap VarIdent -> VarIdent
forall a. a -> a
id [(VarIdent, Binder)]
fbs) TermT VarIdent
t0 of
    t :: TermT VarIdent
t@Pure{}               -> TermT VarIdent -> String
r TermT VarIdent
t
    t :: TermT VarIdent
t@(Free (AnnF TypeInfo (TermT VarIdent)
info TermF (Scope (FS (AnnF TypeInfo TermF)) VarIdent) (TermT VarIdent)
_)) -> TermT VarIdent -> String
r TermT VarIdent
t String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" : " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TermT VarIdent -> String
r (TypeInfo (TermT VarIdent) -> TermT VarIdent
forall term. TypeInfo term -> term
infoType TypeInfo (TermT VarIdent)
info)
  where
    r :: TermT' -> String
    r :: TermT VarIdent -> String
r = Term VarIdent -> String
forall a. Show a => a -> String
show (Term VarIdent -> String)
-> (TermT VarIdent -> Term VarIdent) -> TermT VarIdent -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(VarIdent, Binder)] -> Term VarIdent -> Term VarIdent
restorePatternVars [(VarIdent, Binder)]
fbs (Term VarIdent -> Term VarIdent)
-> (TermT VarIdent -> Term VarIdent)
-> TermT VarIdent
-> Term VarIdent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped

ppTypeErrorInContext :: OutputDirection -> TypeErrorInContext VarIdent -> String
ppTypeErrorInContext :: OutputDirection -> TypeErrorInContext VarIdent -> String
ppTypeErrorInContext OutputDirection
dir TypeErrorInContext{Context VarIdent
TypeError VarIdent
typeErrorError :: forall var. TypeErrorInContext var -> TypeError var
typeErrorContext :: forall var. TypeErrorInContext var -> Context var
typeErrorError :: TypeError VarIdent
typeErrorContext :: Context VarIdent
..} = OutputDirection -> [String] -> String
block OutputDirection
dir
  [ [(VarIdent, Binder)] -> TypeError VarIdent -> String
ppTypeError' [(VarIdent, Binder)]
fbs TypeError VarIdent
typeErrorError
  , String
""
  , OutputDirection -> Context VarIdent -> String
ppContext' OutputDirection
dir Context VarIdent
typeErrorContext
  ]
  where
    ([(VarIdent, Binder)]
fbs, [(VarIdent, [([Proj], VarIdent)])]
_) = Context VarIdent
-> ([(VarIdent, Binder)], [(VarIdent, [([Proj], VarIdent)])])
contextBinders Context VarIdent
typeErrorContext

ppTypeErrorInScopedContextWith'
  :: OutputDirection
  -> [VarIdent]
  -> [VarIdent]
  -> TypeErrorInScopedContext VarIdent
  -> String
ppTypeErrorInScopedContextWith' :: OutputDirection
-> [VarIdent]
-> [VarIdent]
-> TypeErrorInScopedContext VarIdent
-> String
ppTypeErrorInScopedContextWith' OutputDirection
dir [VarIdent]
used [VarIdent]
vars = \case
  PlainTypeError TypeErrorInContext VarIdent
err -> OutputDirection -> TypeErrorInContext VarIdent -> String
ppTypeErrorInContext OutputDirection
dir TypeErrorInContext VarIdent
err
  ScopedTypeError Maybe VarIdent
orig TypeErrorInScopedContext (Inc VarIdent)
err -> Maybe VarIdent -> ((VarIdent, [VarIdent]) -> String) -> String
forall {t}. Maybe VarIdent -> ((VarIdent, [VarIdent]) -> t) -> t
withFresh Maybe VarIdent
orig (((VarIdent, [VarIdent]) -> String) -> String)
-> ((VarIdent, [VarIdent]) -> String) -> String
forall a b. (a -> b) -> a -> b
$ \(VarIdent
x, [VarIdent]
xs) ->
    OutputDirection
-> [VarIdent]
-> [VarIdent]
-> TypeErrorInScopedContext VarIdent
-> String
ppTypeErrorInScopedContextWith' OutputDirection
dir (VarIdent
xVarIdent -> [VarIdent] -> [VarIdent]
forall a. a -> [a] -> [a]
:[VarIdent]
used) [VarIdent]
xs (TypeErrorInScopedContext VarIdent -> String)
-> TypeErrorInScopedContext VarIdent -> String
forall a b. (a -> b) -> a -> b
$ (Inc VarIdent -> VarIdent)
-> TypeErrorInScopedContext (Inc VarIdent)
-> TypeErrorInScopedContext VarIdent
forall a b.
(a -> b)
-> TypeErrorInScopedContext a -> TypeErrorInScopedContext b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (VarIdent -> Inc VarIdent -> VarIdent
forall {p}. p -> Inc p -> p
g VarIdent
x) TypeErrorInScopedContext (Inc VarIdent)
err
  where
    g :: p -> Inc p -> p
g p
x Inc p
Z     = p
x
    g p
_ (S p
y) = p
y

    withFresh :: Maybe VarIdent -> ((VarIdent, [VarIdent]) -> t) -> t
withFresh Maybe VarIdent
Nothing (VarIdent, [VarIdent]) -> t
f =
      case [VarIdent]
vars of
        VarIdent
x:[VarIdent]
xs -> (VarIdent, [VarIdent]) -> t
f (VarIdent
x, [VarIdent]
xs)
        [VarIdent]
_    -> String -> t
forall a. String -> a
panicImpossible String
"not enough fresh variables"
    withFresh (Just VarIdent
z) (VarIdent, [VarIdent]) -> t
f = (VarIdent, [VarIdent]) -> t
f (VarIdent
z', (VarIdent -> Bool) -> [VarIdent] -> [VarIdent]
forall a. (a -> Bool) -> [a] -> [a]
filter (VarIdent -> VarIdent -> Bool
forall a. Eq a => a -> a -> Bool
/= VarIdent
z') [VarIdent]
vars)    -- FIXME: very inefficient filter
      where
        z' :: VarIdent
z' = [VarIdent] -> VarIdent -> VarIdent
refreshVar [VarIdent]
used VarIdent
z -- FIXME: inefficient

ppTypeErrorInScopedContext' :: OutputDirection -> TypeErrorInScopedContext VarIdent -> String
ppTypeErrorInScopedContext' :: OutputDirection -> TypeErrorInScopedContext VarIdent -> String
ppTypeErrorInScopedContext' OutputDirection
dir TypeErrorInScopedContext VarIdent
err =
  OutputDirection
-> [VarIdent]
-> [VarIdent]
-> TypeErrorInScopedContext VarIdent
-> String
ppTypeErrorInScopedContextWith' OutputDirection
dir [VarIdent]
vars ([VarIdent]
defaultVarIdents [VarIdent] -> [VarIdent] -> [VarIdent]
forall a. Eq a => [a] -> [a] -> [a]
\\ [VarIdent]
vars) TypeErrorInScopedContext VarIdent
err
  where
    vars :: [VarIdent]
vars = [VarIdent] -> [VarIdent]
forall a. Eq a => [a] -> [a]
nub ((VarIdent -> [VarIdent])
-> TypeErrorInScopedContext VarIdent -> [VarIdent]
forall m a. Monoid m => (a -> m) -> TypeErrorInScopedContext a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap VarIdent -> [VarIdent]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeErrorInScopedContext VarIdent
err)

issueWarning :: String -> TypeCheck var ()
issueWarning :: forall var. String -> TypeCheck var ()
issueWarning String
message = do
  String -> TypeCheck var () -> TypeCheck var ()
forall a. String -> a -> a
trace (String
"Warning: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
message) (TypeCheck var () -> TypeCheck var ())
-> TypeCheck var () -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$
    () -> TypeCheck var ()
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

fromTypeError :: TypeError var -> TypeCheck var (TypeErrorInScopedContext var)
fromTypeError :: forall var.
TypeError var -> TypeCheck var (TypeErrorInScopedContext var)
fromTypeError TypeError var
err = do
  context <- ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (Context var)
forall r (m :: * -> *). MonadReader r m => m r
ask
  return $ PlainTypeError $ TypeErrorInContext
    { typeErrorError = err
    , typeErrorContext = context
    }

issueTypeError :: TypeError var -> TypeCheck var a
issueTypeError :: forall var a. TypeError var -> TypeCheck var a
issueTypeError TypeError var
err = TypeError var -> TypeCheck var (TypeErrorInScopedContext var)
forall var.
TypeError var -> TypeCheck var (TypeErrorInScopedContext var)
fromTypeError TypeError var
err TypeCheck var (TypeErrorInScopedContext var)
-> (TypeErrorInScopedContext var
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         a)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TypeErrorInScopedContext var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall a.
TypeErrorInScopedContext var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError

panicImpossible :: String -> a
panicImpossible :: forall a. String -> a
panicImpossible String
msg = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
  [ String
"PANIC! Impossible happened (" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
msg String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")!"
  , String
"Please, report a bug at https://github.com/rzk-lang/rzk/issues"
    -- TODO: add details and/or instructions how to produce an artifact for reproducing
  ]

data Action var
  = ActionTypeCheck (Term var) (TermT var)
  | ActionUnify (TermT var) (TermT var) (TermT var)
  | ActionUnifyTerms (TermT var) (TermT var)
  | ActionInfer (Term var)
  | ActionContextEntailedBy [TermT var] (TermT var)
  | ActionContextEntails [TermT var] (TermT var)
  | ActionContextEntailsUnion [TermT var] [TermT var]
  | ActionWHNF (TermT var)
  | ActionNF (TermT var)
  | ActionCheckCoherence (TermT var, TermT var) (TermT var, TermT var)
  | ActionCloseSection (Maybe Rzk.SectionName)
  | ActionCheckLetValue (Maybe VarIdent)
  deriving ((forall a b. (a -> b) -> Action a -> Action b)
-> (forall a b. a -> Action b -> Action a) -> Functor Action
forall a b. a -> Action b -> Action a
forall a b. (a -> b) -> Action a -> Action b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Action a -> Action b
fmap :: forall a b. (a -> b) -> Action a -> Action b
$c<$ :: forall a b. a -> Action b -> Action a
<$ :: forall a b. a -> Action b -> Action a
Functor, (forall m. Monoid m => Action m -> m)
-> (forall m a. Monoid m => (a -> m) -> Action a -> m)
-> (forall m a. Monoid m => (a -> m) -> Action a -> m)
-> (forall a b. (a -> b -> b) -> b -> Action a -> b)
-> (forall a b. (a -> b -> b) -> b -> Action a -> b)
-> (forall b a. (b -> a -> b) -> b -> Action a -> b)
-> (forall b a. (b -> a -> b) -> b -> Action a -> b)
-> (forall a. (a -> a -> a) -> Action a -> a)
-> (forall a. (a -> a -> a) -> Action a -> a)
-> (forall a. Action a -> [a])
-> (forall a. Action a -> Bool)
-> (forall a. Action a -> Int)
-> (forall a. Eq a => a -> Action a -> Bool)
-> (forall a. Ord a => Action a -> a)
-> (forall a. Ord a => Action a -> a)
-> (forall a. Num a => Action a -> a)
-> (forall a. Num a => Action a -> a)
-> Foldable Action
forall a. Eq a => a -> Action a -> Bool
forall a. Num a => Action a -> a
forall a. Ord a => Action a -> a
forall m. Monoid m => Action m -> m
forall a. Action a -> Bool
forall a. Action a -> Int
forall a. Action a -> [a]
forall a. (a -> a -> a) -> Action a -> a
forall m a. Monoid m => (a -> m) -> Action a -> m
forall b a. (b -> a -> b) -> b -> Action a -> b
forall a b. (a -> b -> b) -> b -> Action a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => Action m -> m
fold :: forall m. Monoid m => Action m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Action a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Action a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Action a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> Action a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> Action a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Action a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Action a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Action a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Action a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Action a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Action a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> Action a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> Action a -> a
foldr1 :: forall a. (a -> a -> a) -> Action a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Action a -> a
foldl1 :: forall a. (a -> a -> a) -> Action a -> a
$ctoList :: forall a. Action a -> [a]
toList :: forall a. Action a -> [a]
$cnull :: forall a. Action a -> Bool
null :: forall a. Action a -> Bool
$clength :: forall a. Action a -> Int
length :: forall a. Action a -> Int
$celem :: forall a. Eq a => a -> Action a -> Bool
elem :: forall a. Eq a => a -> Action a -> Bool
$cmaximum :: forall a. Ord a => Action a -> a
maximum :: forall a. Ord a => Action a -> a
$cminimum :: forall a. Ord a => Action a -> a
minimum :: forall a. Ord a => Action a -> a
$csum :: forall a. Num a => Action a -> a
sum :: forall a. Num a => Action a -> a
$cproduct :: forall a. Num a => Action a -> a
product :: forall a. Num a => Action a -> a
Foldable)

type Action' = Action VarIdent

-- | Freshen the compound (pattern) binders in scope so their component names
-- avoid the display names already in use and one another. Returns each relevant
-- variable paired with its freshened binder. Variables bound to a single name
-- are omitted: they need no projection folding and are displayed normally.
freshBinders
  :: Eq var
  => (var -> VarIdent)
  -> [(var, VarIdent)]
  -> [(var, Binder)]
  -> [(var, Binder)]
freshBinders :: forall var.
Eq var =>
(var -> VarIdent)
-> [(var, VarIdent)] -> [(var, Binder)] -> [(var, Binder)]
freshBinders var -> VarIdent
name [(var, VarIdent)]
mapping [(var, Binder)]
binders = [VarIdent] -> [(var, Binder)] -> [(var, Binder)]
forall {a}. [VarIdent] -> [(a, Binder)] -> [(a, Binder)]
go (((var, VarIdent) -> VarIdent) -> [(var, VarIdent)] -> [VarIdent]
forall a b. (a -> b) -> [a] -> [b]
map (var -> VarIdent
name (var -> VarIdent)
-> ((var, VarIdent) -> var) -> (var, VarIdent) -> VarIdent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (var, VarIdent) -> var
forall a b. (a, b) -> a
fst) [(var, VarIdent)]
mapping) [(var, Binder)]
compound
  where
    compound :: [(var, Binder)]
compound = [ (var
v, Binder
b) | (var
v, Binder
b) <- [(var, Binder)]
binders, Binder -> Bool
binderIsCompound Binder
b, var
v var -> [var] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((var, VarIdent) -> var) -> [(var, VarIdent)] -> [var]
forall a b. (a -> b) -> [a] -> [b]
map (var, VarIdent) -> var
forall a b. (a, b) -> a
fst [(var, VarIdent)]
mapping ]
    go :: [VarIdent] -> [(a, Binder)] -> [(a, Binder)]
go [VarIdent]
_    []             = []
    go [VarIdent]
used ((a
v, Binder
b) : [(a, Binder)]
rest) =
      let b' :: Binder
b' = [VarIdent] -> Binder -> Binder
freshenBinderLeaves [VarIdent]
used Binder
b
      in (a
v, Binder
b') (a, Binder) -> [(a, Binder)] -> [(a, Binder)]
forall a. a -> [a] -> [a]
: [VarIdent] -> [(a, Binder)] -> [(a, Binder)]
go (Binder -> [VarIdent]
binderLeaves Binder
b' [VarIdent] -> [VarIdent] -> [VarIdent]
forall a. [a] -> [a] -> [a]
++ [VarIdent]
used) [(a, Binder)]
rest

-- | The projection-folding map for rendering: each pattern-binder variable's
-- display name mapped to the projection paths of its component names (e.g.
-- @π₁@ ↦ @t@, @π₂@ ↦ @s@). Ordinary projections (of non-pattern variables) are
-- left untouched.
binderProjMap :: (var -> VarIdent) -> [(var, Binder)] -> [(VarIdent, [([Proj], VarIdent)])]
binderProjMap :: forall var.
(var -> VarIdent)
-> [(var, Binder)] -> [(VarIdent, [([Proj], VarIdent)])]
binderProjMap var -> VarIdent
name [(var, Binder)]
fbs = [ (var -> VarIdent
name var
v, Binder -> [([Proj], VarIdent)]
binderPaths Binder
b) | (var
v, Binder
b) <- [(var, Binder)]
fbs ]

ppTermInContext :: Eq var => TermT var -> TypeCheck var String
ppTermInContext :: forall var. Eq var => TermT var -> TypeCheck var String
ppTermInContext TermT var
term =  do
  vars <- TermT var -> TypeCheck var [var]
forall var. Eq var => TermT var -> TypeCheck var [var]
freeVarsT_ TermT var
term
  let mapping = [var] -> [VarIdent] -> [(var, VarIdent)]
forall a b. [a] -> [b] -> [(a, b)]
zip [var]
vars [VarIdent]
defaultVarIdents
      toRzkVarIdent [(var, Maybe VarIdent)]
origs var
var = VarIdent -> Maybe VarIdent -> VarIdent
forall a. a -> Maybe a -> a
fromMaybe VarIdent
"_" (Maybe VarIdent -> VarIdent) -> Maybe VarIdent -> VarIdent
forall a b. (a -> b) -> a -> b
$
        Maybe (Maybe VarIdent) -> Maybe VarIdent
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (var -> [(var, Maybe VarIdent)] -> Maybe (Maybe VarIdent)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup var
var [(var, Maybe VarIdent)]
origs) Maybe VarIdent -> Maybe VarIdent -> Maybe VarIdent
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> var -> [(var, VarIdent)] -> Maybe VarIdent
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup var
var [(var, VarIdent)]
mapping
  origs <- asks varOrigs
  binders <- asks varBinders
  let name = [(var, Maybe VarIdent)] -> var -> VarIdent
toRzkVarIdent [(var, Maybe VarIdent)]
origs
      fbs  = (var -> VarIdent)
-> [(var, VarIdent)] -> [(var, Binder)] -> [(var, Binder)]
forall var.
Eq var =>
(var -> VarIdent)
-> [(var, VarIdent)] -> [(var, Binder)] -> [(var, Binder)]
freshBinders var -> VarIdent
name [(var, VarIdent)]
mapping [(var, Binder)]
binders
  return (show (restorePatternVars [ (name v, b) | (v, b) <- fbs ]
                  (foldBinderProjections (binderProjMap name fbs)
                    (untyped (name <$> term)))))

-- | Classify a (WHNF) type as a cube, so cube variables (e.g. @t : 2@) are
-- shown separately from ordinary term variables in a hole's context.
isCubeType :: TermT var -> Bool
isCubeType :: forall var. TermT var -> Bool
isCubeType = \case
  CubeUnitT{}     -> Bool
True
  Cube2T{}        -> Bool
True
  CubeIT{}        -> Bool
True
  CubeProductT{}  -> Bool
True
  UniverseCubeT{} -> Bool
True
  TermT var
_               -> Bool
False

-- | Is a (WHNF) goal type in the cube or tope layer, so a hole of this type is a
-- cube point or a tope rather than a term? Used to suppress type-layer-specific
-- hole candidates (@recOR@, @recBOT@), which cannot inhabit a cube or a tope.
isCubeOrTopeType :: TermT var -> Bool
isCubeOrTopeType :: forall var. TermT var -> Bool
isCubeOrTopeType TermT var
t = TermT var -> Bool
forall var. TermT var -> Bool
isCubeType TermT var
t Bool -> Bool -> Bool
|| case TermT var
t of
  UniverseTopeT{} -> Bool
True
  TermT var
_               -> Bool
False

-- | Is this term a hole? Holes only exist in lenient mode (see 'allowHoles');
-- they are opaque placeholders standing for a term of the expected type.
isHoleT :: TermT var -> Bool
isHoleT :: forall var. TermT var -> Bool
isHoleT HoleT{} = Bool
True
isHoleT FS (AnnF TypeInfo TermF) var
_       = Bool
False

-- | Does this term contain a hole anywhere (including nested, e.g. @f ?@)?
-- Used to keep unification lenient around incomplete terms: a term with an
-- unfilled hole cannot be meaningfully compared, so a unification that would
-- otherwise fail is deferred. Evaluated only on the failure path.
containsHole :: TermT var -> Bool
containsHole :: forall var. TermT var -> Bool
containsHole = \case
  HoleT{}             -> Bool
True
  Pure{}              -> Bool
False
  Free (AnnF TypeInfo (TermT var)
_ TermF (Scope (FS (AnnF TypeInfo TermF)) var) (TermT var)
termf) -> (Scope (FS (AnnF TypeInfo TermF)) var -> Bool -> Bool)
-> (TermT var -> Bool -> Bool)
-> Bool
-> TermF (Scope (FS (AnnF TypeInfo TermF)) var) (TermT var)
-> Bool
forall a c b. (a -> c -> c) -> (b -> c -> c) -> c -> TermF a b -> c
forall (p :: * -> * -> *) a c b.
Bifoldable p =>
(a -> c -> c) -> (b -> c -> c) -> c -> p a b -> c
bifoldr (Bool -> Bool -> Bool
(||) (Bool -> Bool -> Bool)
-> (Scope (FS (AnnF TypeInfo TermF)) var -> Bool)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> Bool
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scope (FS (AnnF TypeInfo TermF)) var -> Bool
forall var. TermT var -> Bool
containsHole) (Bool -> Bool -> Bool
(||) (Bool -> Bool -> Bool)
-> (TermT var -> Bool) -> TermT var -> Bool -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermT var -> Bool
forall var. TermT var -> Bool
containsHole) Bool
False TermF (Scope (FS (AnnF TypeInfo TermF)) var) (TermT var)
termf

-- | All ways to eliminate a hypothesis into a value usable at a goal. Given a
-- @target@ type and a hypothesis /term/ (e.g. @Pure v@ for a context variable),
-- return every elimination spine over that term whose type fits the target (or
-- a subtype of it). Arguments introduced by application are left as holes for
-- the caller to fill later. A value that already fits is returned as-is; a
-- function is applied to holes; a Σ-type (or anything that unfolds to one, e.g.
-- @is-contr@) is projected, possibly repeatedly — so e.g.
-- @first (first (is-segal-A ? ? ? ? ?))@ is discovered.
--
-- The search is driven uniformly by the eliminators a (weak head normal) type
-- admits (see 'eliminatorsOf'), so adding a new eliminator extends it without
-- touching the search.
--
-- A Π-application is a forced spine step — there is exactly one way to fill an
-- argument (with a hole) — so it extends the spine for free and does not spend
-- the budget. Only the genuinely branching eliminators (Σ/cube projections and
-- @idJ@, flagged by 'eliminatorsOf') count against 'maxEliminationDepth'. The
-- bound therefore limits real search depth, not argument count, so a lemma that
-- must be applied to many holes is still reached. The free spine terminates
-- because each application strips one Π binder off a finite type.
allEliminationsInto
  :: Eq var => TermT var -> TermT var -> TypeCheck var [TermT var]
allEliminationsInto :: forall var.
Eq var =>
TermT var -> TermT var -> TypeCheck var [TermT var]
allEliminationsInto TermT var
target = Int
-> TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [TermT var]
forall {t}.
(Ord t, Num t) =>
t
-> TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [TermT var]
go Int
maxEliminationDepth
  where
    go :: t
-> TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [TermT var]
go t
depth TermT var
term = do
      ty    <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
term
      fits  <- fitsInto term ty target
      elims <- eliminatorsOf ty
      let step (ElimCost
SpineStep, TermT var -> TermT var
wrap) = t
-> TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [TermT var]
go t
depth (TermT var -> TermT var
wrap TermT var
term)
          step (ElimCost
Branching, TermT var -> TermT var
wrap)
            | t
depth t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
0 = [TermT var]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [TermT var]
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
            | Bool
otherwise  = t
-> TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [TermT var]
go (t
depth t -> t -> t
forall a. Num a => a -> a -> a
- t
1) (TermT var -> TermT var
wrap TermT var
term)
      deeper <- concat <$> mapM step elims
      pure ([term | fits] <> deeper)

-- | How many /branching/ eliminators 'allEliminationsInto' will chain. Forced
-- Π-applications are free (see 'allEliminationsInto'), so this bounds only the
-- Σ/cube projections and @idJ@ steps, not the argument count of a spine. A
-- temporary fixed bound: branching is shallow in the goals seen so far (a few
-- projections), and a larger bound mostly adds self-referential spines (a built
-- result eliminated again). It should be made configurable once there is more
-- evidence of what real goals need.
maxEliminationDepth :: Int
maxEliminationDepth :: Int
maxEliminationDepth = Int
7

-- | Whether a term of the given (whnf) type may stand where a value of the
-- @target@ type is expected: the two types unify under 'structuralHoleUnify',
-- so a hole acts as a wildcard leaf but a structural mismatch around it is still
-- a mismatch (an under-applied function does not match an extension-type goal,
-- but a partial application that genuinely fits an ordinary-function goal does).
--
-- Outer type restrictions are stripped from both sides first: an extension-type
-- boundary is satisfied by later refinement, not by the choice of spine, and
-- matching against the restricted goal would reject the very spine that
-- introduces the holes meant to satisfy it (e.g. @f ?@ at a boundary goal).
--
-- Holes or constraints recorded while probing are discarded, so this is a pure
-- yes/no query.
fitsInto :: Eq var => TermT var -> TermT var -> TermT var -> TypeCheck var Bool
fitsInto :: forall var.
Eq var =>
TermT var -> TermT var -> TermT var -> TypeCheck var Bool
fitsInto TermT var
term TermT var
ty TermT var
target = do
  ty'     <- TermT var -> TermT var
forall var. TermT var -> TermT var
stripTypeRestrictions (TermT var -> TermT var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
ty
  target' <- stripTypeRestrictions <$> whnfT target
  censor (const []) $ local structuralHoleUnify
    ((unify (Just term) target' ty' >> pure True) `catchError` \TypeErrorInScopedContext var
_ -> Bool
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)

-- | Whether eliminating a value spends the search budget. A forced
-- Π-application is a 'SpineStep' — there is one way to fill the argument (with a
-- hole), so 'allEliminationsInto' applies it for free; a 'Branching' eliminator
-- (a Σ/cube projection or @idJ@) costs one against 'maxEliminationDepth'.
data ElimCost = SpineStep | Branching
  deriving (ElimCost -> ElimCost -> Bool
(ElimCost -> ElimCost -> Bool)
-> (ElimCost -> ElimCost -> Bool) -> Eq ElimCost
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ElimCost -> ElimCost -> Bool
== :: ElimCost -> ElimCost -> Bool
$c/= :: ElimCost -> ElimCost -> Bool
/= :: ElimCost -> ElimCost -> Bool
Eq, Int -> ElimCost -> String -> String
[ElimCost] -> String -> String
ElimCost -> String
(Int -> ElimCost -> String -> String)
-> (ElimCost -> String)
-> ([ElimCost] -> String -> String)
-> Show ElimCost
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ElimCost -> String -> String
showsPrec :: Int -> ElimCost -> String -> String
$cshow :: ElimCost -> String
show :: ElimCost -> String
$cshowList :: [ElimCost] -> String -> String
showList :: [ElimCost] -> String -> String
Show)

-- | The eliminators a value of the given (weak head normal) type admits, each
-- as a function wrapping the eliminated term, paired with its 'ElimCost'. A
-- Π-type is eliminated by application to a fresh hole (a spine step); a Σ-type
-- by either projection; an identity type by path induction (@idJ@), with the
-- motive and base case left as holes. The projections and @idJ@ branch.
-- Anything else admits no simple eliminator.
eliminatorsOf :: Eq var => TermT var -> TypeCheck var [(ElimCost, TermT var -> TermT var)]
eliminatorsOf :: forall var.
Eq var =>
TermT var -> TypeCheck var [(ElimCost, TermT var -> TermT var)]
eliminatorsOf TermT var
ty =
  case TermT var -> TermT var
forall var. TermT var -> TermT var
stripTypeRestrictions TermT var
ty of
    TypeFunT TypeInfo (TermT var)
_ty Binder
_orig TModality
_md TermT var
param Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
_mtope Scope (FS (AnnF TypeInfo TermF)) var
ret ->
      [(ElimCost, TermT var -> TermT var)]
-> TypeCheck var [(ElimCost, TermT var -> TermT var)]
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ (ElimCost
SpineStep, \TermT var
term -> let h :: TermT var
h = TermT var -> TermT var
forall var. TermT var -> TermT var
mkHole TermT var
param in TermT var -> TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var -> TermT var
appT (TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
forall var.
TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
substituteT TermT var
h Scope (FS (AnnF TypeInfo TermF)) var
ret) TermT var
term TermT var
h) ]
    TypeSigmaT TypeInfo (TermT var)
_ty Binder
_orig TModality
_md TermT var
a Scope (FS (AnnF TypeInfo TermF)) var
b ->
      [(ElimCost, TermT var -> TermT var)]
-> TypeCheck var [(ElimCost, TermT var -> TermT var)]
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ (ElimCost
Branching, \TermT var
term -> TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
firstT TermT var
a TermT var
term)
           , (ElimCost
Branching, \TermT var
term -> TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
secondT (TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
forall var.
TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
substituteT (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
firstT TermT var
a TermT var
term) Scope (FS (AnnF TypeInfo TermF)) var
b) TermT var
term) ]
    -- A cube point pair (e.g. a pattern-bound @(t , s) : 2 × 2@) projects to its
    -- coordinates; rzk renders those projections back as the pattern names.
    CubeProductT TypeInfo (TermT var)
_ty TermT var
a TermT var
b ->
      [(ElimCost, TermT var -> TermT var)]
-> TypeCheck var [(ElimCost, TermT var -> TermT var)]
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ (ElimCost
Branching, \TermT var
term -> TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
firstT TermT var
a TermT var
term)
           , (ElimCost
Branching, \TermT var
term -> TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
secondT TermT var
b TermT var
term) ]
    -- A path @p : a =_A x@ is eliminated by path induction. The motive
    -- @C : (z : A) → (a =_A z) → U@ is always a function, so we introduce it
    -- straight away as @\\ b q → ?@ rather than leaving it a bare hole: the spine
    -- @idJ A a (\\ b q → ?) ? x p@ then has type @C x p@, which β-reduces to that
    -- inner hole — so J fits any goal (the player fills the motive and the base
    -- case @d : C a refl@). The two holes are the motive predicate and the base.
    TypeIdT TypeInfo (TermT var)
_ty TermT var
a Maybe (TermT var)
mtA TermT var
x -> do
      tA <- ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (TermT var)
-> (TermT var
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         (TermT var))
-> Maybe (TermT var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
a) TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TermT var)
mtA
      let -- the motive predicate body, a type, under the two motive binders
          cBody  = FS (AnnF TypeInfo TermF) a -> FS (AnnF TypeInfo TermF) a
forall var. TermT var -> TermT var
mkHole FS (AnnF TypeInfo TermF) a
forall var. TermT var
universeT
          cInner = Scope (FS (AnnF TypeInfo TermF)) var
-> Binder
-> Maybe
     (TModality, Scope (FS (AnnF TypeInfo TermF)) var,
      Maybe (Scope (FS (AnnF TypeInfo TermF)) (Inc var)))
-> Scope (FS (AnnF TypeInfo TermF)) (Inc var)
-> Scope (FS (AnnF TypeInfo TermF)) var
forall var.
TermT var
-> Binder
-> Maybe
     (TModality, TermT var,
      Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
lambdaT (Binder
-> TModality
-> Scope (FS (AnnF TypeInfo TermF)) var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) (Inc var))
-> Scope (FS (AnnF TypeInfo TermF)) (Inc var)
-> Scope (FS (AnnF TypeInfo TermF)) var
forall var.
Binder
-> TModality
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeFunT (Maybe VarIdent -> Binder
BinderVar Maybe VarIdent
forall a. Maybe a
Nothing) TModality
Id
                              (Scope (FS (AnnF TypeInfo TermF)) var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> Scope (FS (AnnF TypeInfo TermF)) var
forall var.
TermT var -> Maybe (TermT var) -> TermT var -> TermT var
typeIdT (var -> Inc var
forall var. var -> Inc var
S (var -> Inc var)
-> TermT var -> Scope (FS (AnnF TypeInfo TermF)) var
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
a) (Scope (FS (AnnF TypeInfo TermF)) var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
forall a. a -> Maybe a
Just (var -> Inc var
forall var. var -> Inc var
S (var -> Inc var)
-> TermT var -> Scope (FS (AnnF TypeInfo TermF)) var
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
tA)) (Inc var -> Scope (FS (AnnF TypeInfo TermF)) var
forall (t :: * -> * -> *) a. a -> FS t a
Pure Inc var
forall var. Inc var
Z)) Maybe (Scope (FS (AnnF TypeInfo TermF)) (Inc var))
forall a. Maybe a
Nothing Scope (FS (AnnF TypeInfo TermF)) (Inc var)
forall var. TermT var
universeT)
                     (Maybe VarIdent -> Binder
BinderVar (VarIdent -> Maybe VarIdent
forall a. a -> Maybe a
Just (String -> VarIdent
forall a. IsString a => String -> a
fromString String
"q"))) Maybe
  (TModality, Scope (FS (AnnF TypeInfo TermF)) var,
   Maybe (Scope (FS (AnnF TypeInfo TermF)) (Inc var)))
forall a. Maybe a
Nothing Scope (FS (AnnF TypeInfo TermF)) (Inc var)
forall var. TermT var
cBody
          cType  = Binder
-> TModality
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall var.
Binder
-> TModality
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeFunT (Maybe VarIdent -> Binder
BinderVar Maybe VarIdent
forall a. Maybe a
Nothing) TModality
Id TermT var
tA Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
forall a. Maybe a
Nothing (Scope (FS (AnnF TypeInfo TermF)) var -> TermT var)
-> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
forall a b. (a -> b) -> a -> b
$
                     Binder
-> TModality
-> Scope (FS (AnnF TypeInfo TermF)) var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) (Inc var))
-> Scope (FS (AnnF TypeInfo TermF)) (Inc var)
-> Scope (FS (AnnF TypeInfo TermF)) var
forall var.
Binder
-> TModality
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeFunT (Maybe VarIdent -> Binder
BinderVar Maybe VarIdent
forall a. Maybe a
Nothing) TModality
Id
                       (Scope (FS (AnnF TypeInfo TermF)) var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> Scope (FS (AnnF TypeInfo TermF)) var
forall var.
TermT var -> Maybe (TermT var) -> TermT var -> TermT var
typeIdT (var -> Inc var
forall var. var -> Inc var
S (var -> Inc var)
-> TermT var -> Scope (FS (AnnF TypeInfo TermF)) var
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
a) (Scope (FS (AnnF TypeInfo TermF)) var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
forall a. a -> Maybe a
Just (var -> Inc var
forall var. var -> Inc var
S (var -> Inc var)
-> TermT var -> Scope (FS (AnnF TypeInfo TermF)) var
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
tA)) (Inc var -> Scope (FS (AnnF TypeInfo TermF)) var
forall (t :: * -> * -> *) a. a -> FS t a
Pure Inc var
forall var. Inc var
Z)) Maybe (Scope (FS (AnnF TypeInfo TermF)) (Inc var))
forall a. Maybe a
Nothing Scope (FS (AnnF TypeInfo TermF)) (Inc var)
forall var. TermT var
universeT
          c      = TermT var
-> Binder
-> Maybe
     (TModality, TermT var,
      Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall var.
TermT var
-> Binder
-> Maybe
     (TModality, TermT var,
      Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
lambdaT TermT var
cType (Maybe VarIdent -> Binder
BinderVar (VarIdent -> Maybe VarIdent
forall a. a -> Maybe a
Just (String -> VarIdent
forall a. IsString a => String -> a
fromString String
"b"))) Maybe
  (TModality, TermT var,
   Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
forall a. Maybe a
Nothing Scope (FS (AnnF TypeInfo TermF)) var
cInner
          dType  = TermT var -> TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var -> TermT var
appT TermT var
forall var. TermT var
universeT
                     (TermT var -> TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var -> TermT var
appT (Binder
-> TModality
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall var.
Binder
-> TModality
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeFunT (Maybe VarIdent -> Binder
BinderVar Maybe VarIdent
forall a. Maybe a
Nothing) TModality
Id (TermT var -> Maybe (TermT var) -> TermT var -> TermT var
forall var.
TermT var -> Maybe (TermT var) -> TermT var -> TermT var
typeIdT TermT var
a (TermT var -> Maybe (TermT var)
forall a. a -> Maybe a
Just TermT var
tA) TermT var
a) Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
forall a. Maybe a
Nothing Scope (FS (AnnF TypeInfo TermF)) var
forall var. TermT var
universeT) TermT var
c TermT var
a)
                     (TermT var -> Maybe (TermT var, Maybe (TermT var)) -> TermT var
forall var.
TermT var -> Maybe (TermT var, Maybe (TermT var)) -> TermT var
reflT (TermT var -> Maybe (TermT var) -> TermT var -> TermT var
forall var.
TermT var -> Maybe (TermT var) -> TermT var -> TermT var
typeIdT TermT var
a (TermT var -> Maybe (TermT var)
forall a. a -> Maybe a
Just TermT var
tA) TermT var
a) Maybe (TermT var, Maybe (TermT var))
forall a. Maybe a
Nothing)
          d      = TermT var -> TermT var
forall var. TermT var -> TermT var
mkHole TermT var
dType
          motiveAt TermT var
y TermT var
p = TermT var -> TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var -> TermT var
appT TermT var
forall var. TermT var
universeT
            (TermT var -> TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var -> TermT var
appT (Binder
-> TModality
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall var.
Binder
-> TModality
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeFunT (Maybe VarIdent -> Binder
BinderVar Maybe VarIdent
forall a. Maybe a
Nothing) TModality
Id (TermT var -> Maybe (TermT var) -> TermT var -> TermT var
forall var.
TermT var -> Maybe (TermT var) -> TermT var -> TermT var
typeIdT TermT var
a (TermT var -> Maybe (TermT var)
forall a. a -> Maybe a
Just TermT var
tA) TermT var
y) Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
forall a. Maybe a
Nothing Scope (FS (AnnF TypeInfo TermF)) var
forall var. TermT var
universeT) TermT var
c TermT var
y) TermT var
p
      pure [ (Branching, \TermT var
p -> TermT var
-> TermT var
-> TermT var
-> TermT var
-> TermT var
-> TermT var
-> TermT var
-> TermT var
forall var.
TermT var
-> TermT var
-> TermT var
-> TermT var
-> TermT var
-> TermT var
-> TermT var
-> TermT var
idJT (TermT var -> TermT var -> TermT var
motiveAt TermT var
x TermT var
p) TermT var
tA TermT var
a TermT var
c TermT var
d TermT var
x TermT var
p) ]
    TermT var
_ -> [(ElimCost, TermT var -> TermT var)]
-> TypeCheck var [(ElimCost, TermT var -> TermT var)]
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  where
    mkHole :: FS (AnnF TypeInfo TermF) a -> FS (AnnF TypeInfo TermF) a
mkHole FS (AnnF TypeInfo TermF) a
t = TypeInfo (FS (AnnF TypeInfo TermF) a)
-> Maybe VarIdent -> FS (AnnF TypeInfo TermF) a
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> Maybe VarIdent -> FS (AnnF ann TermF) a
HoleT TypeInfo{ infoType :: FS (AnnF TypeInfo TermF) a
infoType = FS (AnnF TypeInfo TermF) a
t, infoWHNF :: Maybe (FS (AnnF TypeInfo TermF) a)
infoWHNF = Maybe (FS (AnnF TypeInfo TermF) a)
forall a. Maybe a
Nothing, infoNF :: Maybe (FS (AnnF TypeInfo TermF) a)
infoNF = Maybe (FS (AnnF TypeInfo TermF) a)
forall a. Maybe a
Nothing } Maybe VarIdent
forall a. Maybe a
Nothing

-- | The binder for a λ introduced over a domain type. A binder the type already
-- gives as a pattern is kept as-is — it carries the user's own names (e.g.
-- @(t , s)@). Otherwise an /explicit/ (pre-whnf) Σ-type or product domain is
-- destructured into a fresh pair pattern, recursively for products, so that a
-- nameless @2 × 2 × 2@ parameter is introduced as @((t1 , t2) , t3)@ rather than
-- a single opaque variable. Any other domain keeps its single binder.
--
-- Leaves are named by what they range over: a cube-product component is a point,
-- named @t@/@s@-style as @tN@; a Σ component is a term, named @xN@. The names are
-- display-only (the body is a hole that does not mention them) and carry a
-- shared running index, so every leaf in the pattern is distinct.
destructuringBinder :: Binder -> TermT var -> Binder
destructuringBinder :: forall var. Binder -> TermT var -> Binder
destructuringBinder Binder
orig TermT var
param = case Binder
orig of
  BinderPair{} -> Binder
orig                 -- already a pattern: keep the user's names
  Binder
_ -> case TermT var
param of
    CubeProductT{} -> (Binder, Integer) -> Binder
forall a b. (a, b) -> a
fst (Integer -> TermT var -> (Binder, Integer)
forall {a} {ann :: * -> *} {a}.
(Show a, Num a) =>
a -> FS (AnnF ann TermF) a -> (Binder, a)
go Integer
1 TermT var
param)
    TypeSigmaT{}   -> (Binder, Integer) -> Binder
forall a b. (a, b) -> a
fst (Integer -> TermT var -> (Binder, Integer)
forall {a} {ann :: * -> *} {a}.
(Show a, Num a) =>
a -> FS (AnnF ann TermF) a -> (Binder, a)
go Integer
1 TermT var
param)
    TermT var
_              -> Binder
orig             -- not a product/Σ: leave the binder alone
  where
    -- a product/Σ becomes a pair; we recurse into a product's components (plain
    -- types) but not under a Σ's binder (a scope). A leaf is named by its
    -- enclosing constructor: @tN@ under a cube product, @xN@ under a Σ.
    go :: a -> FS (AnnF ann TermF) a -> (Binder, a)
go a
n = \case
      CubeProductT ann (FS (AnnF ann TermF) a)
_ FS (AnnF ann TermF) a
a FS (AnnF ann TermF) a
b ->
        let (Binder
l, a
n')  = String -> a -> FS (AnnF ann TermF) a -> (Binder, a)
child String
"t" a
n  FS (AnnF ann TermF) a
a
            (Binder
r, a
n'') = String -> a -> FS (AnnF ann TermF) a -> (Binder, a)
child String
"t" a
n' FS (AnnF ann TermF) a
b
        in (Binder -> Binder -> Binder
BinderPair Binder
l Binder
r, a
n'')
      TypeSigmaT ann (FS (AnnF ann TermF) a)
_ Binder
_ TModality
_md FS (AnnF ann TermF) a
a Scope (FS (AnnF ann TermF)) a
_b ->
        let (Binder
l, a
n') = String -> a -> FS (AnnF ann TermF) a -> (Binder, a)
child String
"x" a
n FS (AnnF ann TermF) a
a
        in (Binder -> Binder -> Binder
BinderPair Binder
l (Maybe VarIdent -> Binder
BinderVar (VarIdent -> Maybe VarIdent
forall a. a -> Maybe a
Just (String -> a -> VarIdent
forall {a} {a}. (IsString a, Show a) => String -> a -> a
leaf String
"x" a
n'))), a
n' a -> a -> a
forall a. Num a => a -> a -> a
+ a
1)
      FS (AnnF ann TermF) a
_ -> (Maybe VarIdent -> Binder
BinderVar (VarIdent -> Maybe VarIdent
forall a. a -> Maybe a
Just (String -> a -> VarIdent
forall {a} {a}. (IsString a, Show a) => String -> a -> a
leaf String
"t" a
n)), a
n a -> a -> a
forall a. Num a => a -> a -> a
+ a
1)  -- unreached: go is called on products only
    child :: String -> a -> FS (AnnF ann TermF) a -> (Binder, a)
child String
pfx a
n = \case
      c :: FS (AnnF ann TermF) a
c@CubeProductT{} -> a -> FS (AnnF ann TermF) a -> (Binder, a)
go a
n FS (AnnF ann TermF) a
c
      c :: FS (AnnF ann TermF) a
c@TypeSigmaT{}   -> a -> FS (AnnF ann TermF) a -> (Binder, a)
go a
n FS (AnnF ann TermF) a
c
      FS (AnnF ann TermF) a
_                -> (Maybe VarIdent -> Binder
BinderVar (VarIdent -> Maybe VarIdent
forall a. a -> Maybe a
Just (String -> a -> VarIdent
forall {a} {a}. (IsString a, Show a) => String -> a -> a
leaf String
pfx a
n)), a
n a -> a -> a
forall a. Num a => a -> a -> a
+ a
1)
    leaf :: String -> a -> a
leaf String
pfx a
n = String -> a
forall a. IsString a => String -> a
fromString (String
pfx String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
n :: String)

-- | All ways to introduce a value /of/ a goal type by its head constructor,
-- leaving the constituents as holes. Given a @target@ type, return its
-- introduction forms:
--
--   * a Π-type is introduced by a λ-abstraction over a hole body (@\\ x -> ?@);
--     the binder is taken from the type, so a pattern domain (e.g. a @Δ²@ point
--     @(t , s)@) is introduced as @\\ (t , s) -> ?@;
--   * a Σ-type or a cube product by a pair of holes (@(? , ?)@);
--   * an identity type by @refl@, but only when its two endpoints already agree
--     (otherwise @refl@ would not typecheck);
--   * the unit type by @unit@;
--   * the tope universe by each tope constructor — @TOP@, @BOT@, @? ≡ ?@,
--     @? ≤ ?@, @? ∧ ?@, @? ∨ ?@ — so a shape (a hole of type @TOPE@) can be
--     built up by tapping.
--
-- Any other type admits no simple introduction. Unlike 'allEliminationsInto'
-- this does not search: a type has at most one introduction form (the tope
-- universe is the one exception), read off its (weak head normal) head
-- constructor. Outer type restrictions are stripped first, so an extension type
-- is introduced by the form of its underlying type (its boundary is met by later
-- refinement of the holes, not by the choice of constructor).
--
-- The λ binder of a Π-introduction is freshened against @inScope@ (the names
-- already visible at the hole), so introducing over a type whose own definition
-- reuses an in-scope name (e.g. @hom@, whose internal binder is @t@) yields
-- @\\ t₁ -> ?@ rather than a @t@ that shadows the existing one.
allIntroductionsOf :: Eq var => TermT var -> [VarIdent] -> TypeCheck var [TermT var]
allIntroductionsOf :: forall var.
Eq var =>
TermT var -> [VarIdent] -> TypeCheck var [TermT var]
allIntroductionsOf TermT var
target [VarIdent]
inScope = do
  target' <- TermT var -> TermT var
forall var. TermT var -> TermT var
stripTypeRestrictions (TermT var -> TermT var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
target
  case target' of
    TypeFunT TypeInfo (TermT var)
_ty Binder
orig TModality
_md TermT var
param Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
_mtope Scope (FS (AnnF TypeInfo TermF)) var
ret ->
      let binder :: Binder
binder = [VarIdent] -> Binder -> Binder
freshenBinderLeaves [VarIdent]
inScope (Binder -> TermT var -> Binder
forall var. Binder -> TermT var -> Binder
destructuringBinder Binder
orig TermT var
param)
       in [TermT var]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [TermT var]
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ TermT var
-> Binder
-> Maybe
     (TModality, TermT var,
      Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall var.
TermT var
-> Binder
-> Maybe
     (TModality, TermT var,
      Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
lambdaT TermT var
target' Binder
binder Maybe
  (TModality, TermT var,
   Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
forall a. Maybe a
Nothing (Scope (FS (AnnF TypeInfo TermF)) var
-> Scope (FS (AnnF TypeInfo TermF)) var
forall var. TermT var -> TermT var
mkHole Scope (FS (AnnF TypeInfo TermF)) var
ret) ]
    TypeSigmaT TypeInfo (TermT var)
_ty Binder
_orig TModality
_md TermT var
a Scope (FS (AnnF TypeInfo TermF)) var
b ->
      let h :: TermT var
h = TermT var -> TermT var
forall var. TermT var -> TermT var
mkHole TermT var
a in [TermT var]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [TermT var]
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ TermT var -> TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var -> TermT var
pairT TermT var
target' TermT var
h (TermT var -> TermT var
forall var. TermT var -> TermT var
mkHole (TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
forall var.
TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
substituteT TermT var
h Scope (FS (AnnF TypeInfo TermF)) var
b)) ]
    CubeProductT TypeInfo (TermT var)
_ty TermT var
a TermT var
b ->
      [TermT var]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [TermT var]
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ TermT var -> TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var -> TermT var
pairT TermT var
target' (TermT var -> TermT var
forall var. TermT var -> TermT var
mkHole TermT var
a) (TermT var -> TermT var
forall var. TermT var -> TermT var
mkHole TermT var
b) ]
    TypeIdT TypeInfo (TermT var)
_ty TermT var
a Maybe (TermT var)
_tA TermT var
b -> do
      agree <- TermT var -> TermT var -> TypeCheck var Bool
forall var. Eq var => TermT var -> TermT var -> TypeCheck var Bool
endpointsAgree TermT var
a TermT var
b
      pure [ reflT target' Nothing | agree ]
    TypeUnitT{} -> [TermT var]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [TermT var]
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ TermT var
forall var. TermT var
unitT ]
    -- the tope universe: every tope constructor builds a tope, so all are
    -- introductions of a shape goal. Point arguments (of ≡, ≤) and tope
    -- arguments (of ∧, ∨) are left as holes.
    UniverseTopeT{} ->
      let point :: FS (AnnF TypeInfo TermF) a
point = FS (AnnF TypeInfo TermF) a -> FS (AnnF TypeInfo TermF) a
forall var. TermT var -> TermT var
mkHole (FS (AnnF TypeInfo TermF) a -> FS (AnnF TypeInfo TermF) a
forall var. TermT var -> TermT var
mkHole FS (AnnF TypeInfo TermF) a
forall var. TermT var
cubeT)  -- a point of an as-yet-unknown cube
          tope :: TermT var
tope  = TermT var -> TermT var
forall var. TermT var -> TermT var
mkHole TermT var
target'         -- a tope (its type is the tope universe)
       in [TermT var]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [TermT var]
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ TermT var
forall var. TermT var
topeTopT, TermT var
forall var. TermT var
topeBottomT
               , TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT  TermT var
forall var. TermT var
point TermT var
forall var. TermT var
point, TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
forall var. TermT var
point TermT var
forall var. TermT var
point
               , TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeAndT TermT var
tope  TermT var
tope,  TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeOrT  TermT var
tope  TermT var
tope ]
    TermT var
_ -> [TermT var]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [TermT var]
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  where
    mkHole :: FS (AnnF TypeInfo TermF) a -> FS (AnnF TypeInfo TermF) a
mkHole FS (AnnF TypeInfo TermF) a
t = TypeInfo (FS (AnnF TypeInfo TermF) a)
-> Maybe VarIdent -> FS (AnnF TypeInfo TermF) a
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> Maybe VarIdent -> FS (AnnF ann TermF) a
HoleT TypeInfo{ infoType :: FS (AnnF TypeInfo TermF) a
infoType = FS (AnnF TypeInfo TermF) a
t, infoWHNF :: Maybe (FS (AnnF TypeInfo TermF) a)
infoWHNF = Maybe (FS (AnnF TypeInfo TermF) a)
forall a. Maybe a
Nothing, infoNF :: Maybe (FS (AnnF TypeInfo TermF) a)
infoNF = Maybe (FS (AnnF TypeInfo TermF) a)
forall a. Maybe a
Nothing } Maybe VarIdent
forall a. Maybe a
Nothing

-- | Whether the two endpoints of an identity type are definitionally equal, so
-- that @refl@ inhabits it. Like 'fitsInto', any holes or constraints recorded
-- while probing are discarded, leaving a pure yes\/no query.
endpointsAgree :: Eq var => TermT var -> TermT var -> TypeCheck var Bool
endpointsAgree :: forall var. Eq var => TermT var -> TermT var -> TypeCheck var Bool
endpointsAgree TermT var
a TermT var
b =
  ([HoleInfo] -> [HoleInfo])
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     Bool
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     Bool
forall w (m :: * -> *) a. MonadWriter w m => (w -> w) -> m a -> m a
censor ([HoleInfo] -> [HoleInfo] -> [HoleInfo]
forall a b. a -> b -> a
const [])
    ((Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify Maybe (TermT var)
forall a. Maybe a
Nothing TermT var
a TermT var
b TypeCheck var ()
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     Bool
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     Bool
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True) ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  Bool
-> (TypeErrorInScopedContext var
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         Bool)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     Bool
forall a.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (TypeErrorInScopedContext var
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         a)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \TypeErrorInScopedContext var
_ -> Bool
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)

-- | Whether the local tope context is contradictory (entails ⊥). Reads the
-- precomputed flag when present, falling back to an entailment check. Used to
-- decide whether @recBOT@ (ex falso) is available.
contextEntailsBottom :: Eq var => TypeCheck var Bool
contextEntailsBottom :: forall var. Eq var => TypeCheck var Bool
contextEntailsBottom = (Context var -> Maybe Bool)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe Bool)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context var -> Maybe Bool
forall var. Context var -> Maybe Bool
localTopesEntailBottom ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (Maybe Bool)
-> (Maybe Bool
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         Bool)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     Bool
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Just Bool
b  -> Bool
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
b
  Maybe Bool
Nothing -> (Context var -> [ModalTope var])
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [ModalTope var]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context var -> [ModalTope var]
forall var. Context var -> [ModalTope var]
localTopesNF ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  [ModalTope var]
-> ([ModalTope var]
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         Bool)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     Bool
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([ModalTope var]
-> TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     Bool
forall var.
Eq var =>
[ModalTope var] -> TermT var -> TypeCheck var Bool
`entailM` TermT var
forall var. TermT var
topeBottomT)

-- | Ex falso: in a contradictory tope context @recBOT@ inhabits any type, so it
-- is a candidate for every goal there (and only there — elsewhere it would not
-- typecheck). Independent of the goal and of the local hypotheses.
recBottomCandidates :: Eq var => TypeCheck var [TermT var]
recBottomCandidates :: forall var. Eq var => TypeCheck var [TermT var]
recBottomCandidates = do
  vacuous <- TypeCheck var Bool
forall var. Eq var => TypeCheck var Bool
contextEntailsBottom
  pure [ recBottomT | vacuous ]

-- | Whether the local tope context is covered by the union of the given topes —
-- the coverage obligation of @recOR@ (see 'contextEntailsUnion'), but as a pure
-- yes\/no query rather than a check that issues an error.
coverageHolds :: Eq var => [TermT var] -> TypeCheck var Bool
coverageHolds :: forall var. Eq var => [TermT var] -> TypeCheck var Bool
coverageHolds [TermT var]
topes = do
  contextTopes <- (Context var -> [ModalTope var])
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [ModalTope var]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context var -> [ModalTope var]
forall var. Context var -> [ModalTope var]
localTopesNF
  topesNF      <- mapM nfTope topes
  contextTopes `entailM` foldr topeOrT topeBottomT topesNF

-- | Tope case-split moves: ways to build a value of the goal by @recOR@,
-- splitting the proof over a cover of the local tope context. Three sources,
-- offered together (the UI ranks and filters):
--
--   * each disjunction @ψ ∨ φ@ already in the context becomes
--     @recOR(ψ ↦ ?, φ ↦ ?)@ — its cover is immediate;
--   * when the goal is an extension type, its restriction faces are a cover
--     candidate @recOR(ψ₁ ↦ ?, …)@, offered only when they actually cover the
--     context (so the move typechecks);
--   * a generic two-way split @recOR(? ↦ ?, ? ↦ ?)@ with the guards left as
--     holes, for an unusual split the player fills in by hand.
--
-- All three are offered only in a setting where a split makes sense — a cube
-- variable is in scope, the context has a non-trivial tope, or the goal is a
-- restricted type — so an ordinary (tope-free) goal is left alone.
recOrCandidates :: Eq var => TermT var -> TypeCheck var [TermT var]
recOrCandidates :: forall var. Eq var => TermT var -> TypeCheck var [TermT var]
recOrCandidates TermT var
goal = do
  goalW   <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
goal
  topes   <- asks (filter (/= topeTopT) . availableTopes)
  locals  <- asks (filter (not . varIsTopLevel . snd) . varInfos)
  hasCube <- or <$> mapM (fmap isCubeType . whnfT . varType . snd) locals
  let stripped     = TermT var -> TermT var
forall var. TermT var -> TermT var
stripTypeRestrictions TermT var
goalW
      mkRecOr [TermT var]
gs   = TermT var -> [(TermT var, TermT var)] -> TermT var
forall var. TermT var -> [(TermT var, TermT var)] -> TermT var
recOrT TermT var
stripped [ (TermT var
g, TermT var -> TermT var
forall var. TermT var -> TermT var
mkHole TermT var
stripped) | TermT var
g <- [TermT var]
gs ]
      fromContext  = [ [TermT var] -> TermT var
mkRecOr [TermT var
l, TermT var
r] | TopeOrT TypeInfo (TermT var)
_ TermT var
l TermT var
r <- [TermT var]
topes ]
      faces        = case TermT var
goalW of
        TypeRestrictedT TypeInfo (TermT var)
_ TermT var
_ [(TermT var, TermT var)]
rs -> ((TermT var, TermT var) -> TermT var)
-> [(TermT var, TermT var)] -> [TermT var]
forall a b. (a -> b) -> [a] -> [b]
map (TermT var, TermT var) -> TermT var
forall a b. (a, b) -> a
fst [(TermT var, TermT var)]
rs
        TermT var
_                      -> []
      isRestricted = case TermT var
goalW of TypeRestrictedT{} -> Bool
True; TermT var
_ -> Bool
False
      inShape      = Bool
hasCube Bool -> Bool -> Bool
|| Bool -> Bool
not ([TermT var] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TermT var]
topes) Bool -> Bool -> Bool
|| Bool
isRestricted
      generic      = [ TermT var -> [(TermT var, TermT var)] -> TermT var
forall var. TermT var -> [(TermT var, TermT var)] -> TermT var
recOrT TermT var
stripped [ (TermT var -> TermT var
forall var. TermT var -> TermT var
mkHole TermT var
forall var. TermT var
topeT, TermT var -> TermT var
forall var. TermT var -> TermT var
mkHole TermT var
stripped)
                                       , (TermT var -> TermT var
forall var. TermT var -> TermT var
mkHole TermT var
forall var. TermT var
topeT, TermT var -> TermT var
forall var. TermT var -> TermT var
mkHole TermT var
stripped) ]
                     | Bool
inShape ]
  fromFaces <- if length faces >= 2
    then do covered <- coverageHolds faces
            pure [ mkRecOr faces | covered ]
    else pure []
  pure (fromContext <> fromFaces <> generic)
  where
    mkHole :: FS (AnnF TypeInfo TermF) a -> FS (AnnF TypeInfo TermF) a
mkHole FS (AnnF TypeInfo TermF) a
t = TypeInfo (FS (AnnF TypeInfo TermF) a)
-> Maybe VarIdent -> FS (AnnF TypeInfo TermF) a
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> Maybe VarIdent -> FS (AnnF ann TermF) a
HoleT TypeInfo{ infoType :: FS (AnnF TypeInfo TermF) a
infoType = FS (AnnF TypeInfo TermF) a
t, infoWHNF :: Maybe (FS (AnnF TypeInfo TermF) a)
infoWHNF = Maybe (FS (AnnF TypeInfo TermF) a)
forall a. Maybe a
Nothing, infoNF :: Maybe (FS (AnnF TypeInfo TermF) a)
infoNF = Maybe (FS (AnnF TypeInfo TermF) a)
forall a. Maybe a
Nothing } Maybe VarIdent
forall a. Maybe a
Nothing

-- | Record the goal and local context at a hole (lenient mode only). The goal,
-- the local hypotheses, and the tope assumptions are all rendered to
-- user-facing 'VarIdent' names here — reusing the same resolution as
-- 'ppTermInContext' — so the resulting 'HoleInfo' is independent of the De
-- Bruijn scope. The global environment is deliberately excluded (only
-- @varIsTopLevel == False@ locals are kept), and locals are split into cube
-- variables and ordinary term variables.
recordHole :: Eq var => Maybe VarIdent -> TermT var -> TypeCheck var ()
recordHole :: forall var.
Eq var =>
Maybe VarIdent -> TermT var -> TypeCheck var ()
recordHole Maybe VarIdent
mname TermT var
goalTy = Maybe VarIdent
-> TermT var -> Maybe (Binder, TermT (Inc var)) -> TypeCheck var ()
forall var.
Eq var =>
Maybe VarIdent
-> TermT var -> Maybe (Binder, TermT (Inc var)) -> TypeCheck var ()
recordHoleShape Maybe VarIdent
mname TermT var
goalTy Maybe (Binder, TermT (Inc var))
forall a. Maybe a
Nothing

-- | Record a hole. When the hole is the argument of a shape-restricted function
-- its goal is a /shape/: the cube @goalTy@ together with a membership tope. The
-- tope is a scope over the shape's bound variable (the third argument carries
-- the declared binder name, if any, and the tope); it is rendered under that
-- binder so the goal reads @(binder : goalTy | tope)@.
recordHoleShape
  :: Eq var
  => Maybe VarIdent
  -> TermT var
  -> Maybe (Binder, TermT (Inc var))
  -> TypeCheck var ()
recordHoleShape :: forall var.
Eq var =>
Maybe VarIdent
-> TermT var -> Maybe (Binder, TermT (Inc var)) -> TypeCheck var ()
recordHoleShape Maybe VarIdent
mname TermT var
goalTy Maybe (Binder, TermT (Inc var))
mshape = do
  goal'     <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
goalTy
  locals    <- asks (filter (not . varIsTopLevel . snd) . varInfos)
  -- named top-level lemmas the caller allow-listed for hints (see 'hintLemmas').
  -- They feed the candidate-elimination loop only — not the local context shown
  -- to the user, since they are global definitions, not local hypotheses.
  lemmas    <- asks hintLemmas
  lemmaVars <- asks (filter (\(var
_, VarInfo var
i) -> VarInfo var -> Bool
forall var. VarInfo var -> Bool
varIsTopLevel VarInfo var
i Bool -> Bool -> Bool
&& Bool -> (VarIdent -> Bool) -> Maybe VarIdent -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (VarIdent -> [VarIdent] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [VarIdent]
lemmas) (Binder -> Maybe VarIdent
binderName (VarInfo var -> Binder
forall var. VarInfo var -> Binder
varOrig VarInfo var
i))) . varInfos)
  cubeFlags <- mapM (fmap isCubeType . whnfT . varType . snd) locals
  topes     <- asks (filter (/= topeTopT) . availableTopes)
  origs     <- asks varOrigs
  binders   <- asks varBinders
  loc       <- asks location
  -- for each local hypothesis (and allow-listed lemma), the elimination spines
  -- that land in the goal (arguments left as holes). Probing must not leak holes
  -- into the recorded output, hence 'censor'.
  candidates <- censor (const []) $ do
    elims  <- concat <$> mapM (\(var
v, VarInfo var
_) -> TermT var
-> TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [TermT var]
forall var.
Eq var =>
TermT var -> TermT var -> TypeCheck var [TermT var]
allEliminationsInto TermT var
goalTy (var -> TermT var
forall (t :: * -> * -> *) a. a -> FS t a
Pure var
v)) (locals ++ lemmaVars)
    -- context-driven moves (independent of the goal's head and the hypotheses):
    -- ex falso in a contradictory context, and tope case-splits. recOR and recBOT
    -- are term-level eliminators, so they are offered only for a term goal — not
    -- when the hole is a cube point or a tope, where they cannot appear.
    let termLayer = Bool -> Bool
not (TermT var -> Bool
forall var. TermT var -> Bool
isCubeOrTopeType TermT var
goal')
    recbot <- if termLayer then recBottomCandidates    else pure []
    recor  <- if termLayer then recOrCandidates goalTy else pure []
    pure (elims <> recbot <> recor)
  let shapeTope     = (Binder, TermT (Inc var)) -> TermT (Inc var)
forall a b. (a, b) -> b
snd ((Binder, TermT (Inc var)) -> TermT (Inc var))
-> Maybe (Binder, TermT (Inc var)) -> Maybe (TermT (Inc var))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Binder, TermT (Inc var))
mshape
      shapeTopeVars = [var]
-> (TermT (Inc var) -> [var]) -> Maybe (TermT (Inc var)) -> [var]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\TermT (Inc var)
t -> [ var
v | S var
v <- (Inc var -> [Inc var] -> [Inc var])
-> [Inc var] -> TermT (Inc var) -> [Inc var]
forall a b. (a -> b -> b) -> b -> FS (AnnF TypeInfo TermF) a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (:) [] TermT (Inc var)
t ]) Maybe (TermT (Inc var))
shapeTope
  varsList  <- concat <$> mapM freeVarsT_ (goal' : map (varType . snd) (locals ++ lemmaVars) ++ topes)
  let mapping  = [var] -> [VarIdent] -> [(var, VarIdent)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([var] -> [var]
forall a. Eq a => [a] -> [a]
nub ([var]
varsList [var] -> [var] -> [var]
forall a. [a] -> [a] -> [a]
++ [var]
shapeTopeVars [var] -> [var] -> [var]
forall a. [a] -> [a] -> [a]
++ ((var, VarInfo var) -> var) -> [(var, VarInfo var)] -> [var]
forall a b. (a -> b) -> [a] -> [b]
map (var, VarInfo var) -> var
forall a b. (a, b) -> a
fst ([(var, VarInfo var)]
locals [(var, VarInfo var)]
-> [(var, VarInfo var)] -> [(var, VarInfo var)]
forall a. [a] -> [a] -> [a]
++ [(var, VarInfo var)]
lemmaVars))) [VarIdent]
defaultVarIdents
      name var
v   = VarIdent -> Maybe VarIdent -> VarIdent
forall a. a -> Maybe a -> a
fromMaybe VarIdent
"_" (Maybe (Maybe VarIdent) -> Maybe VarIdent
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (var -> [(var, Maybe VarIdent)] -> Maybe (Maybe VarIdent)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup var
v [(var, Maybe VarIdent)]
origs) Maybe VarIdent -> Maybe VarIdent -> Maybe VarIdent
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> var -> [(var, VarIdent)] -> Maybe VarIdent
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup var
v [(var, VarIdent)]
mapping)
      fbs      = (var -> VarIdent)
-> [(var, VarIdent)] -> [(var, Binder)] -> [(var, Binder)]
forall var.
Eq var =>
(var -> VarIdent)
-> [(var, VarIdent)] -> [(var, Binder)] -> [(var, Binder)]
freshBinders var -> VarIdent
name [(var, VarIdent)]
mapping [(var, Binder)]
binders
      render FS (AnnF ann TermF) var
t = [(VarIdent, Binder)] -> Term VarIdent -> Term VarIdent
restorePatternVars [ (var -> VarIdent
name var
v, Binder
b) | (var
v, Binder
b) <- [(var, Binder)]
fbs ]
                   ([(VarIdent, [([Proj], VarIdent)])]
-> Term VarIdent -> Term VarIdent
forall a. Eq a => [(a, [([Proj], a)])] -> Term a -> Term a
foldBinderProjections ((var -> VarIdent)
-> [(var, Binder)] -> [(VarIdent, [([Proj], VarIdent)])]
forall var.
(var -> VarIdent)
-> [(var, Binder)] -> [(VarIdent, [([Proj], VarIdent)])]
binderProjMap var -> VarIdent
name [(var, Binder)]
fbs) (FS (AnnF ann TermF) VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped (var -> VarIdent
name (var -> VarIdent)
-> FS (AnnF ann TermF) var -> FS (AnnF ann TermF) VarIdent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FS (AnnF ann TermF) var
t)))
      -- a pattern binder is shown as its pattern, e.g. (t , s); others by name
      entryName var
v = VarIdent -> (Binder -> VarIdent) -> Maybe Binder -> VarIdent
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (var -> VarIdent
name var
v) Binder -> VarIdent
binderDisplayName (var -> [(var, Binder)] -> Maybe Binder
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup var
v [(var, Binder)]
fbs)
      entries  = [ VarIdent -> Term VarIdent -> HoleEntry
HoleEntry (var -> VarIdent
entryName var
v) (TermT var -> Term VarIdent
forall {ann :: * -> *}.
Functor ann =>
FS (AnnF ann TermF) var -> Term VarIdent
render (VarInfo var -> TermT var
forall var. VarInfo var -> TermT var
varType VarInfo var
info)) | (var
v, VarInfo var
info) <- [(var, VarInfo var)]
locals ]
      flagged  = [Bool] -> [HoleEntry] -> [(Bool, HoleEntry)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Bool]
cubeFlags [HoleEntry]
entries
      -- binder name for the shape: the declared name if any, else a default
      shapeBinder   = VarIdent -> Maybe VarIdent -> VarIdent
forall a. a -> Maybe a -> a
fromMaybe (String -> VarIdent
forall a. IsString a => String -> a
fromString String
"t") (Binder -> Maybe VarIdent
binderName (Binder -> Maybe VarIdent) -> Maybe Binder -> Maybe VarIdent
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ((Binder, TermT (Inc var)) -> Binder
forall a b. (a, b) -> a
fst ((Binder, TermT (Inc var)) -> Binder)
-> Maybe (Binder, TermT (Inc var)) -> Maybe Binder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Binder, TermT (Inc var))
mshape))
      nameInc Inc var
Z     = VarIdent
shapeBinder
      nameInc (S var
v) = var -> VarIdent
name var
v
      goalShape = (\TermT (Inc var)
t -> (VarIdent
shapeBinder, TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped (Inc var -> VarIdent
nameInc (Inc var -> VarIdent) -> TermT (Inc var) -> TermT VarIdent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT (Inc var)
t))) (TermT (Inc var) -> (VarIdent, Term VarIdent))
-> Maybe (TermT (Inc var)) -> Maybe (VarIdent, Term VarIdent)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (TermT (Inc var))
shapeTope
      -- names already visible at the hole, which an introduced binder must not
      -- shadow: each local hypothesis by its display name, or the leaves of a
      -- pattern hypothesis.
      inScopeNames = [ VarIdent
nm | (var
v, VarInfo var
_) <- [(var, VarInfo var)]
locals
                          , VarIdent
nm <- [VarIdent] -> (Binder -> [VarIdent]) -> Maybe Binder -> [VarIdent]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [var -> VarIdent
name var
v] Binder -> [VarIdent]
binderLeaves (var -> [(var, Binder)] -> Maybe Binder
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup var
v [(var, Binder)]
fbs) ]
  -- the introduction forms for the goal itself (constituents left as holes); the
  -- Π binder is freshened against 'inScopeNames' so it does not shadow.
  introductions <- censor (const []) (allIntroductionsOf goalTy inScopeNames)
  -- the goal cell: an SVG of the shape the hole must inhabit (an arrow, triangle
  -- or square), drawn from an abstract inhabitant with the proof term hidden.
  -- 'Nothing' when the goal is not a renderable shape.
  diagram <- censor (const []) (renderGoalCellSVG goal')
  lift $ tell
    [ HoleInfo
        { holeName      = mname
        , holeGoal      = render goal'
        , holeGoalShape = goalShape
        , holeTermVars  = [ e | (False, e) <- flagged ]
        , holeCubeVars  = [ e | (True,  e) <- flagged ]
        , holeTopes     = map render topes
        , holeCandidates = map render candidates
        , holeIntroductions = map render introductions
        , holeDiagram  = diagram
        , holeLocation  = loc
        } ]

-- | Check a hole that appears as the argument of a shape-restricted function,
-- whose domain is the cube @cube@ restricted by @tope@ (a scope over the
-- domain's bound variable). Mirrors the hole case of 'typecheck', but records
-- the shape as the hole's goal so the diagnostic shows @(binder : cube | tope)@.
checkHoleAgainstShape
  :: Eq var
  => Maybe VarIdent -> Binder -> TermT var -> TermT (Inc var)
  -> TypeCheck var (TermT var)
checkHoleAgainstShape :: forall var.
Eq var =>
Maybe VarIdent
-> Binder
-> TermT var
-> TermT (Inc var)
-> TypeCheck var (TermT var)
checkHoleAgainstShape Maybe VarIdent
mname Binder
orig TermT var
cube TermT (Inc var)
tope = do
  reject <- (Context var -> Bool)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context var -> Bool
forall var. Context var -> Bool
holesAreErrors
  if reject
    then issueTypeError (TypeErrorUnsolvedHole mname cube)
    else do
      recordHoleShape mname cube (Just (orig, tope))
      return (HoleT TypeInfo{ infoType = cube, infoWHNF = Nothing, infoNF = Nothing } mname)

ppSomeAction :: Eq var => [(var, Maybe VarIdent)] -> Int -> Action var -> String
ppSomeAction :: forall var.
Eq var =>
[(var, Maybe VarIdent)] -> Int -> Action var -> String
ppSomeAction [(var, Maybe VarIdent)]
origs Int
n Action var
action = [(VarIdent, Binder)] -> Int -> Action VarIdent -> String
ppAction [] Int
n (var -> VarIdent
toRzkVarIdent (var -> VarIdent) -> Action var -> Action VarIdent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Action var
action)
  where
    vars :: [var]
vars = [var] -> [var]
forall a. Eq a => [a] -> [a]
nub ((var -> [var]) -> Action var -> [var]
forall m a. Monoid m => (a -> m) -> Action a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap var -> [var]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Action var
action)
    mapping :: [(var, VarIdent)]
mapping = [var] -> [VarIdent] -> [(var, VarIdent)]
forall a b. [a] -> [b] -> [(a, b)]
zip [var]
vars [VarIdent]
defaultVarIdents
    toRzkVarIdent :: var -> VarIdent
toRzkVarIdent var
var = VarIdent -> Maybe VarIdent -> VarIdent
forall a. a -> Maybe a -> a
fromMaybe VarIdent
"_" (Maybe VarIdent -> VarIdent) -> Maybe VarIdent -> VarIdent
forall a b. (a -> b) -> a -> b
$
      Maybe (Maybe VarIdent) -> Maybe VarIdent
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (var -> [(var, Maybe VarIdent)] -> Maybe (Maybe VarIdent)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup var
var [(var, Maybe VarIdent)]
origs) Maybe VarIdent -> Maybe VarIdent -> Maybe VarIdent
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> var -> [(var, VarIdent)] -> Maybe VarIdent
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup var
var [(var, VarIdent)]
mapping

ppAction :: [(VarIdent, Binder)] -> Int -> Action' -> String
ppAction :: [(VarIdent, Binder)] -> Int -> Action VarIdent -> String
ppAction [(VarIdent, Binder)]
fbs Int
n = [String] -> String
unlines ([String] -> String)
-> (Action VarIdent -> [String]) -> Action VarIdent -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
n) Char
' ' String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) ([String] -> [String])
-> (Action VarIdent -> [String]) -> Action VarIdent -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
  ActionTypeCheck Term VarIdent
term TermT VarIdent
ty ->
    [ String
"typechecking"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU Term VarIdent
term
    , String
"against type"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
ty) ]

  ActionUnify TermT VarIdent
term TermT VarIdent
expected TermT VarIdent
actual ->
    [ String
"unifying expected type"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
expected)
    , String
"with actual type"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
actual)
    , String
"for term"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
term) ]

  ActionUnifyTerms TermT VarIdent
expected TermT VarIdent
actual ->
    [ String
"unifying term (expected)"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TermT VarIdent -> String
ppTyped TermT VarIdent
expected
    , String
"with term (actual)"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TermT VarIdent -> String
ppTyped TermT VarIdent
actual ]

  ActionInfer Term VarIdent
term ->
    [ String
"inferring type for term"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU Term VarIdent
term ]

  ActionContextEntailedBy [TermT VarIdent]
ctxTopes TermT VarIdent
term ->
    [ String
"checking if local context"
    , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ((TermT VarIdent -> String) -> [TermT VarIdent] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (String -> String)
-> (TermT VarIdent -> String) -> TermT VarIdent -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term VarIdent -> String
ppU (Term VarIdent -> String)
-> (TermT VarIdent -> Term VarIdent) -> TermT VarIdent -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped) [TermT VarIdent]
ctxTopes)
    , String
"includes (is entailed by) restriction tope"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
term) ]

  ActionContextEntails [TermT VarIdent]
ctxTopes TermT VarIdent
term ->
    [ String
"checking if local context"
    , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ((TermT VarIdent -> String) -> [TermT VarIdent] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (String -> String)
-> (TermT VarIdent -> String) -> TermT VarIdent -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term VarIdent -> String
ppU (Term VarIdent -> String)
-> (TermT VarIdent -> Term VarIdent) -> TermT VarIdent -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped) [TermT VarIdent]
ctxTopes)
    , String
"is included in (entails) the tope"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
term) ]

  ActionContextEntailsUnion [TermT VarIdent]
ctxTopes [TermT VarIdent]
terms ->
    [ String
"checking if local context"
    , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ((TermT VarIdent -> String) -> [TermT VarIdent] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (String -> String)
-> (TermT VarIdent -> String) -> TermT VarIdent -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term VarIdent -> String
ppU (Term VarIdent -> String)
-> (TermT VarIdent -> Term VarIdent) -> TermT VarIdent -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped) [TermT VarIdent]
ctxTopes)
    , String
"is included in (entails) the union of the topes"
    , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ((TermT VarIdent -> String) -> [TermT VarIdent] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (String -> String)
-> (TermT VarIdent -> String) -> TermT VarIdent -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term VarIdent -> String
ppU (Term VarIdent -> String)
-> (TermT VarIdent -> Term VarIdent) -> TermT VarIdent -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped) [TermT VarIdent]
terms) ]

  ActionWHNF TermT VarIdent
term ->
    [ String
"computing WHNF for term"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TermT VarIdent -> String
ppTyped TermT VarIdent
term ]

  ActionNF TermT VarIdent
term ->
    [ String
"computing normal form for term"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
term) ]

  ActionCheckCoherence (TermT VarIdent
ltope, TermT VarIdent
lterm) (TermT VarIdent
rtope, TermT VarIdent
rterm) ->
    [ String
"checking coherence for"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
ltope)
    , String
"  |-> " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
lterm)
    , String
"and"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
rtope)
    , String
"  |-> " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
rterm) ]

  ActionCloseSection Maybe SectionName
Nothing ->
    [ String
"closing the file"
    , String
"and collecting assumptions (variables)" ]
  ActionCloseSection (Just SectionName
sectionName) ->
    [ String
"closing #section " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SectionName -> String
forall a. Print a => a -> String
Rzk.printTree SectionName
sectionName
    , String
"and collecting assumptions (variables)"]

  ActionCheckLetValue Maybe VarIdent
orig ->
    [ String
"checking the local definition "
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> (VarIdent -> String) -> Maybe VarIdent -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"_" (VarIdent' RzkPosition -> String
forall a. Print a => a -> String
Rzk.printTree (VarIdent' RzkPosition -> String)
-> (VarIdent -> VarIdent' RzkPosition) -> VarIdent -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarIdent -> VarIdent' RzkPosition
getVarIdent) Maybe VarIdent
orig ]
  where
    ppU :: Term' -> String
    ppU :: Term VarIdent -> String
ppU = [(VarIdent, Binder)] -> Term VarIdent -> String
ppFoldU [(VarIdent, Binder)]
fbs
    ppTyped :: TermT' -> String
    ppTyped :: TermT VarIdent -> String
ppTyped = [(VarIdent, Binder)] -> TermT VarIdent -> String
ppFoldT [(VarIdent, Binder)]
fbs


traceAction' :: Int -> Action' -> a -> a
traceAction' :: forall a. Int -> Action VarIdent -> a -> a
traceAction' Int
n Action VarIdent
action = String -> a -> a
forall a. String -> a -> a
trace (String
"[debug]\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [(VarIdent, Binder)] -> Int -> Action VarIdent -> String
ppAction [] Int
n Action VarIdent
action)

unsafeTraceAction' :: Int -> Action var -> a -> a
unsafeTraceAction' :: forall var a. Int -> Action var -> a -> a
unsafeTraceAction' Int
n = Int -> Action VarIdent -> a -> a
forall a. Int -> Action VarIdent -> a -> a
traceAction' Int
n (Action VarIdent -> a -> a)
-> (Action var -> Action VarIdent) -> Action var -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Action var -> Action VarIdent
forall a b. a -> b
unsafeCoerce

data LocationInfo = LocationInfo
  { LocationInfo -> Maybe String
locationFilePath :: Maybe FilePath
  , LocationInfo -> Maybe Int
locationLine     :: Maybe Int
  } deriving (LocationInfo -> LocationInfo -> Bool
(LocationInfo -> LocationInfo -> Bool)
-> (LocationInfo -> LocationInfo -> Bool) -> Eq LocationInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LocationInfo -> LocationInfo -> Bool
== :: LocationInfo -> LocationInfo -> Bool
$c/= :: LocationInfo -> LocationInfo -> Bool
/= :: LocationInfo -> LocationInfo -> Bool
Eq, Int -> LocationInfo -> String -> String
[LocationInfo] -> String -> String
LocationInfo -> String
(Int -> LocationInfo -> String -> String)
-> (LocationInfo -> String)
-> ([LocationInfo] -> String -> String)
-> Show LocationInfo
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> LocationInfo -> String -> String
showsPrec :: Int -> LocationInfo -> String -> String
$cshow :: LocationInfo -> String
show :: LocationInfo -> String
$cshowList :: [LocationInfo] -> String -> String
showList :: [LocationInfo] -> String -> String
Show)

data Verbosity
  = Debug
  | Normal
  | Silent
  deriving (Verbosity -> Verbosity -> Bool
(Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool) -> Eq Verbosity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Verbosity -> Verbosity -> Bool
== :: Verbosity -> Verbosity -> Bool
$c/= :: Verbosity -> Verbosity -> Bool
/= :: Verbosity -> Verbosity -> Bool
Eq, Eq Verbosity
Eq Verbosity =>
(Verbosity -> Verbosity -> Ordering)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Verbosity)
-> (Verbosity -> Verbosity -> Verbosity)
-> Ord Verbosity
Verbosity -> Verbosity -> Bool
Verbosity -> Verbosity -> Ordering
Verbosity -> Verbosity -> Verbosity
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Verbosity -> Verbosity -> Ordering
compare :: Verbosity -> Verbosity -> Ordering
$c< :: Verbosity -> Verbosity -> Bool
< :: Verbosity -> Verbosity -> Bool
$c<= :: Verbosity -> Verbosity -> Bool
<= :: Verbosity -> Verbosity -> Bool
$c> :: Verbosity -> Verbosity -> Bool
> :: Verbosity -> Verbosity -> Bool
$c>= :: Verbosity -> Verbosity -> Bool
>= :: Verbosity -> Verbosity -> Bool
$cmax :: Verbosity -> Verbosity -> Verbosity
max :: Verbosity -> Verbosity -> Verbosity
$cmin :: Verbosity -> Verbosity -> Verbosity
min :: Verbosity -> Verbosity -> Verbosity
Ord)

trace' :: Verbosity -> Verbosity -> String -> a -> a
trace' :: forall a. Verbosity -> Verbosity -> String -> a -> a
trace' Verbosity
msgLevel Verbosity
currentLevel
  | Verbosity
currentLevel Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
<= Verbosity
msgLevel = String -> a -> a
forall a. String -> a -> a
trace
  | Bool
otherwise                = (a -> a) -> String -> a -> a
forall a b. a -> b -> a
const a -> a
forall a. a -> a
id

traceTypeCheck :: Verbosity -> String -> TypeCheck var a -> TypeCheck var a
traceTypeCheck :: forall var a.
Verbosity -> String -> TypeCheck var a -> TypeCheck var a
traceTypeCheck Verbosity
msgLevel String
msg TypeCheck var a
tc = do
  Context{..} <- ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (Context var)
forall r (m :: * -> *). MonadReader r m => m r
ask
  trace' msgLevel verbosity msg tc

localVerbosity :: Verbosity -> TypeCheck var a -> TypeCheck var a
localVerbosity :: forall var a. Verbosity -> TypeCheck var a -> TypeCheck var a
localVerbosity Verbosity
v = (Context var -> Context var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall a.
(Context var -> Context var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((Context var -> Context var)
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      a
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      a)
-> (Context var -> Context var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall a b. (a -> b) -> a -> b
$ \Context{Bool
[[ModalTope var]]
[VarIdent]
[ModalTope var]
[ScopeInfo var]
[Action var]
Maybe Bool
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: forall var. Context var -> Maybe LocationInfo
hintLemmas :: forall var. Context var -> [VarIdent]
deferHoleMismatches :: forall var. Context var -> Bool
holesAreErrors :: forall var. Context var -> Bool
renderHideTerm :: forall var. Context var -> Bool
renderBackend :: forall var. Context var -> Maybe RenderBackend
covariance :: forall var. Context var -> Covariance
verbosity :: forall var. Context var -> Verbosity
currentCommand :: forall var. Context var -> Maybe Command
actionStack :: forall var. Context var -> [Action var]
localTopesEntailBottom :: forall var. Context var -> Maybe Bool
localTopesNFUnion :: forall var. Context var -> [[ModalTope var]]
localTopesNF :: forall var. Context var -> [ModalTope var]
localTopes :: forall var. Context var -> [ModalTope var]
localScopes :: forall var. Context var -> [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopes :: [ModalTope var]
localTopesNF :: [ModalTope var]
localTopesNFUnion :: [[ModalTope var]]
localTopesEntailBottom :: Maybe Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
renderHideTerm :: Bool
holesAreErrors :: Bool
deferHoleMismatches :: Bool
hintLemmas :: [VarIdent]
..} -> Context { verbosity :: Verbosity
verbosity = Verbosity
v, Bool
[[ModalTope var]]
[VarIdent]
[ModalTope var]
[ScopeInfo var]
[Action var]
Maybe Bool
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
location :: Maybe LocationInfo
hintLemmas :: [VarIdent]
deferHoleMismatches :: Bool
holesAreErrors :: Bool
renderHideTerm :: Bool
renderBackend :: Maybe RenderBackend
covariance :: Covariance
currentCommand :: Maybe Command
actionStack :: [Action var]
localTopesEntailBottom :: Maybe Bool
localTopesNFUnion :: [[ModalTope var]]
localTopesNF :: [ModalTope var]
localTopes :: [ModalTope var]
localScopes :: [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopes :: [ModalTope var]
localTopesNF :: [ModalTope var]
localTopesNFUnion :: [[ModalTope var]]
localTopesEntailBottom :: Maybe Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
covariance :: Covariance
renderBackend :: Maybe RenderBackend
renderHideTerm :: Bool
holesAreErrors :: Bool
deferHoleMismatches :: Bool
hintLemmas :: [VarIdent]
.. }

localRenderBackend :: Maybe RenderBackend -> TypeCheck var a -> TypeCheck var a
localRenderBackend :: forall var a.
Maybe RenderBackend -> TypeCheck var a -> TypeCheck var a
localRenderBackend Maybe RenderBackend
v = (Context var -> Context var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall a.
(Context var -> Context var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((Context var -> Context var)
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      a
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      a)
-> (Context var -> Context var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall a b. (a -> b) -> a -> b
$ \Context{Bool
[[ModalTope var]]
[VarIdent]
[ModalTope var]
[ScopeInfo var]
[Action var]
Maybe Bool
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: forall var. Context var -> Maybe LocationInfo
hintLemmas :: forall var. Context var -> [VarIdent]
deferHoleMismatches :: forall var. Context var -> Bool
holesAreErrors :: forall var. Context var -> Bool
renderHideTerm :: forall var. Context var -> Bool
renderBackend :: forall var. Context var -> Maybe RenderBackend
covariance :: forall var. Context var -> Covariance
verbosity :: forall var. Context var -> Verbosity
currentCommand :: forall var. Context var -> Maybe Command
actionStack :: forall var. Context var -> [Action var]
localTopesEntailBottom :: forall var. Context var -> Maybe Bool
localTopesNFUnion :: forall var. Context var -> [[ModalTope var]]
localTopesNF :: forall var. Context var -> [ModalTope var]
localTopes :: forall var. Context var -> [ModalTope var]
localScopes :: forall var. Context var -> [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopes :: [ModalTope var]
localTopesNF :: [ModalTope var]
localTopesNFUnion :: [[ModalTope var]]
localTopesEntailBottom :: Maybe Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
renderHideTerm :: Bool
holesAreErrors :: Bool
deferHoleMismatches :: Bool
hintLemmas :: [VarIdent]
..} -> Context { renderBackend :: Maybe RenderBackend
renderBackend = Maybe RenderBackend
v, Bool
[[ModalTope var]]
[VarIdent]
[ModalTope var]
[ScopeInfo var]
[Action var]
Maybe Bool
Maybe Command
Maybe LocationInfo
Covariance
Verbosity
location :: Maybe LocationInfo
hintLemmas :: [VarIdent]
deferHoleMismatches :: Bool
holesAreErrors :: Bool
renderHideTerm :: Bool
covariance :: Covariance
verbosity :: Verbosity
currentCommand :: Maybe Command
actionStack :: [Action var]
localTopesEntailBottom :: Maybe Bool
localTopesNFUnion :: [[ModalTope var]]
localTopesNF :: [ModalTope var]
localTopes :: [ModalTope var]
localScopes :: [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopes :: [ModalTope var]
localTopesNF :: [ModalTope var]
localTopesNFUnion :: [[ModalTope var]]
localTopesEntailBottom :: Maybe Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderHideTerm :: Bool
holesAreErrors :: Bool
deferHoleMismatches :: Bool
hintLemmas :: [VarIdent]
.. }

-- | Run the enclosed action with the 'renderHideTerm' policy set.
localHideTerm :: Bool -> TypeCheck var a -> TypeCheck var a
localHideTerm :: forall var a. Bool -> TypeCheck var a -> TypeCheck var a
localHideTerm Bool
v = (Context var -> Context var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall a.
(Context var -> Context var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((Context var -> Context var)
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      a
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      a)
-> (Context var -> Context var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall a b. (a -> b) -> a -> b
$ \Context var
ctx -> Context var
ctx { renderHideTerm = v }

-- | Render the enclosed action with the proof term hidden (see 'renderHideTerm').
hidingTerm :: TypeCheck var a -> TypeCheck var a
hidingTerm :: forall var a. TypeCheck var a -> TypeCheck var a
hidingTerm = Bool -> TypeCheck var a -> TypeCheck var a
forall var a. Bool -> TypeCheck var a -> TypeCheck var a
localHideTerm Bool
True

data Covariance
  = Covariant     -- ^ Positive position.
  | Contravariant -- ^ Negative position.
  | Invariant     -- ^ Unknown position.

data RenderBackend
  = RenderSVG
  | RenderLaTeX

data ScopeInfo var = ScopeInfo
  { forall var. ScopeInfo var -> Maybe SectionName
scopeName :: Maybe Rzk.SectionName
  , forall var. ScopeInfo var -> [(var, VarInfo var)]
scopeVars :: [(var, VarInfo var)]
  } deriving ((forall a b. (a -> b) -> ScopeInfo a -> ScopeInfo b)
-> (forall a b. a -> ScopeInfo b -> ScopeInfo a)
-> Functor ScopeInfo
forall a b. a -> ScopeInfo b -> ScopeInfo a
forall a b. (a -> b) -> ScopeInfo a -> ScopeInfo b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> ScopeInfo a -> ScopeInfo b
fmap :: forall a b. (a -> b) -> ScopeInfo a -> ScopeInfo b
$c<$ :: forall a b. a -> ScopeInfo b -> ScopeInfo a
<$ :: forall a b. a -> ScopeInfo b -> ScopeInfo a
Functor, (forall m. Monoid m => ScopeInfo m -> m)
-> (forall m a. Monoid m => (a -> m) -> ScopeInfo a -> m)
-> (forall m a. Monoid m => (a -> m) -> ScopeInfo a -> m)
-> (forall a b. (a -> b -> b) -> b -> ScopeInfo a -> b)
-> (forall a b. (a -> b -> b) -> b -> ScopeInfo a -> b)
-> (forall b a. (b -> a -> b) -> b -> ScopeInfo a -> b)
-> (forall b a. (b -> a -> b) -> b -> ScopeInfo a -> b)
-> (forall a. (a -> a -> a) -> ScopeInfo a -> a)
-> (forall a. (a -> a -> a) -> ScopeInfo a -> a)
-> (forall a. ScopeInfo a -> [a])
-> (forall a. ScopeInfo a -> Bool)
-> (forall a. ScopeInfo a -> Int)
-> (forall a. Eq a => a -> ScopeInfo a -> Bool)
-> (forall a. Ord a => ScopeInfo a -> a)
-> (forall a. Ord a => ScopeInfo a -> a)
-> (forall a. Num a => ScopeInfo a -> a)
-> (forall a. Num a => ScopeInfo a -> a)
-> Foldable ScopeInfo
forall a. Eq a => a -> ScopeInfo a -> Bool
forall a. Num a => ScopeInfo a -> a
forall a. Ord a => ScopeInfo a -> a
forall m. Monoid m => ScopeInfo m -> m
forall a. ScopeInfo a -> Bool
forall a. ScopeInfo a -> Int
forall a. ScopeInfo a -> [a]
forall a. (a -> a -> a) -> ScopeInfo a -> a
forall m a. Monoid m => (a -> m) -> ScopeInfo a -> m
forall b a. (b -> a -> b) -> b -> ScopeInfo a -> b
forall a b. (a -> b -> b) -> b -> ScopeInfo a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => ScopeInfo m -> m
fold :: forall m. Monoid m => ScopeInfo m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> ScopeInfo a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> ScopeInfo a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> ScopeInfo a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> ScopeInfo a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> ScopeInfo a -> b
foldr :: forall a b. (a -> b -> b) -> b -> ScopeInfo a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> ScopeInfo a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> ScopeInfo a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> ScopeInfo a -> b
foldl :: forall b a. (b -> a -> b) -> b -> ScopeInfo a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> ScopeInfo a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> ScopeInfo a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> ScopeInfo a -> a
foldr1 :: forall a. (a -> a -> a) -> ScopeInfo a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> ScopeInfo a -> a
foldl1 :: forall a. (a -> a -> a) -> ScopeInfo a -> a
$ctoList :: forall a. ScopeInfo a -> [a]
toList :: forall a. ScopeInfo a -> [a]
$cnull :: forall a. ScopeInfo a -> Bool
null :: forall a. ScopeInfo a -> Bool
$clength :: forall a. ScopeInfo a -> Int
length :: forall a. ScopeInfo a -> Int
$celem :: forall a. Eq a => a -> ScopeInfo a -> Bool
elem :: forall a. Eq a => a -> ScopeInfo a -> Bool
$cmaximum :: forall a. Ord a => ScopeInfo a -> a
maximum :: forall a. Ord a => ScopeInfo a -> a
$cminimum :: forall a. Ord a => ScopeInfo a -> a
minimum :: forall a. Ord a => ScopeInfo a -> a
$csum :: forall a. Num a => ScopeInfo a -> a
sum :: forall a. Num a => ScopeInfo a -> a
$cproduct :: forall a. Num a => ScopeInfo a -> a
product :: forall a. Num a => ScopeInfo a -> a
Foldable)

addVarToScope :: var -> VarInfo var -> ScopeInfo var -> ScopeInfo var
addVarToScope :: forall var. var -> VarInfo var -> ScopeInfo var -> ScopeInfo var
addVarToScope var
var VarInfo var
info ScopeInfo{[(var, VarInfo var)]
Maybe SectionName
scopeName :: forall var. ScopeInfo var -> Maybe SectionName
scopeVars :: forall var. ScopeInfo var -> [(var, VarInfo var)]
scopeName :: Maybe SectionName
scopeVars :: [(var, VarInfo var)]
..} = ScopeInfo
  { scopeVars :: [(var, VarInfo var)]
scopeVars = (var
var, VarInfo var
info) (var, VarInfo var) -> [(var, VarInfo var)] -> [(var, VarInfo var)]
forall a. a -> [a] -> [a]
: [(var, VarInfo var)]
scopeVars, Maybe SectionName
scopeName :: Maybe SectionName
scopeName :: Maybe SectionName
.. }

addModalityToScope :: TModality -> ScopeInfo var -> ScopeInfo var
addModalityToScope :: forall var. TModality -> ScopeInfo var -> ScopeInfo var
addModalityToScope TModality
md ScopeInfo{[(var, VarInfo var)]
Maybe SectionName
scopeName :: forall var. ScopeInfo var -> Maybe SectionName
scopeVars :: forall var. ScopeInfo var -> [(var, VarInfo var)]
scopeName :: Maybe SectionName
scopeVars :: [(var, VarInfo var)]
..} = ScopeInfo
  { scopeVars :: [(var, VarInfo var)]
scopeVars = ((var, VarInfo var) -> (var, VarInfo var))
-> [(var, VarInfo var)] -> [(var, VarInfo var)]
forall a b. (a -> b) -> [a] -> [b]
map (\(var
var, VarInfo{Bool
[var]
Maybe (TermT var)
Maybe LocationInfo
TermT var
TModality
Binder
varIsTopLevel :: forall var. VarInfo var -> Bool
varType :: forall var. VarInfo var -> TermT var
varOrig :: forall var. VarInfo var -> Binder
varType :: TermT var
varValue :: Maybe (TermT var)
varModality :: TModality
modAccum :: TModality
varOrig :: Binder
varIsAssumption :: Bool
varIsTopLevel :: Bool
varDeclaredAssumptions :: [var]
varLocation :: Maybe LocationInfo
varLocation :: forall var. VarInfo var -> Maybe LocationInfo
varDeclaredAssumptions :: forall var. VarInfo var -> [var]
varIsAssumption :: forall var. VarInfo var -> Bool
modAccum :: forall var. VarInfo var -> TModality
varModality :: forall var. VarInfo var -> TModality
varValue :: forall var. VarInfo var -> Maybe (TermT var)
..}) -> (var
var, VarInfo{ modAccum :: TModality
modAccum = TModality -> TModality -> TModality
forall m. ModeTheory m => m -> m -> m
comp TModality
modAccum TModality
md, Bool
[var]
Maybe (TermT var)
Maybe LocationInfo
TermT var
TModality
Binder
varIsTopLevel :: Bool
varType :: TermT var
varOrig :: Binder
varType :: TermT var
varValue :: Maybe (TermT var)
varModality :: TModality
varOrig :: Binder
varIsAssumption :: Bool
varIsTopLevel :: Bool
varDeclaredAssumptions :: [var]
varLocation :: Maybe LocationInfo
varLocation :: Maybe LocationInfo
varDeclaredAssumptions :: [var]
varIsAssumption :: Bool
varModality :: TModality
varValue :: Maybe (TermT var)
..})) [(var, VarInfo var)]
scopeVars, Maybe SectionName
scopeName :: Maybe SectionName
scopeName :: Maybe SectionName
.. }

data VarInfo var = VarInfo
  { forall var. VarInfo var -> TermT var
varType                :: TermT var
  , forall var. VarInfo var -> Maybe (TermT var)
varValue               :: Maybe (TermT var)
  , forall var. VarInfo var -> TModality
varModality            :: TModality
  , forall var. VarInfo var -> TModality
modAccum               :: TModality
  , forall var. VarInfo var -> Binder
varOrig                :: Binder
  , forall var. VarInfo var -> Bool
varIsAssumption        :: Bool -- FIXME: perhaps, introduce something like decl kind?
  , forall var. VarInfo var -> Bool
varIsTopLevel          :: Bool
  , forall var. VarInfo var -> [var]
varDeclaredAssumptions :: [var]
  , forall var. VarInfo var -> Maybe LocationInfo
varLocation            :: Maybe LocationInfo
  } deriving ((forall a b. (a -> b) -> VarInfo a -> VarInfo b)
-> (forall a b. a -> VarInfo b -> VarInfo a) -> Functor VarInfo
forall a b. a -> VarInfo b -> VarInfo a
forall a b. (a -> b) -> VarInfo a -> VarInfo b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> VarInfo a -> VarInfo b
fmap :: forall a b. (a -> b) -> VarInfo a -> VarInfo b
$c<$ :: forall a b. a -> VarInfo b -> VarInfo a
<$ :: forall a b. a -> VarInfo b -> VarInfo a
Functor, (forall m. Monoid m => VarInfo m -> m)
-> (forall m a. Monoid m => (a -> m) -> VarInfo a -> m)
-> (forall m a. Monoid m => (a -> m) -> VarInfo a -> m)
-> (forall a b. (a -> b -> b) -> b -> VarInfo a -> b)
-> (forall a b. (a -> b -> b) -> b -> VarInfo a -> b)
-> (forall b a. (b -> a -> b) -> b -> VarInfo a -> b)
-> (forall b a. (b -> a -> b) -> b -> VarInfo a -> b)
-> (forall a. (a -> a -> a) -> VarInfo a -> a)
-> (forall a. (a -> a -> a) -> VarInfo a -> a)
-> (forall var. VarInfo var -> [var])
-> (forall var. VarInfo var -> Bool)
-> (forall a. VarInfo a -> Int)
-> (forall a. Eq a => a -> VarInfo a -> Bool)
-> (forall a. Ord a => VarInfo a -> a)
-> (forall a. Ord a => VarInfo a -> a)
-> (forall a. Num a => VarInfo a -> a)
-> (forall a. Num a => VarInfo a -> a)
-> Foldable VarInfo
forall a. Eq a => a -> VarInfo a -> Bool
forall a. Num a => VarInfo a -> a
forall a. Ord a => VarInfo a -> a
forall m. Monoid m => VarInfo m -> m
forall var. VarInfo var -> Bool
forall a. VarInfo a -> Int
forall var. VarInfo var -> [var]
forall a. (a -> a -> a) -> VarInfo a -> a
forall m a. Monoid m => (a -> m) -> VarInfo a -> m
forall b a. (b -> a -> b) -> b -> VarInfo a -> b
forall a b. (a -> b -> b) -> b -> VarInfo a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => VarInfo m -> m
fold :: forall m. Monoid m => VarInfo m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> VarInfo a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> VarInfo a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> VarInfo a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> VarInfo a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> VarInfo a -> b
foldr :: forall a b. (a -> b -> b) -> b -> VarInfo a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> VarInfo a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> VarInfo a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> VarInfo a -> b
foldl :: forall b a. (b -> a -> b) -> b -> VarInfo a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> VarInfo a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> VarInfo a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> VarInfo a -> a
foldr1 :: forall a. (a -> a -> a) -> VarInfo a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> VarInfo a -> a
foldl1 :: forall a. (a -> a -> a) -> VarInfo a -> a
$ctoList :: forall var. VarInfo var -> [var]
toList :: forall var. VarInfo var -> [var]
$cnull :: forall var. VarInfo var -> Bool
null :: forall var. VarInfo var -> Bool
$clength :: forall a. VarInfo a -> Int
length :: forall a. VarInfo a -> Int
$celem :: forall a. Eq a => a -> VarInfo a -> Bool
elem :: forall a. Eq a => a -> VarInfo a -> Bool
$cmaximum :: forall a. Ord a => VarInfo a -> a
maximum :: forall a. Ord a => VarInfo a -> a
$cminimum :: forall a. Ord a => VarInfo a -> a
minimum :: forall a. Ord a => VarInfo a -> a
$csum :: forall a. Num a => VarInfo a -> a
sum :: forall a. Num a => VarInfo a -> a
$cproduct :: forall a. Num a => VarInfo a -> a
product :: forall a. Num a => VarInfo a -> a
Foldable)


class ModeTheory m where
    iden :: m
    comp :: m -> m -> m
    coe :: m -> m -> Bool
    isRA :: m -> Bool

instance ModeTheory TModality where
  iden :: TModality
iden = TModality
Id

  comp :: TModality -> TModality -> TModality
comp TModality
Flat TModality
Flat   = TModality
Flat
  comp TModality
Flat TModality
Sharp  = TModality
Flat
  comp TModality
Flat TModality
Op     = TModality
Flat
  comp TModality
Op TModality
Flat     = TModality
Flat
  comp TModality
Sharp TModality
Sharp = TModality
Sharp
  comp TModality
Sharp TModality
Flat  = TModality
Sharp
  comp TModality
Sharp TModality
Op    = TModality
Sharp
  comp TModality
Op TModality
Sharp    = TModality
Sharp
  comp TModality
Op TModality
Op       = TModality
Id
  comp TModality
Id TModality
m        = TModality
m
  comp TModality
m TModality
Id        = TModality
m

  coe :: TModality -> TModality -> Bool
coe TModality
Flat TModality
Id    = Bool
True
  coe TModality
Flat TModality
Op    = Bool
True
  coe TModality
Id TModality
Sharp   = Bool
True
  coe TModality
Flat TModality
Sharp = Bool
True
  coe TModality
Op TModality
Sharp   = Bool
True
  coe TModality
a TModality
b        = TModality
a TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
== TModality
b

  isRA :: TModality -> Bool
isRA TModality
Sharp = Bool
True 
  isRA TModality
Op = Bool
True 
  isRA TModality
Id = Bool
True
  isRA TModality
_ = Bool
False

data ModalTope var = ModalTope
  { forall var. ModalTope var -> TModality
tModAccum :: TModality
  , forall var. ModalTope var -> TModality
tModVar   :: TModality
  , forall var. ModalTope var -> TermT var
tTope     :: TermT var
  } deriving ((forall a b. (a -> b) -> ModalTope a -> ModalTope b)
-> (forall a b. a -> ModalTope b -> ModalTope a)
-> Functor ModalTope
forall a b. a -> ModalTope b -> ModalTope a
forall a b. (a -> b) -> ModalTope a -> ModalTope b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> ModalTope a -> ModalTope b
fmap :: forall a b. (a -> b) -> ModalTope a -> ModalTope b
$c<$ :: forall a b. a -> ModalTope b -> ModalTope a
<$ :: forall a b. a -> ModalTope b -> ModalTope a
Functor, (forall m. Monoid m => ModalTope m -> m)
-> (forall m a. Monoid m => (a -> m) -> ModalTope a -> m)
-> (forall m a. Monoid m => (a -> m) -> ModalTope a -> m)
-> (forall a b. (a -> b -> b) -> b -> ModalTope a -> b)
-> (forall a b. (a -> b -> b) -> b -> ModalTope a -> b)
-> (forall b a. (b -> a -> b) -> b -> ModalTope a -> b)
-> (forall b a. (b -> a -> b) -> b -> ModalTope a -> b)
-> (forall a. (a -> a -> a) -> ModalTope a -> a)
-> (forall a. (a -> a -> a) -> ModalTope a -> a)
-> (forall a. ModalTope a -> [a])
-> (forall a. ModalTope a -> Bool)
-> (forall a. ModalTope a -> Int)
-> (forall a. Eq a => a -> ModalTope a -> Bool)
-> (forall a. Ord a => ModalTope a -> a)
-> (forall a. Ord a => ModalTope a -> a)
-> (forall a. Num a => ModalTope a -> a)
-> (forall a. Num a => ModalTope a -> a)
-> Foldable ModalTope
forall a. Eq a => a -> ModalTope a -> Bool
forall a. Num a => ModalTope a -> a
forall a. Ord a => ModalTope a -> a
forall m. Monoid m => ModalTope m -> m
forall a. ModalTope a -> Bool
forall a. ModalTope a -> Int
forall a. ModalTope a -> [a]
forall a. (a -> a -> a) -> ModalTope a -> a
forall m a. Monoid m => (a -> m) -> ModalTope a -> m
forall b a. (b -> a -> b) -> b -> ModalTope a -> b
forall a b. (a -> b -> b) -> b -> ModalTope a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => ModalTope m -> m
fold :: forall m. Monoid m => ModalTope m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> ModalTope a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> ModalTope a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> ModalTope a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> ModalTope a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> ModalTope a -> b
foldr :: forall a b. (a -> b -> b) -> b -> ModalTope a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> ModalTope a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> ModalTope a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> ModalTope a -> b
foldl :: forall b a. (b -> a -> b) -> b -> ModalTope a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> ModalTope a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> ModalTope a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> ModalTope a -> a
foldr1 :: forall a. (a -> a -> a) -> ModalTope a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> ModalTope a -> a
foldl1 :: forall a. (a -> a -> a) -> ModalTope a -> a
$ctoList :: forall a. ModalTope a -> [a]
toList :: forall a. ModalTope a -> [a]
$cnull :: forall a. ModalTope a -> Bool
null :: forall a. ModalTope a -> Bool
$clength :: forall a. ModalTope a -> Int
length :: forall a. ModalTope a -> Int
$celem :: forall a. Eq a => a -> ModalTope a -> Bool
elem :: forall a. Eq a => a -> ModalTope a -> Bool
$cmaximum :: forall a. Ord a => ModalTope a -> a
maximum :: forall a. Ord a => ModalTope a -> a
$cminimum :: forall a. Ord a => ModalTope a -> a
minimum :: forall a. Ord a => ModalTope a -> a
$csum :: forall a. Num a => ModalTope a -> a
sum :: forall a. Num a => ModalTope a -> a
$cproduct :: forall a. Num a => ModalTope a -> a
product :: forall a. Num a => ModalTope a -> a
Foldable, ModalTope var -> ModalTope var -> Bool
(ModalTope var -> ModalTope var -> Bool)
-> (ModalTope var -> ModalTope var -> Bool) -> Eq (ModalTope var)
forall var. Eq var => ModalTope var -> ModalTope var -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall var. Eq var => ModalTope var -> ModalTope var -> Bool
== :: ModalTope var -> ModalTope var -> Bool
$c/= :: forall var. Eq var => ModalTope var -> ModalTope var -> Bool
/= :: ModalTope var -> ModalTope var -> Bool
Eq)

data Context var = Context
  { forall var. Context var -> [ScopeInfo var]
localScopes            :: [ScopeInfo var]
  , forall var. Context var -> [ModalTope var]
localTopes             :: [ModalTope var]
  , forall var. Context var -> [ModalTope var]
localTopesNF           :: [ModalTope var]
  , forall var. Context var -> [[ModalTope var]]
localTopesNFUnion      :: [[ModalTope var]]
  , forall var. Context var -> Maybe Bool
localTopesEntailBottom :: Maybe Bool
  , forall var. Context var -> [Action var]
actionStack            :: [Action var]
  , forall var. Context var -> Maybe Command
currentCommand         :: Maybe Rzk.Command
  , forall var. Context var -> Maybe LocationInfo
location               :: Maybe LocationInfo
  , forall var. Context var -> Verbosity
verbosity              :: Verbosity
  , forall var. Context var -> Covariance
covariance             :: Covariance
  , forall var. Context var -> Maybe RenderBackend
renderBackend          :: Maybe RenderBackend
    -- | When rendering a diagram, hide the proof term: drop the @\<title\>@
    -- (which carries the full term) from every cell and blank the visible label
    -- of proof-coloured (interior) cells, keeping the given boundary labels. So
    -- a worked term or an abstract inhabitant of a goal type is shown as the
    -- shape with its given edges, not the term that fills it.
  , forall var. Context var -> Bool
renderHideTerm     :: Bool
  , forall var. Context var -> Bool
holesAreErrors         :: Bool
    -- ^ When 'True' (the default), an unfilled hole is reported as a
    -- 'TypeErrorUnsolvedHole'; finished work (and CI) must have no holes. The
    -- lenient mode ('allowHoles') instead records each hole's goal and context.
  , forall var. Context var -> Bool
deferHoleMismatches    :: Bool
    -- ^ How holes behave during unification, giving three modes overall. With
    -- 'holesAreErrors' a hole is rejected outright (strict). Otherwise a hole
    -- always unifies as a leaf; this flag then chooses what happens when the
    -- /surrounding/ structure disagrees: 'True' (the default) defers — any term
    -- containing a hole is accepted, for an in-progress sketch — while 'False'
    -- keeps such a mismatch an error, so only a hole standing in a matching
    -- structure is accepted ('structuralHoleUnify').
  , forall var. Context var -> [VarIdent]
hintLemmas             :: [VarIdent]
    -- ^ Named top-level definitions a hole's candidate list may draw on, beyond
    -- the local hypotheses (see 'withHintLemmas'). A caller (the game) supplies
    -- a small curated allow-list per level; each listed lemma whose type fits
    -- the goal is then offered, applied to holes (e.g. @concat ? ? ?@).
  } deriving ((forall a b. (a -> b) -> Context a -> Context b)
-> (forall a b. a -> Context b -> Context a) -> Functor Context
forall a b. a -> Context b -> Context a
forall a b. (a -> b) -> Context a -> Context b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Context a -> Context b
fmap :: forall a b. (a -> b) -> Context a -> Context b
$c<$ :: forall a b. a -> Context b -> Context a
<$ :: forall a b. a -> Context b -> Context a
Functor, (forall m. Monoid m => Context m -> m)
-> (forall m a. Monoid m => (a -> m) -> Context a -> m)
-> (forall m a. Monoid m => (a -> m) -> Context a -> m)
-> (forall a b. (a -> b -> b) -> b -> Context a -> b)
-> (forall a b. (a -> b -> b) -> b -> Context a -> b)
-> (forall b a. (b -> a -> b) -> b -> Context a -> b)
-> (forall b a. (b -> a -> b) -> b -> Context a -> b)
-> (forall a. (a -> a -> a) -> Context a -> a)
-> (forall a. (a -> a -> a) -> Context a -> a)
-> (forall a. Context a -> [a])
-> (forall var. Context var -> Bool)
-> (forall a. Context a -> Int)
-> (forall a. Eq a => a -> Context a -> Bool)
-> (forall a. Ord a => Context a -> a)
-> (forall a. Ord a => Context a -> a)
-> (forall a. Num a => Context a -> a)
-> (forall a. Num a => Context a -> a)
-> Foldable Context
forall a. Eq a => a -> Context a -> Bool
forall a. Num a => Context a -> a
forall a. Ord a => Context a -> a
forall m. Monoid m => Context m -> m
forall var. Context var -> Bool
forall a. Context a -> Int
forall a. Context a -> [a]
forall a. (a -> a -> a) -> Context a -> a
forall m a. Monoid m => (a -> m) -> Context a -> m
forall b a. (b -> a -> b) -> b -> Context a -> b
forall a b. (a -> b -> b) -> b -> Context a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => Context m -> m
fold :: forall m. Monoid m => Context m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Context a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Context a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Context a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> Context a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> Context a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Context a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Context a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Context a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Context a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Context a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Context a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> Context a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> Context a -> a
foldr1 :: forall a. (a -> a -> a) -> Context a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Context a -> a
foldl1 :: forall a. (a -> a -> a) -> Context a -> a
$ctoList :: forall a. Context a -> [a]
toList :: forall a. Context a -> [a]
$cnull :: forall var. Context var -> Bool
null :: forall var. Context var -> Bool
$clength :: forall a. Context a -> Int
length :: forall a. Context a -> Int
$celem :: forall a. Eq a => a -> Context a -> Bool
elem :: forall a. Eq a => a -> Context a -> Bool
$cmaximum :: forall a. Ord a => Context a -> a
maximum :: forall a. Ord a => Context a -> a
$cminimum :: forall a. Ord a => Context a -> a
minimum :: forall a. Ord a => Context a -> a
$csum :: forall a. Num a => Context a -> a
sum :: forall a. Num a => Context a -> a
$cproduct :: forall a. Num a => Context a -> a
product :: forall a. Num a => Context a -> a
Foldable)

addVarInCurrentScope :: var -> VarInfo var -> Context var -> Context var
addVarInCurrentScope :: forall var. var -> VarInfo var -> Context var -> Context var
addVarInCurrentScope var
var VarInfo var
info Context{Bool
[[ModalTope var]]
[VarIdent]
[ModalTope var]
[ScopeInfo var]
[Action var]
Maybe Bool
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: forall var. Context var -> Maybe LocationInfo
hintLemmas :: forall var. Context var -> [VarIdent]
deferHoleMismatches :: forall var. Context var -> Bool
holesAreErrors :: forall var. Context var -> Bool
renderHideTerm :: forall var. Context var -> Bool
renderBackend :: forall var. Context var -> Maybe RenderBackend
covariance :: forall var. Context var -> Covariance
verbosity :: forall var. Context var -> Verbosity
currentCommand :: forall var. Context var -> Maybe Command
actionStack :: forall var. Context var -> [Action var]
localTopesEntailBottom :: forall var. Context var -> Maybe Bool
localTopesNFUnion :: forall var. Context var -> [[ModalTope var]]
localTopesNF :: forall var. Context var -> [ModalTope var]
localTopes :: forall var. Context var -> [ModalTope var]
localScopes :: forall var. Context var -> [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopes :: [ModalTope var]
localTopesNF :: [ModalTope var]
localTopesNFUnion :: [[ModalTope var]]
localTopesEntailBottom :: Maybe Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
renderHideTerm :: Bool
holesAreErrors :: Bool
deferHoleMismatches :: Bool
hintLemmas :: [VarIdent]
..} = Context
  { localScopes :: [ScopeInfo var]
localScopes =
      case [ScopeInfo var]
localScopes of
        []             -> [Maybe SectionName -> [(var, VarInfo var)] -> ScopeInfo var
forall var.
Maybe SectionName -> [(var, VarInfo var)] -> ScopeInfo var
ScopeInfo Maybe SectionName
forall a. Maybe a
Nothing [(var
var, VarInfo var
info)]]
        ScopeInfo var
scope : [ScopeInfo var]
scopes -> var -> VarInfo var -> ScopeInfo var -> ScopeInfo var
forall var. var -> VarInfo var -> ScopeInfo var -> ScopeInfo var
addVarToScope var
var VarInfo var
info ScopeInfo var
scope ScopeInfo var -> [ScopeInfo var] -> [ScopeInfo var]
forall a. a -> [a] -> [a]
: [ScopeInfo var]
scopes
  , Bool
[[ModalTope var]]
[VarIdent]
[ModalTope var]
[Action var]
Maybe Bool
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: Maybe LocationInfo
hintLemmas :: [VarIdent]
deferHoleMismatches :: Bool
holesAreErrors :: Bool
renderHideTerm :: Bool
renderBackend :: Maybe RenderBackend
covariance :: Covariance
verbosity :: Verbosity
currentCommand :: Maybe Command
actionStack :: [Action var]
localTopesEntailBottom :: Maybe Bool
localTopesNFUnion :: [[ModalTope var]]
localTopesNF :: [ModalTope var]
localTopes :: [ModalTope var]
localTopes :: [ModalTope var]
localTopesNF :: [ModalTope var]
localTopesNFUnion :: [[ModalTope var]]
localTopesEntailBottom :: Maybe Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
renderHideTerm :: Bool
holesAreErrors :: Bool
deferHoleMismatches :: Bool
hintLemmas :: [VarIdent]
.. }

applyModalityToScopes :: TModality -> [ScopeInfo var] -> [ScopeInfo var]
applyModalityToScopes :: forall var. TModality -> [ScopeInfo var] -> [ScopeInfo var]
applyModalityToScopes TModality
md [ScopeInfo var]
scopes = (ScopeInfo var -> ScopeInfo var)
-> [ScopeInfo var] -> [ScopeInfo var]
forall a b. (a -> b) -> [a] -> [b]
map (TModality -> ScopeInfo var -> ScopeInfo var
forall var. TModality -> ScopeInfo var -> ScopeInfo var
addModalityToScope TModality
md) [ScopeInfo var]
scopes

applyModalityToTopes :: TModality -> [ModalTope var] -> [ModalTope var]
applyModalityToTopes :: forall var. TModality -> [ModalTope var] -> [ModalTope var]
applyModalityToTopes TModality
md [ModalTope var]
topes = (ModalTope var -> ModalTope var)
-> [ModalTope var] -> [ModalTope var]
forall a b. (a -> b) -> [a] -> [b]
map (\ModalTope{TermT var
TModality
tModAccum :: forall var. ModalTope var -> TModality
tModVar :: forall var. ModalTope var -> TModality
tTope :: forall var. ModalTope var -> TermT var
tModAccum :: TModality
tModVar :: TModality
tTope :: TermT var
..} -> ModalTope{tModAccum :: TModality
tModAccum = TModality -> TModality -> TModality
forall m. ModeTheory m => m -> m -> m
comp TModality
tModAccum TModality
md, TermT var
TModality
tModVar :: TModality
tTope :: TermT var
tModVar :: TModality
tTope :: TermT var
..}) [ModalTope var]
topes

applyModality :: TModality -> Context var -> Context var
applyModality :: forall var. TModality -> Context var -> Context var
applyModality TModality
md Context{Bool
[[ModalTope var]]
[VarIdent]
[ModalTope var]
[ScopeInfo var]
[Action var]
Maybe Bool
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: forall var. Context var -> Maybe LocationInfo
hintLemmas :: forall var. Context var -> [VarIdent]
deferHoleMismatches :: forall var. Context var -> Bool
holesAreErrors :: forall var. Context var -> Bool
renderHideTerm :: forall var. Context var -> Bool
renderBackend :: forall var. Context var -> Maybe RenderBackend
covariance :: forall var. Context var -> Covariance
verbosity :: forall var. Context var -> Verbosity
currentCommand :: forall var. Context var -> Maybe Command
actionStack :: forall var. Context var -> [Action var]
localTopesEntailBottom :: forall var. Context var -> Maybe Bool
localTopesNFUnion :: forall var. Context var -> [[ModalTope var]]
localTopesNF :: forall var. Context var -> [ModalTope var]
localTopes :: forall var. Context var -> [ModalTope var]
localScopes :: forall var. Context var -> [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopes :: [ModalTope var]
localTopesNF :: [ModalTope var]
localTopesNFUnion :: [[ModalTope var]]
localTopesEntailBottom :: Maybe Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
renderHideTerm :: Bool
holesAreErrors :: Bool
deferHoleMismatches :: Bool
hintLemmas :: [VarIdent]
..} = Context
  { localScopes :: [ScopeInfo var]
localScopes = TModality -> [ScopeInfo var] -> [ScopeInfo var]
forall var. TModality -> [ScopeInfo var] -> [ScopeInfo var]
applyModalityToScopes TModality
md [ScopeInfo var]
localScopes
  , localTopes :: [ModalTope var]
localTopes = TModality -> [ModalTope var] -> [ModalTope var]
forall var. TModality -> [ModalTope var] -> [ModalTope var]
applyModalityToTopes TModality
md [ModalTope var]
localTopes
  , localTopesNF :: [ModalTope var]
localTopesNF = TModality -> [ModalTope var] -> [ModalTope var]
forall var. TModality -> [ModalTope var] -> [ModalTope var]
applyModalityToTopes TModality
md [ModalTope var]
localTopesNF
  , localTopesNFUnion :: [[ModalTope var]]
localTopesNFUnion = ([ModalTope var] -> [ModalTope var])
-> [[ModalTope var]] -> [[ModalTope var]]
forall a b. (a -> b) -> [a] -> [b]
map (TModality -> [ModalTope var] -> [ModalTope var]
forall var. TModality -> [ModalTope var] -> [ModalTope var]
applyModalityToTopes TModality
md) [[ModalTope var]]
localTopesNFUnion
  , Bool
[VarIdent]
[Action var]
Maybe Bool
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: Maybe LocationInfo
hintLemmas :: [VarIdent]
deferHoleMismatches :: Bool
holesAreErrors :: Bool
renderHideTerm :: Bool
renderBackend :: Maybe RenderBackend
covariance :: Covariance
verbosity :: Verbosity
currentCommand :: Maybe Command
actionStack :: [Action var]
localTopesEntailBottom :: Maybe Bool
localTopesEntailBottom :: Maybe Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
renderHideTerm :: Bool
holesAreErrors :: Bool
deferHoleMismatches :: Bool
hintLemmas :: [VarIdent]
.. }

emptyTopeContext :: [ModalTope var]
emptyTopeContext :: forall var. [ModalTope var]
emptyTopeContext =
  [ TModality -> TModality -> TermT var -> ModalTope var
forall var. TModality -> TModality -> TermT var -> ModalTope var
ModalTope TModality
Id TModality
Id    TermT var
forall var. TermT var
topeTopT
  , TModality -> TModality -> TermT var -> ModalTope var
forall var. TModality -> TModality -> TermT var -> ModalTope var
ModalTope TModality
Id TModality
Flat  TermT var
forall var. TermT var
topeTopT
  , TModality -> TModality -> TermT var -> ModalTope var
forall var. TModality -> TModality -> TermT var -> ModalTope var
ModalTope TModality
Id TModality
Op    TermT var
forall var. TermT var
topeTopT
  , TModality -> TModality -> TermT var -> ModalTope var
forall var. TModality -> TModality -> TermT var -> ModalTope var
ModalTope TModality
Id TModality
Sharp TermT var
forall var. TermT var
topeTopT
  ]

emptyContext :: Context var
emptyContext :: forall var. Context var
emptyContext = Context
  { localScopes :: [ScopeInfo var]
localScopes = [Maybe SectionName -> [(var, VarInfo var)] -> ScopeInfo var
forall var.
Maybe SectionName -> [(var, VarInfo var)] -> ScopeInfo var
ScopeInfo Maybe SectionName
forall a. Maybe a
Nothing []]
  , localTopes :: [ModalTope var]
localTopes = [ModalTope var]
forall var. [ModalTope var]
emptyTopeContext
  , localTopesNF :: [ModalTope var]
localTopesNF = [ModalTope var]
forall var. [ModalTope var]
emptyTopeContext
  , localTopesNFUnion :: [[ModalTope var]]
localTopesNFUnion = [[ModalTope var]
forall var. [ModalTope var]
emptyTopeContext]
  , localTopesEntailBottom :: Maybe Bool
localTopesEntailBottom = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
  , actionStack :: [Action var]
actionStack = []
  , currentCommand :: Maybe Command
currentCommand = Maybe Command
forall a. Maybe a
Nothing
  , location :: Maybe LocationInfo
location = Maybe LocationInfo
forall a. Maybe a
Nothing
  , verbosity :: Verbosity
verbosity = Verbosity
Normal
  , covariance :: Covariance
covariance = Covariance
Covariant
  , renderBackend :: Maybe RenderBackend
renderBackend = Maybe RenderBackend
forall a. Maybe a
Nothing
  , renderHideTerm :: Bool
renderHideTerm = Bool
False
  , holesAreErrors :: Bool
holesAreErrors = Bool
True
  , deferHoleMismatches :: Bool
deferHoleMismatches = Bool
True
  , hintLemmas :: [VarIdent]
hintLemmas = []
  }

-- | Switch to lenient hole mode: record each hole's goal and context instead
-- of reporting it as an error. Used by the structured goal/context query and
-- the @--allow-holes@ CLI mode; the default (strict) mode rejects holes.
allowHoles :: Context var -> Context var
allowHoles :: forall var. Context var -> Context var
allowHoles Context var
ctx = Context var
ctx { holesAreErrors = False }

-- | Allow a hole's candidate list to draw on the given named top-level
-- definitions (in addition to the local hypotheses). The game supplies the
-- per-level allow-list; 'recordHoleShape' then offers each listed lemma whose
-- type fits the goal, applied to holes. See 'hintLemmas'.
withHintLemmas :: [VarIdent] -> Context var -> Context var
withHintLemmas :: forall var. [VarIdent] -> Context var -> Context var
withHintLemmas [VarIdent]
lemmas Context var
ctx = Context var
ctx { hintLemmas = lemmas }

-- | Within the given action, a hole unifies only as a leaf in an otherwise
-- matching structure: a structural mismatch around a hole stays an error rather
-- than being deferred (see 'deferHoleMismatches'). Used to ask whether a term
-- /could/ have a given type, as opposed to tolerating an in-progress sketch.
structuralHoleUnify :: Context var -> Context var
structuralHoleUnify :: forall var. Context var -> Context var
structuralHoleUnify Context var
ctx = Context var
ctx { deferHoleMismatches = False }

askCurrentScope :: TypeCheck var (ScopeInfo var)
askCurrentScope :: forall var. TypeCheck var (ScopeInfo var)
askCurrentScope = (Context var -> [ScopeInfo var])
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [ScopeInfo var]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context var -> [ScopeInfo var]
forall var. Context var -> [ScopeInfo var]
localScopes ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  [ScopeInfo var]
-> ([ScopeInfo var]
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         (ScopeInfo var))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (ScopeInfo var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  []              -> String
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (ScopeInfo var)
forall a. String -> a
panicImpossible String
"no current scope available"
  ScopeInfo var
scope : [ScopeInfo var]
_scopes -> ScopeInfo var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (ScopeInfo var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ScopeInfo var
scope

isAccessible :: ModalTope var -> Bool
isAccessible :: forall a. ModalTope a -> Bool
isAccessible ModalTope var
mt = TModality -> TModality -> Bool
forall m. ModeTheory m => m -> m -> Bool
coe (ModalTope var -> TModality
forall var. ModalTope var -> TModality
tModVar ModalTope var
mt) (ModalTope var -> TModality
forall var. ModalTope var -> TModality
tModAccum ModalTope var
mt)

filterAccessible :: [ModalTope var] -> [ModalTope var]
filterAccessible :: forall var. [ModalTope var] -> [ModalTope var]
filterAccessible = (ModalTope var -> Bool) -> [ModalTope var] -> [ModalTope var]
forall a. (a -> Bool) -> [a] -> [a]
filter ModalTope var -> Bool
forall a. ModalTope a -> Bool
isAccessible

filterInaccessible :: [ModalTope var] -> [ModalTope var]
filterInaccessible :: forall var. [ModalTope var] -> [ModalTope var]
filterInaccessible = (ModalTope var -> Bool) -> [ModalTope var] -> [ModalTope var]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (ModalTope var -> Bool) -> ModalTope var -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModalTope var -> Bool
forall a. ModalTope a -> Bool
isAccessible)

partitionAccessible :: [ModalTope var] -> ([ModalTope var], [ModalTope var])
partitionAccessible :: forall var. [ModalTope var] -> ([ModalTope var], [ModalTope var])
partitionAccessible = (ModalTope var -> Bool)
-> [ModalTope var] -> ([ModalTope var], [ModalTope var])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ModalTope var -> Bool
forall a. ModalTope a -> Bool
isAccessible

accessibleTopes :: [ModalTope var] -> [TermT var]
accessibleTopes :: forall var. [ModalTope var] -> [TermT var]
accessibleTopes = (ModalTope var -> TermT var) -> [ModalTope var] -> [TermT var]
forall a b. (a -> b) -> [a] -> [b]
map ModalTope var -> TermT var
forall var. ModalTope var -> TermT var
tTope ([ModalTope var] -> [TermT var])
-> ([ModalTope var] -> [ModalTope var])
-> [ModalTope var]
-> [TermT var]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ModalTope var] -> [ModalTope var]
forall var. [ModalTope var] -> [ModalTope var]
filterAccessible

plainTope :: TermT var -> ModalTope var
plainTope :: forall var. TermT var -> ModalTope var
plainTope = TModality -> TModality -> TermT var -> ModalTope var
forall var. TModality -> TModality -> TermT var -> ModalTope var
ModalTope TModality
Id TModality
Id

availableTopes :: Context var -> [TermT var]
availableTopes :: forall var. Context var -> [TermT var]
availableTopes Context var
ctx = (ModalTope var -> TermT var) -> [ModalTope var] -> [TermT var]
forall a b. (a -> b) -> [a] -> [b]
map ModalTope var -> TermT var
forall var. ModalTope var -> TermT var
tTope ([ModalTope var] -> [TermT var]) -> [ModalTope var] -> [TermT var]
forall a b. (a -> b) -> a -> b
$ [ModalTope var] -> [ModalTope var]
forall var. [ModalTope var] -> [ModalTope var]
filterAccessible (Context var -> [ModalTope var]
forall var. Context var -> [ModalTope var]
localTopes Context var
ctx)

availableTopesNF :: Context var -> [TermT var]
availableTopesNF :: forall var. Context var -> [TermT var]
availableTopesNF Context var
ctx = (ModalTope var -> TermT var) -> [ModalTope var] -> [TermT var]
forall a b. (a -> b) -> [a] -> [b]
map ModalTope var -> TermT var
forall var. ModalTope var -> TermT var
tTope ([ModalTope var] -> [TermT var]) -> [ModalTope var] -> [TermT var]
forall a b. (a -> b) -> a -> b
$ [ModalTope var] -> [ModalTope var]
forall var. [ModalTope var] -> [ModalTope var]
filterAccessible (Context var -> [ModalTope var]
forall var. Context var -> [ModalTope var]
localTopesNF Context var
ctx)

varInfos :: Context var -> [(var, VarInfo var)]
varInfos :: forall var. Context var -> [(var, VarInfo var)]
varInfos Context{Bool
[[ModalTope var]]
[VarIdent]
[ModalTope var]
[ScopeInfo var]
[Action var]
Maybe Bool
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: forall var. Context var -> Maybe LocationInfo
hintLemmas :: forall var. Context var -> [VarIdent]
deferHoleMismatches :: forall var. Context var -> Bool
holesAreErrors :: forall var. Context var -> Bool
renderHideTerm :: forall var. Context var -> Bool
renderBackend :: forall var. Context var -> Maybe RenderBackend
covariance :: forall var. Context var -> Covariance
verbosity :: forall var. Context var -> Verbosity
currentCommand :: forall var. Context var -> Maybe Command
actionStack :: forall var. Context var -> [Action var]
localTopesEntailBottom :: forall var. Context var -> Maybe Bool
localTopesNFUnion :: forall var. Context var -> [[ModalTope var]]
localTopesNF :: forall var. Context var -> [ModalTope var]
localTopes :: forall var. Context var -> [ModalTope var]
localScopes :: forall var. Context var -> [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopes :: [ModalTope var]
localTopesNF :: [ModalTope var]
localTopesNFUnion :: [[ModalTope var]]
localTopesEntailBottom :: Maybe Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
renderHideTerm :: Bool
holesAreErrors :: Bool
deferHoleMismatches :: Bool
hintLemmas :: [VarIdent]
..} = (ScopeInfo var -> [(var, VarInfo var)])
-> [ScopeInfo var] -> [(var, VarInfo var)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ScopeInfo var -> [(var, VarInfo var)]
forall var. ScopeInfo var -> [(var, VarInfo var)]
scopeVars [ScopeInfo var]
localScopes

varTypes :: Context var -> [(var, TermT var)]
varTypes :: forall var. Context var -> [(var, TermT var)]
varTypes = ((var, VarInfo var) -> (var, TermT var))
-> [(var, VarInfo var)] -> [(var, TermT var)]
forall a b. (a -> b) -> [a] -> [b]
map ((VarInfo var -> TermT var)
-> (var, VarInfo var) -> (var, TermT var)
forall a b. (a -> b) -> (var, a) -> (var, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap VarInfo var -> TermT var
forall var. VarInfo var -> TermT var
varType) ([(var, VarInfo var)] -> [(var, TermT var)])
-> (Context var -> [(var, VarInfo var)])
-> Context var
-> [(var, TermT var)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context var -> [(var, VarInfo var)]
forall var. Context var -> [(var, VarInfo var)]
varInfos

varValues :: Context var -> [(var, Maybe (TermT var))]
varValues :: forall var. Context var -> [(var, Maybe (TermT var))]
varValues = ((var, VarInfo var) -> (var, Maybe (TermT var)))
-> [(var, VarInfo var)] -> [(var, Maybe (TermT var))]
forall a b. (a -> b) -> [a] -> [b]
map ((VarInfo var -> Maybe (TermT var))
-> (var, VarInfo var) -> (var, Maybe (TermT var))
forall a b. (a -> b) -> (var, a) -> (var, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap VarInfo var -> Maybe (TermT var)
forall var. VarInfo var -> Maybe (TermT var)
varValue) ([(var, VarInfo var)] -> [(var, Maybe (TermT var))])
-> (Context var -> [(var, VarInfo var)])
-> Context var
-> [(var, Maybe (TermT var))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context var -> [(var, VarInfo var)]
forall var. Context var -> [(var, VarInfo var)]
varInfos

varOrigs :: Context var -> [(var, Maybe VarIdent)]
varOrigs :: forall var. Context var -> [(var, Maybe VarIdent)]
varOrigs = ((var, VarInfo var) -> (var, Maybe VarIdent))
-> [(var, VarInfo var)] -> [(var, Maybe VarIdent)]
forall a b. (a -> b) -> [a] -> [b]
map ((VarInfo var -> Maybe VarIdent)
-> (var, VarInfo var) -> (var, Maybe VarIdent)
forall a b. (a -> b) -> (var, a) -> (var, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Binder -> Maybe VarIdent
binderName (Binder -> Maybe VarIdent)
-> (VarInfo var -> Binder) -> VarInfo var -> Maybe VarIdent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarInfo var -> Binder
forall var. VarInfo var -> Binder
varOrig)) ([(var, VarInfo var)] -> [(var, Maybe VarIdent)])
-> (Context var -> [(var, VarInfo var)])
-> Context var
-> [(var, Maybe VarIdent)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context var -> [(var, VarInfo var)]
forall var. Context var -> [(var, VarInfo var)]
varInfos

-- | The full binder (pattern) of each in-scope variable, used to restore
-- pattern-binder component names (e.g. @t@\/@s@ for @\\ (t , s) -> …@) when
-- rendering goals, holes and contexts.
varBinders :: Context var -> [(var, Binder)]
varBinders :: forall var. Context var -> [(var, Binder)]
varBinders = ((var, VarInfo var) -> (var, Binder))
-> [(var, VarInfo var)] -> [(var, Binder)]
forall a b. (a -> b) -> [a] -> [b]
map ((VarInfo var -> Binder) -> (var, VarInfo var) -> (var, Binder)
forall a b. (a -> b) -> (var, a) -> (var, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap VarInfo var -> Binder
forall var. VarInfo var -> Binder
varOrig) ([(var, VarInfo var)] -> [(var, Binder)])
-> (Context var -> [(var, VarInfo var)])
-> Context var
-> [(var, Binder)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context var -> [(var, VarInfo var)]
forall var. Context var -> [(var, VarInfo var)]
varInfos

varModalities :: Context var -> [(var, TModality)]
varModalities :: forall var. Context var -> [(var, TModality)]
varModalities = ((var, VarInfo var) -> (var, TModality))
-> [(var, VarInfo var)] -> [(var, TModality)]
forall a b. (a -> b) -> [a] -> [b]
map ((VarInfo var -> TModality)
-> (var, VarInfo var) -> (var, TModality)
forall a b. (a -> b) -> (var, a) -> (var, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap VarInfo var -> TModality
forall var. VarInfo var -> TModality
varModality) ([(var, VarInfo var)] -> [(var, TModality)])
-> (Context var -> [(var, VarInfo var)])
-> Context var
-> [(var, TModality)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context var -> [(var, VarInfo var)]
forall var. Context var -> [(var, VarInfo var)]
varInfos

varLocks :: Context var -> [(var, TModality)]
varLocks :: forall var. Context var -> [(var, TModality)]
varLocks = ((var, VarInfo var) -> (var, TModality))
-> [(var, VarInfo var)] -> [(var, TModality)]
forall a b. (a -> b) -> [a] -> [b]
map ((VarInfo var -> TModality)
-> (var, VarInfo var) -> (var, TModality)
forall a b. (a -> b) -> (var, a) -> (var, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap VarInfo var -> TModality
forall var. VarInfo var -> TModality
modAccum) ([(var, VarInfo var)] -> [(var, TModality)])
-> (Context var -> [(var, VarInfo var)])
-> Context var
-> [(var, TModality)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context var -> [(var, VarInfo var)]
forall var. Context var -> [(var, VarInfo var)]
varInfos

varTopLevels :: Context var -> [(var, Bool)]
varTopLevels :: forall var. Context var -> [(var, Bool)]
varTopLevels = ((var, VarInfo var) -> (var, Bool))
-> [(var, VarInfo var)] -> [(var, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map ((VarInfo var -> Bool) -> (var, VarInfo var) -> (var, Bool)
forall a b. (a -> b) -> (var, a) -> (var, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap VarInfo var -> Bool
forall var. VarInfo var -> Bool
varIsTopLevel) ([(var, VarInfo var)] -> [(var, Bool)])
-> (Context var -> [(var, VarInfo var)])
-> Context var
-> [(var, Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context var -> [(var, VarInfo var)]
forall var. Context var -> [(var, VarInfo var)]
varInfos

withPartialDecls
  :: TypeCheck VarIdent ([Decl'], [err])
  -> TypeCheck VarIdent ([Decl'], [err])
  -> TypeCheck VarIdent ([Decl'], [err])
withPartialDecls :: forall err.
TypeCheck VarIdent ([Decl'], [err])
-> TypeCheck VarIdent ([Decl'], [err])
-> TypeCheck VarIdent ([Decl'], [err])
withPartialDecls TypeCheck VarIdent ([Decl'], [err])
tc TypeCheck VarIdent ([Decl'], [err])
next = do
  (decls, errs) <- TypeCheck VarIdent ([Decl'], [err])
tc
  if null errs
    then first (decls <>)
      <$> localDeclsPrepared decls next
    else return (decls, errs)

withSection
  :: Maybe Rzk.SectionName
  -> TypeCheck VarIdent ([Decl VarIdent], [TypeErrorInScopedContext VarIdent])
  -> TypeCheck VarIdent ([Decl VarIdent], [TypeErrorInScopedContext VarIdent])
  -> TypeCheck VarIdent ([Decl VarIdent], [TypeErrorInScopedContext VarIdent])
withSection :: Maybe SectionName
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
withSection Maybe SectionName
name TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
sectionBody =
  TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall err.
TypeCheck VarIdent ([Decl'], [err])
-> TypeCheck VarIdent ([Decl'], [err])
-> TypeCheck VarIdent ([Decl'], [err])
withPartialDecls (TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
 -> TypeCheck
      VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
 -> TypeCheck
      VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a b. (a -> b) -> a -> b
$ Maybe SectionName
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a.
Maybe SectionName -> TypeCheck VarIdent a -> TypeCheck VarIdent a
startSection Maybe SectionName
name (TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
 -> TypeCheck
      VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a b. (a -> b) -> a -> b
$ do
    (decls, errs) <- TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
sectionBody
    localDeclsPrepared decls $
      performing (ActionCloseSection name) $ do
        result <- (Right <$> endSection errs) `catchError` (return . Left)
        case result of
          Left TypeErrorInScopedContext VarIdent
err              -> ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a.
a
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [TypeErrorInScopedContext VarIdent]
errs [TypeErrorInScopedContext VarIdent]
-> [TypeErrorInScopedContext VarIdent]
-> [TypeErrorInScopedContext VarIdent]
forall a. Semigroup a => a -> a -> a
<> [TypeErrorInScopedContext VarIdent
err])
          Right ([Decl']
decls', [TypeErrorInScopedContext VarIdent]
errs') -> ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a.
a
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Decl']
decls', [TypeErrorInScopedContext VarIdent]
errs')
        -- (\ decls' -> (decls', errs)) <$> endSection errs

startSection :: Maybe Rzk.SectionName -> TypeCheck VarIdent a -> TypeCheck VarIdent a
startSection :: forall a.
Maybe SectionName -> TypeCheck VarIdent a -> TypeCheck VarIdent a
startSection Maybe SectionName
name = (Context VarIdent -> Context VarIdent)
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     a
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     a
forall a.
(Context VarIdent -> Context VarIdent)
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     a
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((Context VarIdent -> Context VarIdent)
 -> ReaderT
      (Context VarIdent)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
      a
 -> ReaderT
      (Context VarIdent)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
      a)
-> (Context VarIdent -> Context VarIdent)
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     a
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     a
forall a b. (a -> b) -> a -> b
$ \Context{Bool
[[ModalTope VarIdent]]
[VarIdent]
[ModalTope VarIdent]
[ScopeInfo VarIdent]
[Action VarIdent]
Maybe Bool
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: forall var. Context var -> Maybe LocationInfo
hintLemmas :: forall var. Context var -> [VarIdent]
deferHoleMismatches :: forall var. Context var -> Bool
holesAreErrors :: forall var. Context var -> Bool
renderHideTerm :: forall var. Context var -> Bool
renderBackend :: forall var. Context var -> Maybe RenderBackend
covariance :: forall var. Context var -> Covariance
verbosity :: forall var. Context var -> Verbosity
currentCommand :: forall var. Context var -> Maybe Command
actionStack :: forall var. Context var -> [Action var]
localTopesEntailBottom :: forall var. Context var -> Maybe Bool
localTopesNFUnion :: forall var. Context var -> [[ModalTope var]]
localTopesNF :: forall var. Context var -> [ModalTope var]
localTopes :: forall var. Context var -> [ModalTope var]
localScopes :: forall var. Context var -> [ScopeInfo var]
localScopes :: [ScopeInfo VarIdent]
localTopes :: [ModalTope VarIdent]
localTopesNF :: [ModalTope VarIdent]
localTopesNFUnion :: [[ModalTope VarIdent]]
localTopesEntailBottom :: Maybe Bool
actionStack :: [Action VarIdent]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
renderHideTerm :: Bool
holesAreErrors :: Bool
deferHoleMismatches :: Bool
hintLemmas :: [VarIdent]
..} -> Context
  { localScopes :: [ScopeInfo VarIdent]
localScopes = ScopeInfo { scopeName :: Maybe SectionName
scopeName = Maybe SectionName
name, scopeVars :: [(VarIdent, VarInfo VarIdent)]
scopeVars = [] } ScopeInfo VarIdent -> [ScopeInfo VarIdent] -> [ScopeInfo VarIdent]
forall a. a -> [a] -> [a]
: [ScopeInfo VarIdent]
localScopes
  , Bool
[[ModalTope VarIdent]]
[VarIdent]
[ModalTope VarIdent]
[Action VarIdent]
Maybe Bool
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: Maybe LocationInfo
hintLemmas :: [VarIdent]
deferHoleMismatches :: Bool
holesAreErrors :: Bool
renderHideTerm :: Bool
renderBackend :: Maybe RenderBackend
covariance :: Covariance
verbosity :: Verbosity
currentCommand :: Maybe Command
actionStack :: [Action VarIdent]
localTopesEntailBottom :: Maybe Bool
localTopesNFUnion :: [[ModalTope VarIdent]]
localTopesNF :: [ModalTope VarIdent]
localTopes :: [ModalTope VarIdent]
localTopes :: [ModalTope VarIdent]
localTopesNF :: [ModalTope VarIdent]
localTopesNFUnion :: [[ModalTope VarIdent]]
localTopesEntailBottom :: Maybe Bool
actionStack :: [Action VarIdent]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
renderHideTerm :: Bool
holesAreErrors :: Bool
deferHoleMismatches :: Bool
hintLemmas :: [VarIdent]
.. }

endSection :: [TypeErrorInScopedContext VarIdent] -> TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
endSection :: [TypeErrorInScopedContext VarIdent]
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
endSection [TypeErrorInScopedContext VarIdent]
errs = TypeCheck VarIdent (ScopeInfo VarIdent)
forall var. TypeCheck var (ScopeInfo var)
askCurrentScope TypeCheck VarIdent (ScopeInfo VarIdent)
-> (ScopeInfo VarIdent
    -> TypeCheck
         VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a b.
ReaderT
  (Context VarIdent)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
  a
-> (a
    -> ReaderT
         (Context VarIdent)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
         b)
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [TypeErrorInScopedContext VarIdent]
-> ScopeInfo VarIdent
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall var.
Eq var =>
[TypeErrorInScopedContext var]
-> ScopeInfo var
-> TypeCheck var ([Decl var], [TypeErrorInScopedContext var])
scopeToDecls [TypeErrorInScopedContext VarIdent]
errs

scopeToDecls :: Eq var => [TypeErrorInScopedContext var] -> ScopeInfo var -> TypeCheck var ([Decl var], [TypeErrorInScopedContext var])
scopeToDecls :: forall var.
Eq var =>
[TypeErrorInScopedContext var]
-> ScopeInfo var
-> TypeCheck var ([Decl var], [TypeErrorInScopedContext var])
scopeToDecls [TypeErrorInScopedContext var]
errs ScopeInfo{[(var, VarInfo var)]
Maybe SectionName
scopeName :: forall var. ScopeInfo var -> Maybe SectionName
scopeVars :: forall var. ScopeInfo var -> [(var, VarInfo var)]
scopeName :: Maybe SectionName
scopeVars :: [(var, VarInfo var)]
..} = do
  -- In lenient (hole-checking) mode an as-yet-unfilled hole may still come to
  -- use a declared variable, so we tolerate the unused-variable diagnostics
  -- wherever such a hole is present anywhere in the section. This covers both an
  -- unused section assumption and an unused 'uses' variable, and crucially a
  -- hole-free definition whose body refers to an in-progress (hole-bearing) one:
  -- its 'uses' reads as unused only because the referenced definition is
  -- incomplete. Strict mode (the default, and CI) keeps reporting both.
  lenient <- Bool -> Bool
not (Bool -> Bool)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     Bool
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Context var -> Bool)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context var -> Bool
forall var. Context var -> Bool
holesAreErrors
  let sectionHasHole = ((var, VarInfo var) -> Bool) -> [(var, VarInfo var)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> (TermT var -> Bool) -> Maybe (TermT var) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False TermT var -> Bool
forall var. TermT var -> Bool
containsHole (Maybe (TermT var) -> Bool)
-> ((var, VarInfo var) -> Maybe (TermT var))
-> (var, VarInfo var)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarInfo var -> Maybe (TermT var)
forall var. VarInfo var -> Maybe (TermT var)
varValue (VarInfo var -> Maybe (TermT var))
-> ((var, VarInfo var) -> VarInfo var)
-> (var, VarInfo var)
-> Maybe (TermT var)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (var, VarInfo var) -> VarInfo var
forall a b. (a, b) -> b
snd) [(var, VarInfo var)]
scopeVars
  (decls, errs') <- collectScopeDecls (lenient && sectionHasHole) errs [] scopeVars
  -- only issue unused variable errors if there were no errors prior in the section
  -- when (null errs) $ do
  unusedErrors <- forM decls $ \Decl{var
Bool
[var]
Maybe (TermT var)
Maybe LocationInfo
TermT var
declName :: forall var. Decl var -> var
declType :: forall var. Decl var -> TermT var
declValue :: forall var. Decl var -> Maybe (TermT var)
declIsAssumption :: forall var. Decl var -> Bool
declUsedVars :: forall var. Decl var -> [var]
declLocation :: forall var. Decl var -> Maybe LocationInfo
declName :: var
declType :: TermT var
declValue :: Maybe (TermT var)
declIsAssumption :: Bool
declUsedVars :: [var]
declLocation :: Maybe LocationInfo
..} -> do
    let unusedUsedVars :: [var]
unusedUsedVars = [var]
declUsedVars [var] -> [var] -> [var]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` ((var, VarInfo var) -> var) -> [(var, VarInfo var)] -> [var]
forall a b. (a -> b) -> [a] -> [b]
map (var, VarInfo var) -> var
forall a b. (a, b) -> a
fst [(var, VarInfo var)]
scopeVars
    if [TypeErrorInScopedContext var] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TypeErrorInScopedContext var]
errs Bool -> Bool -> Bool
&& Bool -> Bool
not ([var] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [var]
unusedUsedVars) Bool -> Bool -> Bool
&& Bool -> Bool
not (Bool
lenient Bool -> Bool -> Bool
&& Bool
sectionHasHole)
      then do
        err <- (Context var -> Context var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TypeErrorInScopedContext var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TypeErrorInScopedContext var)
forall a.
(Context var -> Context var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\Context var
c -> Context var
c { location = declLocation }) (ReaderT
   (Context var)
   (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
   (TypeErrorInScopedContext var)
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      (TypeErrorInScopedContext var))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TypeErrorInScopedContext var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TypeErrorInScopedContext var)
forall a b. (a -> b) -> a -> b
$
          TypeError var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TypeErrorInScopedContext var)
forall var.
TypeError var -> TypeCheck var (TypeErrorInScopedContext var)
fromTypeError ([var] -> var -> TypeError var
forall var. [var] -> var -> TypeError var
TypeErrorUnusedUsedVariables [var]
unusedUsedVars var
declName)
        return [err]
      else [TypeErrorInScopedContext var]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [TypeErrorInScopedContext var]
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  return (decls, errs' <> concat unusedErrors)

insertExplicitAssumptionFor
  :: Eq var => var -> (var, VarInfo var) -> TermT var -> TermT var
insertExplicitAssumptionFor :: forall var.
Eq var =>
var -> (var, VarInfo var) -> TermT var -> TermT var
insertExplicitAssumptionFor var
a (var
declName, VarInfo{Bool
[var]
Maybe (TermT var)
Maybe LocationInfo
TermT var
TModality
Binder
varIsTopLevel :: forall var. VarInfo var -> Bool
varType :: forall var. VarInfo var -> TermT var
varOrig :: forall var. VarInfo var -> Binder
varLocation :: forall var. VarInfo var -> Maybe LocationInfo
varDeclaredAssumptions :: forall var. VarInfo var -> [var]
varIsAssumption :: forall var. VarInfo var -> Bool
modAccum :: forall var. VarInfo var -> TModality
varModality :: forall var. VarInfo var -> TModality
varValue :: forall var. VarInfo var -> Maybe (TermT var)
varType :: TermT var
varValue :: Maybe (TermT var)
varModality :: TModality
modAccum :: TModality
varOrig :: Binder
varIsAssumption :: Bool
varIsTopLevel :: Bool
varDeclaredAssumptions :: [var]
varLocation :: Maybe LocationInfo
..}) TermT var
term =
  TermT var
term TermT var -> (var -> TermT var) -> TermT var
forall a b.
FS (AnnF TypeInfo TermF) a
-> (a -> FS (AnnF TypeInfo TermF) b) -> FS (AnnF TypeInfo TermF) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    var
y | var
y var -> var -> Bool
forall a. Eq a => a -> a -> Bool
== var
declName -> TermT var -> TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var -> TermT var
appT TermT var
varType (var -> TermT var
forall (t :: * -> * -> *) a. a -> FS t a
Pure var
declName) (var -> TermT var
forall (t :: * -> * -> *) a. a -> FS t a
Pure var
a)
      | Bool
otherwise     -> var -> TermT var
forall (t :: * -> * -> *) a. a -> FS t a
Pure var
y

insertExplicitAssumptionFor'
  :: Eq var => var -> (var, VarInfo var) -> VarInfo var -> VarInfo var
insertExplicitAssumptionFor' :: forall var.
Eq var =>
var -> (var, VarInfo var) -> VarInfo var -> VarInfo var
insertExplicitAssumptionFor' var
a (var, VarInfo var)
decl VarInfo{Bool
[var]
Maybe (TermT var)
Maybe LocationInfo
TermT var
TModality
Binder
varIsTopLevel :: forall var. VarInfo var -> Bool
varType :: forall var. VarInfo var -> TermT var
varOrig :: forall var. VarInfo var -> Binder
varLocation :: forall var. VarInfo var -> Maybe LocationInfo
varDeclaredAssumptions :: forall var. VarInfo var -> [var]
varIsAssumption :: forall var. VarInfo var -> Bool
modAccum :: forall var. VarInfo var -> TModality
varModality :: forall var. VarInfo var -> TModality
varValue :: forall var. VarInfo var -> Maybe (TermT var)
varType :: TermT var
varValue :: Maybe (TermT var)
varModality :: TModality
modAccum :: TModality
varOrig :: Binder
varIsAssumption :: Bool
varIsTopLevel :: Bool
varDeclaredAssumptions :: [var]
varLocation :: Maybe LocationInfo
..}
  | Bool
varIsAssumption = VarInfo{Bool
[var]
Maybe (TermT var)
Maybe LocationInfo
TermT var
TModality
Binder
varIsTopLevel :: Bool
varType :: TermT var
varOrig :: Binder
varLocation :: Maybe LocationInfo
varDeclaredAssumptions :: [var]
varIsAssumption :: Bool
modAccum :: TModality
varModality :: TModality
varValue :: Maybe (TermT var)
varType :: TermT var
varValue :: Maybe (TermT var)
varModality :: TModality
modAccum :: TModality
varOrig :: Binder
varIsAssumption :: Bool
varIsTopLevel :: Bool
varDeclaredAssumptions :: [var]
varLocation :: Maybe LocationInfo
..}
  | Bool
otherwise = VarInfo
      { varType :: TermT var
varType = var -> (var, VarInfo var) -> TermT var -> TermT var
forall var.
Eq var =>
var -> (var, VarInfo var) -> TermT var -> TermT var
insertExplicitAssumptionFor var
a (var, VarInfo var)
decl TermT var
varType
      , varValue :: Maybe (TermT var)
varValue = var -> (var, VarInfo var) -> TermT var -> TermT var
forall var.
Eq var =>
var -> (var, VarInfo var) -> TermT var -> TermT var
insertExplicitAssumptionFor var
a (var, VarInfo var)
decl (TermT var -> TermT var) -> Maybe (TermT var) -> Maybe (TermT var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (TermT var)
varValue
      , varIsAssumption :: Bool
varIsAssumption = Bool
varIsAssumption
      , varIsTopLevel :: Bool
varIsTopLevel = Bool
varIsTopLevel
      , varModality :: TModality
varModality = TModality
varModality
      , modAccum :: TModality
modAccum = TModality
modAccum
      , varOrig :: Binder
varOrig = Binder
varOrig
      , varDeclaredAssumptions :: [var]
varDeclaredAssumptions = [var]
varDeclaredAssumptions
      , varLocation :: Maybe LocationInfo
varLocation = Maybe LocationInfo
varLocation
      }

makeAssumptionExplicit
  :: Eq var
  => (var, VarInfo var)
  -> [(var, VarInfo var)]
  -> TypeCheck var (Bool, [(var, VarInfo var)])
makeAssumptionExplicit :: forall var.
Eq var =>
(var, VarInfo var)
-> [(var, VarInfo var)]
-> TypeCheck var (Bool, [(var, VarInfo var)])
makeAssumptionExplicit (var, VarInfo var)
_ [] = (Bool, [(var, VarInfo var)])
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Bool, [(var, VarInfo var)])
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False {- UNUSED -}, [])
makeAssumptionExplicit assumption :: (var, VarInfo var)
assumption@(var
a, VarInfo var
aInfo) ((var
x, VarInfo var
xInfo) : [(var, VarInfo var)]
xs) = do
  varsInType <- TermT var -> TypeCheck var [var]
forall var. Eq var => TermT var -> TypeCheck var [var]
freeVarsT_ (VarInfo var -> TermT var
forall var. VarInfo var -> TermT var
varType VarInfo var
xInfo)
  varsInBody <- concat <$> traverse freeVarsT_ (varValue xInfo)
  let xFreeVars = [var]
varsInBody [var] -> [var] -> [var]
forall a. Semigroup a => a -> a -> a
<> [var]
varsInType
  let hasAssumption = var
a var -> [var] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [var]
xFreeVars
  xType <- typeOfVar x
  xValue <- valueOfVar x
  let assumptionInType = var
a var -> [var] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Term var -> [var]
forall a. Term a -> [a]
freeVars (TermT var -> Term var
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT var
xType)
      assumptionInBody = var
a var -> [var] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (TermT var -> [var]) -> Maybe (TermT var) -> [var]
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Term var -> [var]
forall a. Term a -> [a]
freeVars (Term var -> [var])
-> (TermT var -> Term var) -> TermT var -> [var]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermT var -> Term var
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped) Maybe (TermT var)
xValue
      implicitAssumption = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and
        [ Bool
hasAssumption
        , Bool -> Bool
not (Bool
assumptionInType Bool -> Bool -> Bool
|| Bool
assumptionInBody)
        , var
a var -> [var] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` VarInfo var -> [var]
forall var. VarInfo var -> [var]
varDeclaredAssumptions VarInfo var
xInfo ]
  if hasAssumption
     then do
       when implicitAssumption $ do
         issueTypeError $ TypeErrorImplicitAssumption (a, varType aInfo) x
       (_used, xs'') <- makeAssumptionExplicit (a, aInfo) xs'
       return (True {- USED -}, (x, xInfo') : xs'')
     else do
       (used, xs'') <- makeAssumptionExplicit assumption xs
       return (used, (x, xInfo) : xs'')
  where
    xType' :: TermT var
xType' = Binder
-> TModality
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall var.
Binder
-> TModality
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeFunT (VarInfo var -> Binder
forall var. VarInfo var -> Binder
varOrig VarInfo var
aInfo) TModality
Id (VarInfo var -> TermT var
forall var. VarInfo var -> TermT var
varType VarInfo var
aInfo) Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
forall a. Maybe a
Nothing (var -> TermT var -> Scope (FS (AnnF TypeInfo TermF)) var
forall a (f :: * -> *). (Eq a, Functor f) => a -> f a -> f (Inc a)
abstract var
a (VarInfo var -> TermT var
forall var. VarInfo var -> TermT var
varType VarInfo var
xInfo))
    xInfo' :: VarInfo var
xInfo' = VarInfo
      { varType :: TermT var
varType = TermT var
xType'
      , varValue :: Maybe (TermT var)
varValue = (TermT var -> TermT var) -> Maybe (TermT var) -> Maybe (TermT var)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TermT var
-> Binder
-> Maybe
     (TModality, TermT var,
      Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall var.
TermT var
-> Binder
-> Maybe
     (TModality, TermT var,
      Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
lambdaT TermT var
xType' (VarInfo var -> Binder
forall var. VarInfo var -> Binder
varOrig VarInfo var
aInfo) Maybe
  (TModality, TermT var,
   Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
forall a. Maybe a
Nothing (Scope (FS (AnnF TypeInfo TermF)) var -> TermT var)
-> (TermT var -> Scope (FS (AnnF TypeInfo TermF)) var)
-> TermT var
-> TermT var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. var -> TermT var -> Scope (FS (AnnF TypeInfo TermF)) var
forall a (f :: * -> *). (Eq a, Functor f) => a -> f a -> f (Inc a)
abstract var
a) (VarInfo var -> Maybe (TermT var)
forall var. VarInfo var -> Maybe (TermT var)
varValue VarInfo var
xInfo)
      , varIsAssumption :: Bool
varIsAssumption = VarInfo var -> Bool
forall var. VarInfo var -> Bool
varIsAssumption VarInfo var
xInfo
      , varIsTopLevel :: Bool
varIsTopLevel = VarInfo var -> Bool
forall var. VarInfo var -> Bool
varIsTopLevel VarInfo var
xInfo
      , varModality :: TModality
varModality = TModality
Id
      , modAccum :: TModality
modAccum = TModality
Id
      , varOrig :: Binder
varOrig = VarInfo var -> Binder
forall var. VarInfo var -> Binder
varOrig VarInfo var
xInfo
      , varDeclaredAssumptions :: [var]
varDeclaredAssumptions = VarInfo var -> [var]
forall var. VarInfo var -> [var]
varDeclaredAssumptions VarInfo var
xInfo [var] -> [var] -> [var]
forall a. Eq a => [a] -> [a] -> [a]
\\ [var
a]
      , varLocation :: Maybe LocationInfo
varLocation = VarInfo var -> Maybe LocationInfo
forall var. VarInfo var -> Maybe LocationInfo
varLocation VarInfo var
xInfo
      }
    xs' :: [(var, VarInfo var)]
xs' = ((var, VarInfo var) -> (var, VarInfo var))
-> [(var, VarInfo var)] -> [(var, VarInfo var)]
forall a b. (a -> b) -> [a] -> [b]
map ((VarInfo var -> VarInfo var)
-> (var, VarInfo var) -> (var, VarInfo var)
forall a b. (a -> b) -> (var, a) -> (var, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (var -> (var, VarInfo var) -> VarInfo var -> VarInfo var
forall var.
Eq var =>
var -> (var, VarInfo var) -> VarInfo var -> VarInfo var
insertExplicitAssumptionFor' var
a (var
x, VarInfo var
xInfo))) [(var, VarInfo var)]
xs

collectScopeDecls :: Eq var => Bool -> [TypeErrorInScopedContext var] -> [(var, VarInfo var)] -> [(var, VarInfo var)] -> TypeCheck var ([Decl var], [TypeErrorInScopedContext var])
collectScopeDecls :: forall var.
Eq var =>
Bool
-> [TypeErrorInScopedContext var]
-> [(var, VarInfo var)]
-> [(var, VarInfo var)]
-> TypeCheck var ([Decl var], [TypeErrorInScopedContext var])
collectScopeDecls Bool
tolerateUnused [TypeErrorInScopedContext var]
errs [(var, VarInfo var)]
recentVars (decl :: (var, VarInfo var)
decl@(var
var, VarInfo{Bool
[var]
Maybe (TermT var)
Maybe LocationInfo
TermT var
TModality
Binder
varIsTopLevel :: forall var. VarInfo var -> Bool
varType :: forall var. VarInfo var -> TermT var
varOrig :: forall var. VarInfo var -> Binder
varLocation :: forall var. VarInfo var -> Maybe LocationInfo
varDeclaredAssumptions :: forall var. VarInfo var -> [var]
varIsAssumption :: forall var. VarInfo var -> Bool
modAccum :: forall var. VarInfo var -> TModality
varModality :: forall var. VarInfo var -> TModality
varValue :: forall var. VarInfo var -> Maybe (TermT var)
varType :: TermT var
varValue :: Maybe (TermT var)
varModality :: TModality
modAccum :: TModality
varOrig :: Binder
varIsAssumption :: Bool
varIsTopLevel :: Bool
varDeclaredAssumptions :: [var]
varLocation :: Maybe LocationInfo
..}) : [(var, VarInfo var)]
vars)
  | Bool
varIsAssumption = do
      (used, recentVars') <- (var, VarInfo var)
-> [(var, VarInfo var)]
-> TypeCheck var (Bool, [(var, VarInfo var)])
forall var.
Eq var =>
(var, VarInfo var)
-> [(var, VarInfo var)]
-> TypeCheck var (Bool, [(var, VarInfo var)])
makeAssumptionExplicit (var, VarInfo var)
decl [(var, VarInfo var)]
recentVars
      -- only issue unused vars error if there were no other errors previously
      -- when (null errs) $ do
      unusedErr <-
        if null errs && not used && not tolerateUnused
          then local (\Context var
c -> Context var
c { location = varLocation }) $
            pure <$> fromTypeError (TypeErrorUnusedVariable var varType)
          else return []
      collectScopeDecls tolerateUnused (errs <> unusedErr) recentVars' vars
  | Bool
otherwise = do
      Bool
-> [TypeErrorInScopedContext var]
-> [(var, VarInfo var)]
-> [(var, VarInfo var)]
-> TypeCheck var ([Decl var], [TypeErrorInScopedContext var])
forall var.
Eq var =>
Bool
-> [TypeErrorInScopedContext var]
-> [(var, VarInfo var)]
-> [(var, VarInfo var)]
-> TypeCheck var ([Decl var], [TypeErrorInScopedContext var])
collectScopeDecls Bool
tolerateUnused [TypeErrorInScopedContext var]
errs ((var, VarInfo var)
decl (var, VarInfo var) -> [(var, VarInfo var)] -> [(var, VarInfo var)]
forall a. a -> [a] -> [a]
: [(var, VarInfo var)]
recentVars) [(var, VarInfo var)]
vars
collectScopeDecls Bool
_ [TypeErrorInScopedContext var]
errs [(var, VarInfo var)]
recentVars [] = do
  loc <- (Context var -> Maybe LocationInfo)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe LocationInfo)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context var -> Maybe LocationInfo
forall var. Context var -> Maybe LocationInfo
location
  return (toDecl loc <$> recentVars, errs)
  where
    toDecl :: Maybe LocationInfo -> (var, VarInfo var) -> Decl var
toDecl Maybe LocationInfo
loc (var
var, VarInfo{Bool
[var]
Maybe (TermT var)
Maybe LocationInfo
TermT var
TModality
Binder
varIsTopLevel :: forall var. VarInfo var -> Bool
varType :: forall var. VarInfo var -> TermT var
varOrig :: forall var. VarInfo var -> Binder
varLocation :: forall var. VarInfo var -> Maybe LocationInfo
varDeclaredAssumptions :: forall var. VarInfo var -> [var]
varIsAssumption :: forall var. VarInfo var -> Bool
modAccum :: forall var. VarInfo var -> TModality
varModality :: forall var. VarInfo var -> TModality
varValue :: forall var. VarInfo var -> Maybe (TermT var)
varType :: TermT var
varValue :: Maybe (TermT var)
varModality :: TModality
modAccum :: TModality
varOrig :: Binder
varIsAssumption :: Bool
varIsTopLevel :: Bool
varDeclaredAssumptions :: [var]
varLocation :: Maybe LocationInfo
..}) = Decl
      { declName :: var
declName = var
var
      , declType :: TermT var
declType = TermT var
varType
      , declValue :: Maybe (TermT var)
declValue = Maybe (TermT var)
varValue
      , declIsAssumption :: Bool
declIsAssumption = Bool
varIsAssumption
      , declUsedVars :: [var]
declUsedVars = [var]
varDeclaredAssumptions
      , declLocation :: Maybe LocationInfo
declLocation = Maybe Int -> LocationInfo -> LocationInfo
updatePosition (Binder -> Maybe VarIdent
binderName Binder
varOrig Maybe VarIdent -> (VarIdent -> Maybe Int) -> Maybe Int
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((Int, Int) -> Int) -> BNFC'Position -> Maybe Int
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, Int) -> Int
forall a b. (a, b) -> a
fst (BNFC'Position -> Maybe Int)
-> (VarIdent -> BNFC'Position) -> VarIdent -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarIdent' BNFC'Position -> BNFC'Position
forall a. HasPosition a => a -> BNFC'Position
Rzk.hasPosition (VarIdent' BNFC'Position -> BNFC'Position)
-> (VarIdent -> VarIdent' BNFC'Position)
-> VarIdent
-> BNFC'Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarIdent -> VarIdent' BNFC'Position
fromVarIdent) (LocationInfo -> LocationInfo)
-> Maybe LocationInfo -> Maybe LocationInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe LocationInfo
loc -- FIXME
      }
    updatePosition :: Maybe Int -> LocationInfo -> LocationInfo
updatePosition Maybe Int
Nothing LocationInfo
l       = LocationInfo
l
    updatePosition (Just Int
lineNo) LocationInfo
l = LocationInfo
l { locationLine = Just lineNo }

abstractAssumption :: Eq var => (var, VarInfo var) -> Decl var -> Decl var
abstractAssumption :: forall var. Eq var => (var, VarInfo var) -> Decl var -> Decl var
abstractAssumption (var
var, VarInfo{Bool
[var]
Maybe (TermT var)
Maybe LocationInfo
TermT var
TModality
Binder
varIsTopLevel :: forall var. VarInfo var -> Bool
varType :: forall var. VarInfo var -> TermT var
varOrig :: forall var. VarInfo var -> Binder
varLocation :: forall var. VarInfo var -> Maybe LocationInfo
varDeclaredAssumptions :: forall var. VarInfo var -> [var]
varIsAssumption :: forall var. VarInfo var -> Bool
modAccum :: forall var. VarInfo var -> TModality
varModality :: forall var. VarInfo var -> TModality
varValue :: forall var. VarInfo var -> Maybe (TermT var)
varType :: TermT var
varValue :: Maybe (TermT var)
varModality :: TModality
modAccum :: TModality
varOrig :: Binder
varIsAssumption :: Bool
varIsTopLevel :: Bool
varDeclaredAssumptions :: [var]
varLocation :: Maybe LocationInfo
..}) Decl{var
Bool
[var]
Maybe (TermT var)
Maybe LocationInfo
TermT var
declName :: forall var. Decl var -> var
declType :: forall var. Decl var -> TermT var
declValue :: forall var. Decl var -> Maybe (TermT var)
declIsAssumption :: forall var. Decl var -> Bool
declUsedVars :: forall var. Decl var -> [var]
declLocation :: forall var. Decl var -> Maybe LocationInfo
declName :: var
declType :: TermT var
declValue :: Maybe (TermT var)
declIsAssumption :: Bool
declUsedVars :: [var]
declLocation :: Maybe LocationInfo
..} = Decl
  { declName :: var
declName = var
declName
  , declType :: TermT var
declType = Binder
-> TModality
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall var.
Binder
-> TModality
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeFunT Binder
varOrig TModality
Id TermT var
varType Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
forall a. Maybe a
Nothing (var -> TermT var -> Scope (FS (AnnF TypeInfo TermF)) var
forall a (f :: * -> *). (Eq a, Functor f) => a -> f a -> f (Inc a)
abstract var
var TermT var
declType)
  , declValue :: Maybe (TermT var)
declValue = (\TermT var
body -> TermT var
-> Binder
-> Maybe
     (TModality, TermT var,
      Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall var.
TermT var
-> Binder
-> Maybe
     (TModality, TermT var,
      Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
lambdaT TermT var
newDeclType Binder
varOrig Maybe
  (TModality, TermT var,
   Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
forall a. Maybe a
Nothing (var -> TermT var -> Scope (FS (AnnF TypeInfo TermF)) var
forall a (f :: * -> *). (Eq a, Functor f) => a -> f a -> f (Inc a)
abstract var
var TermT var
body)) (TermT var -> TermT var) -> Maybe (TermT var) -> Maybe (TermT var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (TermT var)
declValue
  , declIsAssumption :: Bool
declIsAssumption = Bool
declIsAssumption
  , declUsedVars :: [var]
declUsedVars = [var]
declUsedVars
  , declLocation :: Maybe LocationInfo
declLocation = Maybe LocationInfo
declLocation
  }
  where
    newDeclType :: TermT var
newDeclType = Binder
-> TModality
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall var.
Binder
-> TModality
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeFunT Binder
varOrig TModality
Id TermT var
varType Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
forall a. Maybe a
Nothing (var -> TermT var -> Scope (FS (AnnF TypeInfo TermF)) var
forall a (f :: * -> *). (Eq a, Functor f) => a -> f a -> f (Inc a)
abstract var
var TermT var
declType)

data OutputDirection = TopDown | BottomUp
  deriving (OutputDirection -> OutputDirection -> Bool
(OutputDirection -> OutputDirection -> Bool)
-> (OutputDirection -> OutputDirection -> Bool)
-> Eq OutputDirection
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OutputDirection -> OutputDirection -> Bool
== :: OutputDirection -> OutputDirection -> Bool
$c/= :: OutputDirection -> OutputDirection -> Bool
/= :: OutputDirection -> OutputDirection -> Bool
Eq)

block :: OutputDirection -> [String] -> String
block :: OutputDirection -> [String] -> String
block OutputDirection
TopDown  = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n"
block OutputDirection
BottomUp = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. [a] -> [a]
reverse

namedBlock :: OutputDirection -> String -> [String] -> String
namedBlock :: OutputDirection -> String -> [String] -> String
namedBlock OutputDirection
dir String
name [String]
lines_ = OutputDirection -> [String] -> String
block OutputDirection
dir ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
  String
name String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
indent [String]
lines_
  where
    indent :: String -> String
indent = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++)) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines

ppContext' :: OutputDirection -> Context VarIdent -> String
ppContext' :: OutputDirection -> Context VarIdent -> String
ppContext' OutputDirection
dir ctx :: Context VarIdent
ctx@Context{Bool
[[ModalTope VarIdent]]
[VarIdent]
[ModalTope VarIdent]
[ScopeInfo VarIdent]
[Action VarIdent]
Maybe Bool
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: forall var. Context var -> Maybe LocationInfo
hintLemmas :: forall var. Context var -> [VarIdent]
deferHoleMismatches :: forall var. Context var -> Bool
holesAreErrors :: forall var. Context var -> Bool
renderHideTerm :: forall var. Context var -> Bool
renderBackend :: forall var. Context var -> Maybe RenderBackend
covariance :: forall var. Context var -> Covariance
verbosity :: forall var. Context var -> Verbosity
currentCommand :: forall var. Context var -> Maybe Command
actionStack :: forall var. Context var -> [Action var]
localTopesEntailBottom :: forall var. Context var -> Maybe Bool
localTopesNFUnion :: forall var. Context var -> [[ModalTope var]]
localTopesNF :: forall var. Context var -> [ModalTope var]
localTopes :: forall var. Context var -> [ModalTope var]
localScopes :: forall var. Context var -> [ScopeInfo var]
localScopes :: [ScopeInfo VarIdent]
localTopes :: [ModalTope VarIdent]
localTopesNF :: [ModalTope VarIdent]
localTopesNFUnion :: [[ModalTope VarIdent]]
localTopesEntailBottom :: Maybe Bool
actionStack :: [Action VarIdent]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
renderHideTerm :: Bool
holesAreErrors :: Bool
deferHoleMismatches :: Bool
hintLemmas :: [VarIdent]
..} = OutputDirection -> [String] -> String
block OutputDirection
dir ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null
  [ OutputDirection -> [String] -> String
block OutputDirection
TopDown
    [ case Maybe LocationInfo
location of
        Maybe LocationInfo
_ | OutputDirection
dir OutputDirection -> OutputDirection -> Bool
forall a. Eq a => a -> a -> Bool
== OutputDirection
TopDown -> String
"" -- FIXME
        Just (LocationInfo (Just String
path) (Just Int
lineNo)) ->
          String
path String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" (line " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
lineNo String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"):"
        Just (LocationInfo (Just String
path) Maybe Int
_) ->
          String
path String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":"
        Maybe LocationInfo
_  -> String
""
    , case Maybe Command
currentCommand of
        Just (Rzk.CommandDefine BNFC'Position
_loc VarIdent' BNFC'Position
name DeclUsedVars' BNFC'Position
_vars [Param' BNFC'Position]
_params Term' BNFC'Position
_ty Term' BNFC'Position
_term) ->
          String
"  Error occurred when checking\n    #define " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> VarIdent' BNFC'Position -> String
forall a. Print a => a -> String
Rzk.printTree VarIdent' BNFC'Position
name
        Just (Rzk.CommandPostulate BNFC'Position
_loc VarIdent' BNFC'Position
name DeclUsedVars' BNFC'Position
_vars [Param' BNFC'Position]
_params Term' BNFC'Position
_ty ) ->
          String
"  Error occurred when checking\n    #postulate " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> VarIdent' BNFC'Position -> String
forall a. Print a => a -> String
Rzk.printTree VarIdent' BNFC'Position
name
        Just (Rzk.CommandCheck BNFC'Position
_loc Term' BNFC'Position
term Term' BNFC'Position
ty) ->
          String
"  Error occurred when checking\n    " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term' BNFC'Position -> String
forall a. Print a => a -> String
Rzk.printTree Term' BNFC'Position
term String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" : " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term' BNFC'Position -> String
forall a. Print a => a -> String
Rzk.printTree Term' BNFC'Position
ty
        Just (Rzk.CommandCompute BNFC'Position
_loc Term' BNFC'Position
term) ->
          String
"  Error occurred when computing\n    " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term' BNFC'Position -> String
forall a. Print a => a -> String
Rzk.printTree Term' BNFC'Position
term
        Just (Rzk.CommandComputeNF BNFC'Position
_loc Term' BNFC'Position
term) ->
          String
"  Error occurred when computing NF for\n    " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term' BNFC'Position -> String
forall a. Print a => a -> String
Rzk.printTree Term' BNFC'Position
term
        Just (Rzk.CommandComputeWHNF BNFC'Position
_loc Term' BNFC'Position
term) ->
          String
"  Error occurred when computing WHNF for\n    " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term' BNFC'Position -> String
forall a. Print a => a -> String
Rzk.printTree Term' BNFC'Position
term
        Just (Rzk.CommandSetOption BNFC'Position
_loc String
optionName String
_optionValue) ->
          String
"  Error occurred when trying to set option\n    #set-option " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
optionName
        Just command :: Command
command@Rzk.CommandUnsetOption{} ->
          String
"  Error occurred when trying to unset option\n    " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Command -> String
forall a. Print a => a -> String
Rzk.printTree Command
command
        Just command :: Command
command@Rzk.CommandAssume{} ->
          String
"  Error occurred when checking assumption\n    " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Command -> String
forall a. Print a => a -> String
Rzk.printTree Command
command
        Just (Rzk.CommandSection BNFC'Position
_loc SectionName
name) ->
          String
"  Error occurred when checking\n    #section " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SectionName -> String
forall a. Print a => a -> String
Rzk.printTree SectionName
name
        Just (Rzk.CommandSectionEnd BNFC'Position
_loc SectionName
name) ->
          String
"  Error occurred when checking\n    #end " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SectionName -> String
forall a. Print a => a -> String
Rzk.printTree SectionName
name
        Maybe Command
Nothing -> String
"  Error occurred outside of any command!"
    ]
  , String
""
  , case (TermT VarIdent -> Bool) -> [TermT VarIdent] -> [TermT VarIdent]
forall a. (a -> Bool) -> [a] -> [a]
filter (TermT VarIdent -> TermT VarIdent -> Bool
forall a. Eq a => a -> a -> Bool
/= TermT VarIdent
forall var. TermT var
topeTopT) (Context VarIdent -> [TermT VarIdent]
forall var. Context var -> [TermT var]
availableTopes Context VarIdent
ctx) of
      [] -> String
"Local tope context is unrestricted (⊤)."
      [TermT VarIdent]
localTopes' -> OutputDirection -> String -> [String] -> String
namedBlock OutputDirection
TopDown String
"Local tope context:"
        [ String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
tope)
        | TermT VarIdent
tope <- [TermT VarIdent]
localTopes' ]
  , String
""
  , OutputDirection -> [String] -> String
block OutputDirection
dir
    [ String
"when " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [(VarIdent, Binder)] -> Int -> Action VarIdent -> String
ppAction [(VarIdent, Binder)]
fbs Int
0 Action VarIdent
action
    | Action VarIdent
action <- [Action VarIdent]
actionStack ]
  , OutputDirection -> String -> [String] -> String
namedBlock OutputDirection
TopDown String
"Definitions in context:"
    [ OutputDirection -> [String] -> String
block OutputDirection
dir
      [ VarIdent -> String
dispName VarIdent
x String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" : " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
ppU (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
ty)
      | (VarIdent
x, TermT VarIdent
ty) <- [(VarIdent, TermT VarIdent)] -> [(VarIdent, TermT VarIdent)]
forall a. [a] -> [a]
reverse (Context VarIdent -> [(VarIdent, TermT VarIdent)]
forall var. Context var -> [(var, TermT var)]
varTypes Context VarIdent
ctx) ] ]
  ]
  where
    ([(VarIdent, Binder)]
fbs, [(VarIdent, [([Proj], VarIdent)])]
_) = Context VarIdent
-> ([(VarIdent, Binder)], [(VarIdent, [([Proj], VarIdent)])])
contextBinders Context VarIdent
ctx
    ppU :: Term VarIdent -> String
ppU = [(VarIdent, Binder)] -> Term VarIdent -> String
ppFoldU [(VarIdent, Binder)]
fbs
    -- a pattern binder is shown as its pattern, e.g. (t , s); others by name
    dispName :: VarIdent -> String
dispName VarIdent
x = String -> (Binder -> String) -> Maybe Binder -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Term VarIdent -> String
forall a. Show a => a -> String
show (VarIdent -> Term VarIdent
forall (t :: * -> * -> *) a. a -> FS t a
Pure VarIdent
x :: Term')) (VarIdent -> String
forall a. Show a => a -> String
show (VarIdent -> String) -> (Binder -> VarIdent) -> Binder -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Binder -> VarIdent
binderDisplayName) (VarIdent -> [(VarIdent, Binder)] -> Maybe Binder
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup VarIdent
x [(VarIdent, Binder)]
fbs)

doesShadowName :: VarIdent -> TypeCheck var [VarIdent]
doesShadowName :: forall var. VarIdent -> TypeCheck var [VarIdent]
doesShadowName VarIdent
name = (Context var -> [VarIdent])
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [VarIdent]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Context var -> [VarIdent])
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      [VarIdent])
-> (Context var -> [VarIdent])
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [VarIdent]
forall a b. (a -> b) -> a -> b
$ \Context var
ctx ->
  (VarIdent -> Bool) -> [VarIdent] -> [VarIdent]
forall a. (a -> Bool) -> [a] -> [a]
filter (VarIdent
name VarIdent -> VarIdent -> Bool
forall a. Eq a => a -> a -> Bool
==) (((var, Maybe VarIdent) -> Maybe VarIdent)
-> [(var, Maybe VarIdent)] -> [VarIdent]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (var, Maybe VarIdent) -> Maybe VarIdent
forall a b. (a, b) -> b
snd (Context var -> [(var, Maybe VarIdent)]
forall var. Context var -> [(var, Maybe VarIdent)]
varOrigs Context var
ctx))

checkTopLevelDuplicate :: VarIdent -> TypeCheck var ()
checkTopLevelDuplicate :: forall var. VarIdent -> TypeCheck var ()
checkTopLevelDuplicate VarIdent
name = do
  VarIdent -> TypeCheck var [VarIdent]
forall var. VarIdent -> TypeCheck var [VarIdent]
doesShadowName VarIdent
name TypeCheck var [VarIdent]
-> ([VarIdent]
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         ())
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     ()
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    []         -> ()
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     ()
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [VarIdent]
collisions -> TypeError var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     ()
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      ())
-> TypeError var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     ()
forall a b. (a -> b) -> a -> b
$
      [VarIdent] -> VarIdent -> TypeError var
forall var. [VarIdent] -> VarIdent -> TypeError var
TypeErrorDuplicateTopLevel [VarIdent]
collisions VarIdent
name

checkNameShadowing :: VarIdent -> TypeCheck var ()
checkNameShadowing :: forall var. VarIdent -> TypeCheck var ()
checkNameShadowing VarIdent
name = do
  VarIdent -> TypeCheck var [VarIdent]
forall var. VarIdent -> TypeCheck var [VarIdent]
doesShadowName VarIdent
name TypeCheck var [VarIdent]
-> ([VarIdent]
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         ())
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     ()
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    [] -> ()
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     ()
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [VarIdent]
collisions -> String
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     ()
forall var. String -> TypeCheck var ()
issueWarning (String
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      ())
-> String
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     ()
forall a b. (a -> b) -> a -> b
$
      VarIdent' RzkPosition -> String
forall a. Print a => a -> String
Rzk.printTree (VarIdent -> VarIdent' RzkPosition
getVarIdent VarIdent
name) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" shadows an existing definition:"
      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unlines
        [ String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> VarIdent -> String
ppVarIdentWithLocation VarIdent
name
        , String
"previous top-level definitions found at"
        , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n"
          [ String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> VarIdent -> String
ppVarIdentWithLocation VarIdent
prev | VarIdent
prev <- [VarIdent]
collisions ] ]

withLocation :: LocationInfo -> TypeCheck var a -> TypeCheck var a
withLocation :: forall var a. LocationInfo -> TypeCheck var a -> TypeCheck var a
withLocation LocationInfo
loc = (Context var -> Context var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall a.
(Context var -> Context var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((Context var -> Context var)
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      a
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      a)
-> (Context var -> Context var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall a b. (a -> b) -> a -> b
$ \Context{Bool
[[ModalTope var]]
[VarIdent]
[ModalTope var]
[ScopeInfo var]
[Action var]
Maybe Bool
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: forall var. Context var -> Maybe LocationInfo
hintLemmas :: forall var. Context var -> [VarIdent]
deferHoleMismatches :: forall var. Context var -> Bool
holesAreErrors :: forall var. Context var -> Bool
renderHideTerm :: forall var. Context var -> Bool
renderBackend :: forall var. Context var -> Maybe RenderBackend
covariance :: forall var. Context var -> Covariance
verbosity :: forall var. Context var -> Verbosity
currentCommand :: forall var. Context var -> Maybe Command
actionStack :: forall var. Context var -> [Action var]
localTopesEntailBottom :: forall var. Context var -> Maybe Bool
localTopesNFUnion :: forall var. Context var -> [[ModalTope var]]
localTopesNF :: forall var. Context var -> [ModalTope var]
localTopes :: forall var. Context var -> [ModalTope var]
localScopes :: forall var. Context var -> [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopes :: [ModalTope var]
localTopesNF :: [ModalTope var]
localTopesNFUnion :: [[ModalTope var]]
localTopesEntailBottom :: Maybe Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
renderHideTerm :: Bool
holesAreErrors :: Bool
deferHoleMismatches :: Bool
hintLemmas :: [VarIdent]
..} -> Context { location :: Maybe LocationInfo
location = LocationInfo -> Maybe LocationInfo
forall a. a -> Maybe a
Just LocationInfo
loc, Bool
[[ModalTope var]]
[VarIdent]
[ModalTope var]
[ScopeInfo var]
[Action var]
Maybe Bool
Maybe Command
Maybe RenderBackend
Covariance
Verbosity
hintLemmas :: [VarIdent]
deferHoleMismatches :: Bool
holesAreErrors :: Bool
renderHideTerm :: Bool
renderBackend :: Maybe RenderBackend
covariance :: Covariance
verbosity :: Verbosity
currentCommand :: Maybe Command
actionStack :: [Action var]
localTopesEntailBottom :: Maybe Bool
localTopesNFUnion :: [[ModalTope var]]
localTopesNF :: [ModalTope var]
localTopes :: [ModalTope var]
localScopes :: [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopes :: [ModalTope var]
localTopesNF :: [ModalTope var]
localTopesNFUnion :: [[ModalTope var]]
localTopesEntailBottom :: Maybe Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
renderHideTerm :: Bool
holesAreErrors :: Bool
deferHoleMismatches :: Bool
hintLemmas :: [VarIdent]
.. }

withCommand :: Rzk.Command -> TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]) -> TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
withCommand :: Command
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
withCommand Command
command TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
tc = (Context VarIdent -> Context VarIdent)
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a.
(Context VarIdent -> Context VarIdent)
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     a
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local Context VarIdent -> Context VarIdent
forall var. Context var -> Context var
f (TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
 -> TypeCheck
      VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a b. (a -> b) -> a -> b
$ do
  result <- (([Decl'], [TypeErrorInScopedContext VarIdent])
-> Either
     (TypeErrorInScopedContext VarIdent)
     ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a b. b -> Either a b
Right (([Decl'], [TypeErrorInScopedContext VarIdent])
 -> Either
      (TypeErrorInScopedContext VarIdent)
      ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     (Either
        (TypeErrorInScopedContext VarIdent)
        ([Decl'], [TypeErrorInScopedContext VarIdent]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
tc) ReaderT
  (Context VarIdent)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
  (Either
     (TypeErrorInScopedContext VarIdent)
     ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> (TypeErrorInScopedContext VarIdent
    -> ReaderT
         (Context VarIdent)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
         (Either
            (TypeErrorInScopedContext VarIdent)
            ([Decl'], [TypeErrorInScopedContext VarIdent])))
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     (Either
        (TypeErrorInScopedContext VarIdent)
        ([Decl'], [TypeErrorInScopedContext VarIdent]))
forall a.
ReaderT
  (Context VarIdent)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
  a
-> (TypeErrorInScopedContext VarIdent
    -> ReaderT
         (Context VarIdent)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
         a)
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` (Either
  (TypeErrorInScopedContext VarIdent)
  ([Decl'], [TypeErrorInScopedContext VarIdent])
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     (Either
        (TypeErrorInScopedContext VarIdent)
        ([Decl'], [TypeErrorInScopedContext VarIdent]))
forall a.
a
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (TypeErrorInScopedContext VarIdent)
   ([Decl'], [TypeErrorInScopedContext VarIdent])
 -> ReaderT
      (Context VarIdent)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
      (Either
         (TypeErrorInScopedContext VarIdent)
         ([Decl'], [TypeErrorInScopedContext VarIdent])))
-> (TypeErrorInScopedContext VarIdent
    -> Either
         (TypeErrorInScopedContext VarIdent)
         ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> TypeErrorInScopedContext VarIdent
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     (Either
        (TypeErrorInScopedContext VarIdent)
        ([Decl'], [TypeErrorInScopedContext VarIdent]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeErrorInScopedContext VarIdent
-> Either
     (TypeErrorInScopedContext VarIdent)
     ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a b. a -> Either a b
Left)
  case result of
    Left TypeErrorInScopedContext VarIdent
err            -> ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a.
a
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [TypeErrorInScopedContext VarIdent
err])
    Right ([Decl']
decls, [TypeErrorInScopedContext VarIdent]
errs) -> ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a.
a
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Decl']
decls, [TypeErrorInScopedContext VarIdent]
errs)
  where
    f :: Context var -> Context var
f Context{Bool
[[ModalTope var]]
[VarIdent]
[ModalTope var]
[ScopeInfo var]
[Action var]
Maybe Bool
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: forall var. Context var -> Maybe LocationInfo
hintLemmas :: forall var. Context var -> [VarIdent]
deferHoleMismatches :: forall var. Context var -> Bool
holesAreErrors :: forall var. Context var -> Bool
renderHideTerm :: forall var. Context var -> Bool
renderBackend :: forall var. Context var -> Maybe RenderBackend
covariance :: forall var. Context var -> Covariance
verbosity :: forall var. Context var -> Verbosity
currentCommand :: forall var. Context var -> Maybe Command
actionStack :: forall var. Context var -> [Action var]
localTopesEntailBottom :: forall var. Context var -> Maybe Bool
localTopesNFUnion :: forall var. Context var -> [[ModalTope var]]
localTopesNF :: forall var. Context var -> [ModalTope var]
localTopes :: forall var. Context var -> [ModalTope var]
localScopes :: forall var. Context var -> [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopes :: [ModalTope var]
localTopesNF :: [ModalTope var]
localTopesNFUnion :: [[ModalTope var]]
localTopesEntailBottom :: Maybe Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
renderHideTerm :: Bool
holesAreErrors :: Bool
deferHoleMismatches :: Bool
hintLemmas :: [VarIdent]
..} = Context
      { currentCommand :: Maybe Command
currentCommand = Command -> Maybe Command
forall a. a -> Maybe a
Just Command
command
      , location :: Maybe LocationInfo
location = BNFC'Position -> LocationInfo -> LocationInfo
forall {b}. Maybe (Int, b) -> LocationInfo -> LocationInfo
updatePosition (Command -> BNFC'Position
forall a. HasPosition a => a -> BNFC'Position
Rzk.hasPosition Command
command) (LocationInfo -> LocationInfo)
-> Maybe LocationInfo -> Maybe LocationInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe LocationInfo
location
      , Bool
[[ModalTope var]]
[VarIdent]
[ModalTope var]
[ScopeInfo var]
[Action var]
Maybe Bool
Maybe RenderBackend
Covariance
Verbosity
hintLemmas :: [VarIdent]
deferHoleMismatches :: Bool
holesAreErrors :: Bool
renderHideTerm :: Bool
renderBackend :: Maybe RenderBackend
covariance :: Covariance
verbosity :: Verbosity
actionStack :: [Action var]
localTopesEntailBottom :: Maybe Bool
localTopesNFUnion :: [[ModalTope var]]
localTopesNF :: [ModalTope var]
localTopes :: [ModalTope var]
localScopes :: [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopes :: [ModalTope var]
localTopesNF :: [ModalTope var]
localTopesNFUnion :: [[ModalTope var]]
localTopesEntailBottom :: Maybe Bool
actionStack :: [Action var]
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
renderHideTerm :: Bool
holesAreErrors :: Bool
deferHoleMismatches :: Bool
hintLemmas :: [VarIdent]
.. }
    updatePosition :: Maybe (Int, b) -> LocationInfo -> LocationInfo
updatePosition Maybe (Int, b)
pos LocationInfo
loc = LocationInfo
loc { locationLine = fst <$> pos }

localDecls :: [Decl VarIdent] -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDecls :: forall a. [Decl'] -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDecls []             = TypeCheck VarIdent a -> TypeCheck VarIdent a
forall a. a -> a
id
localDecls (Decl'
decl : [Decl']
decls) = Decl' -> TypeCheck VarIdent a -> TypeCheck VarIdent a
forall a. Decl' -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDecl Decl'
decl (TypeCheck VarIdent a -> TypeCheck VarIdent a)
-> (TypeCheck VarIdent a -> TypeCheck VarIdent a)
-> TypeCheck VarIdent a
-> TypeCheck VarIdent a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Decl'] -> TypeCheck VarIdent a -> TypeCheck VarIdent a
forall a. [Decl'] -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDecls [Decl']
decls

localDeclsPrepared :: [Decl VarIdent] -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclsPrepared :: forall a. [Decl'] -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclsPrepared [] = TypeCheck VarIdent a -> TypeCheck VarIdent a
forall a. a -> a
id
localDeclsPrepared (Decl'
decl : [Decl']
decls) = Decl' -> TypeCheck VarIdent a -> TypeCheck VarIdent a
forall a. Decl' -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclPrepared Decl'
decl (TypeCheck VarIdent a -> TypeCheck VarIdent a)
-> (TypeCheck VarIdent a -> TypeCheck VarIdent a)
-> TypeCheck VarIdent a
-> TypeCheck VarIdent a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Decl'] -> TypeCheck VarIdent a -> TypeCheck VarIdent a
forall a. [Decl'] -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclsPrepared [Decl']
decls

localDecl :: Decl VarIdent -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDecl :: forall a. Decl' -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDecl (Decl VarIdent
x TermT VarIdent
ty Maybe (TermT VarIdent)
term Bool
isAssumption [VarIdent]
vars Maybe LocationInfo
loc) TypeCheck VarIdent a
tc = do
  ty' <- TermT VarIdent -> TypeCheck VarIdent (TermT VarIdent)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
memoizeWHNF TermT VarIdent
ty
  term' <- traverse memoizeWHNF term
  localDeclPrepared (Decl x ty' term' isAssumption vars loc) tc

localDeclPrepared :: Decl VarIdent -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclPrepared :: forall a. Decl' -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclPrepared (Decl VarIdent
x TermT VarIdent
ty Maybe (TermT VarIdent)
term Bool
isAssumption [VarIdent]
vars Maybe LocationInfo
loc) TypeCheck VarIdent a
tc = do
  VarIdent
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     ()
forall var. VarIdent -> TypeCheck var ()
checkTopLevelDuplicate VarIdent
x
  (Context VarIdent -> Context VarIdent)
-> TypeCheck VarIdent a -> TypeCheck VarIdent a
forall a.
(Context VarIdent -> Context VarIdent)
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     a
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local Context VarIdent -> Context VarIdent
update TypeCheck VarIdent a
tc
  where
    update :: Context VarIdent -> Context VarIdent
update = VarIdent
-> VarInfo VarIdent -> Context VarIdent -> Context VarIdent
forall var. var -> VarInfo var -> Context var -> Context var
addVarInCurrentScope VarIdent
x VarInfo
      { varType :: TermT VarIdent
varType = TermT VarIdent
ty
      , varValue :: Maybe (TermT VarIdent)
varValue = Maybe (TermT VarIdent)
term
      , varOrig :: Binder
varOrig = Maybe VarIdent -> Binder
BinderVar (VarIdent -> Maybe VarIdent
forall a. a -> Maybe a
Just VarIdent
x)
      , varModality :: TModality
varModality  = TModality
Id
      , modAccum :: TModality
modAccum = TModality
Id
      , varIsAssumption :: Bool
varIsAssumption = Bool
isAssumption
      , varIsTopLevel :: Bool
varIsTopLevel = Bool
True
      , varDeclaredAssumptions :: [VarIdent]
varDeclaredAssumptions = [VarIdent]
vars
      , varLocation :: Maybe LocationInfo
varLocation = Maybe LocationInfo
loc
      }

-- | A binding shown in a hole's local context: the display name and its type,
-- already rendered with user-facing 'VarIdent' names (see 'HoleInfo').
data HoleEntry = HoleEntry
  { HoleEntry -> VarIdent
holeEntryName :: VarIdent
  , HoleEntry -> Term VarIdent
holeEntryType :: Term'
  } deriving (HoleEntry -> HoleEntry -> Bool
(HoleEntry -> HoleEntry -> Bool)
-> (HoleEntry -> HoleEntry -> Bool) -> Eq HoleEntry
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HoleEntry -> HoleEntry -> Bool
== :: HoleEntry -> HoleEntry -> Bool
$c/= :: HoleEntry -> HoleEntry -> Bool
/= :: HoleEntry -> HoleEntry -> Bool
Eq, Int -> HoleEntry -> String -> String
[HoleEntry] -> String -> String
HoleEntry -> String
(Int -> HoleEntry -> String -> String)
-> (HoleEntry -> String)
-> ([HoleEntry] -> String -> String)
-> Show HoleEntry
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> HoleEntry -> String -> String
showsPrec :: Int -> HoleEntry -> String -> String
$cshow :: HoleEntry -> String
show :: HoleEntry -> String
$cshowList :: [HoleEntry] -> String -> String
showList :: [HoleEntry] -> String -> String
Show)

-- | The structured goal and context at a hole, recorded in lenient mode (see
-- 'allowHoles'). Everything is rendered to user-facing 'VarIdent' names at
-- record time, so 'HoleInfo' is independent of the De Bruijn scope it came
-- from. Local hypotheses are split into ordinary term variables and cube
-- variables (the cube/tope layer is specific to Rzk); the global environment is
-- deliberately excluded — it belongs in a searchable inventory, not the goal
-- panel.
data HoleInfo = HoleInfo
  { HoleInfo -> Maybe VarIdent
holeName      :: Maybe VarIdent  -- ^ the @?name@, if the hole was named
  , HoleInfo -> Term VarIdent
holeGoal      :: Term'           -- ^ expected type (the goal), kept symbolic
  , HoleInfo -> Maybe (VarIdent, Term VarIdent)
holeGoalShape :: Maybe (VarIdent, Term')
    -- ^ when the goal is a /shape/ (the hole is the argument of a
    -- shape-restricted function), the shape's bound variable and its tope: the
    -- goal then reads @(binder : holeGoal | tope)@. 'Nothing' for an ordinary
    -- goal. (Extension-type goals need no special handling — they are already a
    -- restricted type in 'holeGoal'.)
  , HoleInfo -> [HoleEntry]
holeTermVars  :: [HoleEntry]     -- ^ local hypotheses whose type is not a cube
  , HoleInfo -> [HoleEntry]
holeCubeVars  :: [HoleEntry]     -- ^ local cube variables (type is a cube)
  , HoleInfo -> [Term VarIdent]
holeTopes     :: [Term']         -- ^ local tope assumptions (excluding ⊤)
  , HoleInfo -> [Term VarIdent]
holeCandidates :: [Term']
    -- ^ elimination spines over the local hypotheses whose type fits the goal,
    -- with applied arguments left as holes (see 'allEliminationsInto'). Already
    -- rendered, like the other fields.
  , HoleInfo -> [Term VarIdent]
holeIntroductions :: [Term']
    -- ^ introduction forms for the goal type, built from its head constructor
    -- with the constituents left as holes (see 'allIntroductionsOf'). Already
    -- rendered, like the other fields.
  , HoleInfo -> Maybe String
holeDiagram   :: Maybe String
    -- ^ an SVG of the goal cell, when the goal is a renderable shape (an arrow,
    -- triangle, or square up to dimension 3): the shape with its given boundary
    -- edges, drawn from an abstract inhabitant of the goal type with the
    -- proof term hidden (see 'renderHideTerm'). 'Nothing' for a non-shape goal.
  , HoleInfo -> Maybe LocationInfo
holeLocation  :: Maybe LocationInfo
  } deriving (HoleInfo -> HoleInfo -> Bool
(HoleInfo -> HoleInfo -> Bool)
-> (HoleInfo -> HoleInfo -> Bool) -> Eq HoleInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HoleInfo -> HoleInfo -> Bool
== :: HoleInfo -> HoleInfo -> Bool
$c/= :: HoleInfo -> HoleInfo -> Bool
/= :: HoleInfo -> HoleInfo -> Bool
Eq, Int -> HoleInfo -> String -> String
[HoleInfo] -> String -> String
HoleInfo -> String
(Int -> HoleInfo -> String -> String)
-> (HoleInfo -> String)
-> ([HoleInfo] -> String -> String)
-> Show HoleInfo
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> HoleInfo -> String -> String
showsPrec :: Int -> HoleInfo -> String -> String
$cshow :: HoleInfo -> String
show :: HoleInfo -> String
$cshowList :: [HoleInfo] -> String -> String
showList :: [HoleInfo] -> String -> String
Show)

type TypeCheck var =
  ReaderT (Context var)
    (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))

freeVarsT_ :: Eq var => TermT var -> TypeCheck var [var]
freeVarsT_ :: forall var. Eq var => TermT var -> TypeCheck var [var]
freeVarsT_ TermT var
term = do
  types <- (Context var -> [(var, TermT var)])
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [(var, TermT var)]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context var -> [(var, TermT var)]
forall var. Context var -> [(var, TermT var)]
varTypes
  let typeOfVar' var
x =
        case var -> [(var, TermT var)] -> Maybe (TermT var)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup var
x [(var, TermT var)]
types of
          Maybe (TermT var)
Nothing -> String -> TermT var
forall a. String -> a
panicImpossible String
"undefined variable"
          Just TermT var
ty -> TermT var
ty
  return (freeVarsT typeOfVar' term)

traceStartAndFinish :: Show a => String -> a -> a
traceStartAndFinish :: forall a. Show a => String -> a -> a
traceStartAndFinish String
tag = String -> a -> a
forall a. String -> a -> a
trace (String
"start [" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
tag String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"]") (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  (\a
x -> String -> a -> a
forall a. String -> a -> a
trace (String
"finish [" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
tag String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"] with " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
x) a
x)

entailM :: Eq var => [ModalTope var] -> TermT var -> TypeCheck var Bool
entailM :: forall var.
Eq var =>
[ModalTope var] -> TermT var -> TypeCheck var Bool
entailM [ModalTope var]
modalTopes TermT var
goal = do
  -- genTopes <- generateTopesForPointsM (allTopePoints goal)
  discreteAxioms <- TypeCheck var [ModalTope var]
forall var. Eq var => TypeCheck var [ModalTope var]
generateTopesForModalCubeVarsM
  let topes'    = [ModalTope var] -> [ModalTope var]
forall a. Eq a => [a] -> [a]
nubTermT ([ModalTope var]
modalTopes [ModalTope var] -> [ModalTope var] -> [ModalTope var]
forall a. Semigroup a => a -> a -> a
<> [ModalTope var]
discreteAxioms)
      topes''   = [ModalTope var] -> [[ModalTope var]]
forall var. Eq var => [ModalTope var] -> [[ModalTope var]]
simplifyLHSwithDisjunctions [ModalTope var]
topes'
  topes'''  <- mapM (fmap (saturateTopes (allTopePoints goal) . saturateBottom) . saturateInv) topes''
  prettyTopes <- mapM ppTermInContext (map tTope (saturateTopes (allTopePoints goal) (simplifyLHS topes')))
  prettyTope <- ppTermInContext goal
  traceTypeCheck Debug
    ("entail " <> intercalate ", " prettyTopes <> " |- " <> prettyTope) $
      and <$> mapM (`solveRHSM` goal) topes'''


generateTopesForModalCubeVarsM :: Eq var => TypeCheck var [ModalTope var]
generateTopesForModalCubeVarsM :: forall var. Eq var => TypeCheck var [ModalTope var]
generateTopesForModalCubeVarsM = do
  infos <- (Context var -> [(var, VarInfo var)])
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [(var, VarInfo var)]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context var -> [(var, VarInfo var)]
forall var. Context var -> [(var, VarInfo var)]
varInfos
  fmap (nubTermT . concat) $ forM infos $ \(var
var, VarInfo var
info) ->
    case VarInfo var -> TModality
forall var. VarInfo var -> TModality
varModality VarInfo var
info of
      TModality
Flat -> do
        TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT (VarInfo var -> TermT var
forall var. VarInfo var -> TermT var
varType VarInfo var
info) TypeCheck var (TermT var)
-> (TermT var
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         [ModalTope var])
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [ModalTope var]
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Cube2T{} -> do
            let pt :: FS t var
pt = var -> FS t var
forall (t :: * -> * -> *) a. a -> FS t a
Pure var
var
            [ModalTope var]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [ModalTope var]
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return [TermT var -> ModalTope var
forall var. TermT var -> ModalTope var
plainTope (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeOrT (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
forall {t :: * -> * -> *}. FS t var
pt TermT var
forall var. TermT var
cube2_0T) (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
forall {t :: * -> * -> *}. FS t var
pt TermT var
forall var. TermT var
cube2_1T))]
          CubeIT{} -> do
            let pt :: FS t var
pt = var -> FS t var
forall (t :: * -> * -> *) a. a -> FS t a
Pure var
var
            [ModalTope var]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [ModalTope var]
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return [TermT var -> ModalTope var
forall var. TermT var -> ModalTope var
plainTope (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeOrT (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
forall {t :: * -> * -> *}. FS t var
pt TermT var
forall var. TermT var
cubeI_0T) (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
forall {t :: * -> * -> *}. FS t var
pt TermT var
forall var. TermT var
cubeI_1T))]
          TermT var
_ -> [ModalTope var]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [ModalTope var]
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return []
      TModality
_ -> [ModalTope var]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [ModalTope var]
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return []

entailTraceM :: Eq var => [ModalTope var] -> TermT var -> TypeCheck var Bool
entailTraceM :: forall var.
Eq var =>
[ModalTope var] -> TermT var -> TypeCheck var Bool
entailTraceM [ModalTope var]
modalTopes TermT var
goal = do
  topes' <- (TermT var
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      String)
-> [TermT var]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     String
forall var. Eq var => TermT var -> TypeCheck var String
ppTermInContext ([ModalTope var] -> [TermT var]
forall var. [ModalTope var] -> [TermT var]
accessibleTopes [ModalTope var]
modalTopes)
  goal' <- ppTermInContext goal
  result <- trace ("entail " <> intercalate ", " topes' <> " |- " <> goal') $
        modalTopes `entailM` goal
  return $ trace ("  " <> show result) result

nubTermT :: Eq a => [a] -> [a]
nubTermT :: forall a. Eq a => [a] -> [a]
nubTermT []     = []
nubTermT (a
t:[a]
ts) = a
t a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
forall a. Eq a => [a] -> [a]
nubTermT ((a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
t) [a]
ts)

saturateTopes :: Eq var => [TermT var] -> [ModalTope var] -> [ModalTope var]
saturateTopes :: forall var.
Eq var =>
[TermT var] -> [ModalTope var] -> [ModalTope var]
saturateTopes [TermT var]
_points [ModalTope var]
topes =
  let ([ModalTope var]
accessible, [ModalTope var]
inaccessible) = [ModalTope var] -> ([ModalTope var], [ModalTope var])
forall var. [ModalTope var] -> ([ModalTope var], [ModalTope var])
partitionAccessible [ModalTope var]
topes
      saturated :: [ModalTope var]
saturated = (ModalTope var -> [ModalTope var] -> Bool)
-> ([ModalTope var] -> [ModalTope var] -> [ModalTope var])
-> [ModalTope var]
-> [ModalTope var]
forall a. (a -> [a] -> Bool) -> ([a] -> [a] -> [a]) -> [a] -> [a]
saturateWith
        (\ModalTope var
mt [ModalTope var]
ts -> ModalTope var
mt ModalTope var -> [ModalTope var] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ModalTope var]
ts)
        (\[ModalTope var]
new [ModalTope var]
old -> (TermT var -> ModalTope var) -> [TermT var] -> [ModalTope var]
forall a b. (a -> b) -> [a] -> [b]
map TermT var -> ModalTope var
forall var. TermT var -> ModalTope var
plainTope ([TermT var] -> [ModalTope var]) -> [TermT var] -> [ModalTope var]
forall a b. (a -> b) -> a -> b
$ [TermT var] -> [TermT var] -> [TermT var]
forall var. Eq var => [TermT var] -> [TermT var] -> [TermT var]
generateTopes ((ModalTope var -> TermT var) -> [ModalTope var] -> [TermT var]
forall a b. (a -> b) -> [a] -> [b]
map ModalTope var -> TermT var
forall var. ModalTope var -> TermT var
tTope [ModalTope var]
new) ((ModalTope var -> TermT var) -> [ModalTope var] -> [TermT var]
forall a b. (a -> b) -> [a] -> [b]
map ModalTope var -> TermT var
forall var. ModalTope var -> TermT var
tTope [ModalTope var]
old))
        [ModalTope var]
accessible
  in [ModalTope var]
saturated [ModalTope var] -> [ModalTope var] -> [ModalTope var]
forall a. Semigroup a => a -> a -> a
<> [ModalTope var]
inaccessible

saturateInv :: Eq var => [ModalTope var] -> TypeCheck var [ModalTope var]
saturateInv :: forall var.
Eq var =>
[ModalTope var] -> TypeCheck var [ModalTope var]
saturateInv [ModalTope var]
modalTopes = do
    -- FIXME: this is a workaround; ideally we should regenerate all topes
    -- on EVERY modality change in any layer, but that would produce too many;
    -- for now we also invert topes that were accessible before the modality shift
    let accessible :: [ModalTope var]
accessible = [ModalTope var] -> [ModalTope var]
forall var. [ModalTope var] -> [ModalTope var]
filterAccessible [ModalTope var]
modalTopes
        accessibleById :: [ModalTope var]
accessibleById = (ModalTope var -> Bool) -> [ModalTope var] -> [ModalTope var]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ModalTope var
mt -> TModality -> TModality -> Bool
forall m. ModeTheory m => m -> m -> Bool
coe (ModalTope var -> TModality
forall var. ModalTope var -> TModality
tModVar ModalTope var
mt) TModality
Id) [ModalTope var]
modalTopes
    invResults <- [ModalTope var]
-> (ModalTope var
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         (ModalTope var))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [ModalTope var]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([ModalTope var] -> [ModalTope var]
forall a. Eq a => [a] -> [a]
nubTermT ([ModalTope var]
accessible [ModalTope var] -> [ModalTope var] -> [ModalTope var]
forall a. Semigroup a => a -> a -> a
<> [ModalTope var]
accessibleById)) ((ModalTope var
  -> ReaderT
       (Context var)
       (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
       (ModalTope var))
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      [ModalTope var])
-> (ModalTope var
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         (ModalTope var))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [ModalTope var]
forall a b. (a -> b) -> a -> b
$ \ModalTope var
mt -> do
      nf <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope (TermT var -> TypeCheck var (TermT var))
-> TermT var -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ TermT var -> TModality -> TModality -> TermT var -> TermT var
forall var.
TermT var -> TModality -> TModality -> TermT var -> TermT var
modExtractT TermT var
forall var. TermT var
topeT TModality
Id TModality
Op (TermT var -> TermT var
forall var. TermT var -> TermT var
topeInvT (ModalTope var -> TermT var
forall var. ModalTope var -> TermT var
tTope ModalTope var
mt))
      return $ ModalTope (tModAccum mt) Op nf
    let accessibleUnderOp = (ModalTope var -> Bool) -> [ModalTope var] -> [ModalTope var]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ModalTope var
mt -> TModality -> TModality -> Bool
forall m. ModeTheory m => m -> m -> Bool
coe (ModalTope var -> TModality
forall var. ModalTope var -> TModality
tModVar ModalTope var
mt) (TModality -> TModality -> TModality
forall m. ModeTheory m => m -> m -> m
comp (ModalTope var -> TModality
forall var. ModalTope var -> TModality
tModAccum ModalTope var
mt) TModality
Op)) [ModalTope var]
modalTopes
    uninvResults <- forM accessibleUnderOp $ \(ModalTope TModality
acc TModality
var' TermT var
phi) -> do
      nf <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope (TermT var -> TypeCheck var (TermT var))
-> TermT var -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ TermT var -> TermT var
forall var. TermT var -> TermT var
topeUninvT (TermT var -> TModality -> TermT var -> TermT var
forall var. TermT var -> TModality -> TermT var -> TermT var
modAppT TermT var
forall var. TermT var
topeT TModality
Op TermT var
phi)
      return $ ModalTope (comp acc Op) var' nf
    let newTopes = [ModalTope var] -> [ModalTope var]
forall a. Eq a => [a] -> [a]
nubTermT ([ModalTope var]
invResults [ModalTope var] -> [ModalTope var] -> [ModalTope var]
forall a. Semigroup a => a -> a -> a
<> [ModalTope var]
uninvResults)
        fresh = (ModalTope var -> Bool) -> [ModalTope var] -> [ModalTope var]
forall a. (a -> Bool) -> [a] -> [a]
filter (ModalTope var -> [ModalTope var] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ModalTope var]
modalTopes) [ModalTope var]
newTopes
    return (modalTopes <> fresh)

-- | Ex falso for BOT, lifted across modalities.
--
-- A contradiction in the topes that are genuinely available at the identity
-- modality entails BOT, and BOT entails @_μ BOT@ for every modality @μ@ by the
-- absurd rule (this holds for BOT specifically; a general tope @φ@ does NOT give
-- @_μ φ@, which would need the missing unit @id ⇒ μ@). Re-asserting @_μ BOT@ at
-- each lock @μ@ where an available tope was hidden lets the contradiction survive
-- the lock: e.g. @_b BOT@ is accessible under a @_b@ lock (@coe Flat Flat@), so
-- @mod _b recBOT@ in a vacuous context is accepted.
--
-- A tope counts as available at the identity modality when its variable modality
-- coerces into @Id@: a @_b@-modal tope qualifies via the counit (@coe Flat Id@),
-- but a @_#@-modal one does not (@coe Sharp Id@ is False) — which is exactly why
-- @_# BOT@ does not leak to plain BOT (see ill-modal-sharp-bot-not-bot).
saturateBottom :: Eq var => [ModalTope var] -> [ModalTope var]
saturateBottom :: forall var. Eq var => [ModalTope var] -> [ModalTope var]
saturateBottom [ModalTope var]
modalTopes
  | [TModality] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TModality]
droppedAccums = [ModalTope var]
modalTopes   -- nothing hidden by a lock; ordinary saturation suffices
  | Bool
botDerivable       = [ModalTope var]
modalTopes [ModalTope var] -> [ModalTope var] -> [ModalTope var]
forall a. Semigroup a => a -> a -> a
<> [ModalTope var]
forall var. [ModalTope var]
fresh
  | Bool
otherwise          = [ModalTope var]
modalTopes
  where
    idAccessible :: [ModalTope var]
idAccessible  = (ModalTope var -> Bool) -> [ModalTope var] -> [ModalTope var]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ModalTope var
mt -> TModality -> TModality -> Bool
forall m. ModeTheory m => m -> m -> Bool
coe (ModalTope var -> TModality
forall var. ModalTope var -> TModality
tModVar ModalTope var
mt) TModality
Id) [ModalTope var]
modalTopes
    droppedAccums :: [TModality]
droppedAccums = [TModality] -> [TModality]
forall a. Eq a => [a] -> [a]
nub [ ModalTope var -> TModality
forall var. ModalTope var -> TModality
tModAccum ModalTope var
mt | ModalTope var
mt <- [ModalTope var]
idAccessible, Bool -> Bool
not (ModalTope var -> Bool
forall a. ModalTope a -> Bool
isAccessible ModalTope var
mt) ]
    saturatedId :: [TermT var]
saturatedId   = (TermT var -> [TermT var] -> Bool)
-> ([TermT var] -> [TermT var] -> [TermT var])
-> [TermT var]
-> [TermT var]
forall a. (a -> [a] -> Bool) -> ([a] -> [a] -> [a]) -> [a] -> [a]
saturateWith (\TermT var
t [TermT var]
ts -> TermT var
t TermT var -> [TermT var] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TermT var]
ts) [TermT var] -> [TermT var] -> [TermT var]
forall var. Eq var => [TermT var] -> [TermT var] -> [TermT var]
generateTopes ((ModalTope var -> TermT var) -> [ModalTope var] -> [TermT var]
forall a b. (a -> b) -> [a] -> [b]
map ModalTope var -> TermT var
forall var. ModalTope var -> TermT var
tTope [ModalTope var]
idAccessible)
    botDerivable :: Bool
botDerivable  = TermT var
forall var. TermT var
topeBottomT TermT var -> [TermT var] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TermT var]
saturatedId
    fresh :: [ModalTope var]
fresh = [ ModalTope var
forall {var}. ModalTope var
mt
            | TModality
acc <- [TModality]
droppedAccums
            , let mt :: ModalTope var
mt = TModality -> TModality -> TermT var -> ModalTope var
forall var. TModality -> TModality -> TermT var -> ModalTope var
ModalTope TModality
acc TModality
acc TermT var
forall var. TermT var
topeBottomT
            , ModalTope var
forall {var}. ModalTope var
mt ModalTope var -> [ModalTope var] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ModalTope var]
modalTopes ]

-- FIXME: cleanup
saturateWith :: (a -> [a] -> Bool) -> ([a] -> [a] -> [a]) -> [a] -> [a]
saturateWith :: forall a. (a -> [a] -> Bool) -> ([a] -> [a] -> [a]) -> [a] -> [a]
saturateWith a -> [a] -> Bool
elem' [a] -> [a] -> [a]
step [a]
zs = [a] -> [a] -> [a]
go ([a] -> [a]
nub' [a]
zs) []
  where
    go :: [a] -> [a] -> [a]
go [a]
lastNew [a]
xs
      | [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
new = [a]
lastNew
      | Bool
otherwise = [a]
lastNew [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> [a] -> [a] -> [a]
go [a]
new [a]
xs'
      where
        xs' :: [a]
xs' = [a]
lastNew [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> [a]
xs
        new :: [a]
new = (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> [a] -> Bool
`elem'` [a]
xs')) ([a] -> [a]
nub' ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ [a] -> [a] -> [a]
step [a]
lastNew [a]
xs)
    nub' :: [a] -> [a]
nub' []     = []
    nub' (a
x:[a]
xs) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
nub' ((a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> [a] -> Bool
`elem'` [a
x])) [a]
xs)

generateTopes :: Eq var => [TermT var] -> [TermT var] -> [TermT var]
generateTopes :: forall var. Eq var => [TermT var] -> [TermT var] -> [TermT var]
generateTopes [TermT var]
newTopes [TermT var]
oldTopes
  | TermT var
forall var. TermT var
topeBottomT TermT var -> [TermT var] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TermT var]
newTopes = []
  | TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
forall var. TermT var
cube2_0T TermT var
forall var. TermT var
cube2_1T TermT var -> [TermT var] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TermT var]
newTopes = [TermT var
forall var. TermT var
topeBottomT]
  | TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
forall var. TermT var
cubeI_0T TermT var
forall var. TermT var
cubeI_1T TermT var -> [TermT var] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TermT var]
newTopes = [TermT var
forall var. TermT var
topeBottomT]
  | [TermT var] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TermT var]
oldTopes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
100 = []    -- FIXME
  | Bool
otherwise = [[TermT var]] -> [TermT var]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [  -- symmetry EQ
        [ TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
y TermT var
x | TopeEQT TypeInfo (TermT var)
_ty TermT var
x TermT var
y <- [TermT var]
newTopes ]
        -- transitivity EQ (1)
      , [ TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
x TermT var
z
        | TopeEQT TypeInfo (TermT var)
_ty TermT var
x TermT var
y : [TermT var]
newTopes' <- [TermT var] -> [[TermT var]]
forall a. [a] -> [[a]]
tails [TermT var]
newTopes
        , TopeEQT TypeInfo (TermT var)
_ty TermT var
y' TermT var
z <- [TermT var]
newTopes' [TermT var] -> [TermT var] -> [TermT var]
forall a. Semigroup a => a -> a -> a
<> [TermT var]
oldTopes
        , TermT var
y TermT var -> TermT var -> Bool
forall a. Eq a => a -> a -> Bool
== TermT var
y' ]
        -- transitivity EQ (2)
      , [ TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
x TermT var
z
        | TopeEQT TypeInfo (TermT var)
_ty TermT var
y TermT var
z : [TermT var]
newTopes' <- [TermT var] -> [[TermT var]]
forall a. [a] -> [[a]]
tails [TermT var]
newTopes
        , TopeEQT TypeInfo (TermT var)
_ty TermT var
x TermT var
y' <- [TermT var]
newTopes' [TermT var] -> [TermT var] -> [TermT var]
forall a. Semigroup a => a -> a -> a
<> [TermT var]
oldTopes
        , TermT var
y TermT var -> TermT var -> Bool
forall a. Eq a => a -> a -> Bool
== TermT var
y' ]

        -- transitivity LEQ (1)
      , [ TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
x TermT var
z
        | TopeLEQT TypeInfo (TermT var)
_ty TermT var
x TermT var
y : [TermT var]
newTopes' <- [TermT var] -> [[TermT var]]
forall a. [a] -> [[a]]
tails [TermT var]
newTopes
        , TopeLEQT TypeInfo (TermT var)
_ty TermT var
y' TermT var
z <- [TermT var]
newTopes' [TermT var] -> [TermT var] -> [TermT var]
forall a. Semigroup a => a -> a -> a
<> [TermT var]
oldTopes
        , TermT var
y TermT var -> TermT var -> Bool
forall a. Eq a => a -> a -> Bool
== TermT var
y' ]
        -- transitivity LEQ (2)
      , [ TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
x TermT var
z
        | TopeLEQT TypeInfo (TermT var)
_ty TermT var
y TermT var
z : [TermT var]
newTopes' <- [TermT var] -> [[TermT var]]
forall a. [a] -> [[a]]
tails [TermT var]
newTopes
        , TopeLEQT TypeInfo (TermT var)
_ty TermT var
x TermT var
y' <- [TermT var]
newTopes' [TermT var] -> [TermT var] -> [TermT var]
forall a. Semigroup a => a -> a -> a
<> [TermT var]
oldTopes
        , TermT var
y TermT var -> TermT var -> Bool
forall a. Eq a => a -> a -> Bool
== TermT var
y' ]

        -- antisymmetry LEQ
      , [ TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
x TermT var
y
        | TopeLEQT TypeInfo (TermT var)
_ty TermT var
x TermT var
y : [TermT var]
newTopes' <- [TermT var] -> [[TermT var]]
forall a. [a] -> [[a]]
tails [TermT var]
newTopes
        , TopeLEQT TypeInfo (TermT var)
_ty TermT var
y' TermT var
x' <- [TermT var]
newTopes' [TermT var] -> [TermT var] -> [TermT var]
forall a. Semigroup a => a -> a -> a
<> [TermT var]
oldTopes
        , TermT var
y TermT var -> TermT var -> Bool
forall a. Eq a => a -> a -> Bool
== TermT var
y'
        , TermT var
x TermT var -> TermT var -> Bool
forall a. Eq a => a -> a -> Bool
== TermT var
x' ]

        -- FIXME: special case of substitution of EQ
        -- transitivity EQ-LEQ (1)
      , [ TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
x TermT var
z
        | TopeEQT  TypeInfo (TermT var)
_ty TermT var
y TermT var
z : [TermT var]
newTopes' <- [TermT var] -> [[TermT var]]
forall a. [a] -> [[a]]
tails [TermT var]
newTopes
        , TopeLEQT TypeInfo (TermT var)
_ty TermT var
x TermT var
y' <- [TermT var]
newTopes' [TermT var] -> [TermT var] -> [TermT var]
forall a. Semigroup a => a -> a -> a
<> [TermT var]
oldTopes
        , TermT var
y TermT var -> TermT var -> Bool
forall a. Eq a => a -> a -> Bool
== TermT var
y' ]

        -- FIXME: special case of substitution of EQ
        -- transitivity EQ-LEQ (2)
      , [ TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
x TermT var
z
        | TopeEQT  TypeInfo (TermT var)
_ty TermT var
x TermT var
y : [TermT var]
newTopes' <- [TermT var] -> [[TermT var]]
forall a. [a] -> [[a]]
tails [TermT var]
newTopes
        , TopeLEQT TypeInfo (TermT var)
_ty TermT var
y' TermT var
z <- [TermT var]
newTopes' [TermT var] -> [TermT var] -> [TermT var]
forall a. Semigroup a => a -> a -> a
<> [TermT var]
oldTopes
        , TermT var
y TermT var -> TermT var -> Bool
forall a. Eq a => a -> a -> Bool
== TermT var
y' ]

        -- FIXME: special case of substitution of EQ
        -- transitivity EQ-LEQ (3)
      , [ TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
x TermT var
z
        | TopeLEQT  TypeInfo (TermT var)
_ty TermT var
y TermT var
z : [TermT var]
newTopes' <- [TermT var] -> [[TermT var]]
forall a. [a] -> [[a]]
tails [TermT var]
newTopes
        , TopeEQT TypeInfo (TermT var)
_ty TermT var
x TermT var
y' <- [TermT var]
newTopes' [TermT var] -> [TermT var] -> [TermT var]
forall a. Semigroup a => a -> a -> a
<> [TermT var]
oldTopes
        , TermT var
y TermT var -> TermT var -> Bool
forall a. Eq a => a -> a -> Bool
== TermT var
y' ]

        -- FIXME: special case of substitution of EQ
        -- transitivity EQ-LEQ (4)
      , [ TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
x TermT var
z
        | TopeLEQT  TypeInfo (TermT var)
_ty TermT var
x TermT var
y : [TermT var]
newTopes' <- [TermT var] -> [[TermT var]]
forall a. [a] -> [[a]]
tails [TermT var]
newTopes
        , TopeEQT TypeInfo (TermT var)
_ty TermT var
y' TermT var
z <- [TermT var]
newTopes' [TermT var] -> [TermT var] -> [TermT var]
forall a. Semigroup a => a -> a -> a
<> [TermT var]
oldTopes
        , TermT var
y TermT var -> TermT var -> Bool
forall a. Eq a => a -> a -> Bool
== TermT var
y' ]

        -- FIXME: consequence of LEM for LEQ and antisymmetry for LEQ
      , [ TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
x TermT var
y | TopeLEQT TypeInfo (TermT var)
_ty TermT var
x y :: TermT var
y@Cube2_0T{} <- [TermT var]
newTopes ]
        -- FIXME: consequence of LEM for LEQ and antisymmetry for LEQ
      , [ TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
x TermT var
y | TopeLEQT TypeInfo (TermT var)
_ty x :: TermT var
x@Cube2_1T{} TermT var
y <- [TermT var]
newTopes ]
      , [ TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
x TermT var
y | TopeLEQT TypeInfo (TermT var)
_ty TermT var
x y :: TermT var
y@CubeI_0T{} <- [TermT var]
newTopes ]
        -- FIXME: consequence of LEM for LEQ and antisymmetry for LEQ
      , [ TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
x TermT var
y | TopeLEQT TypeInfo (TermT var)
_ty x :: TermT var
x@CubeI_1T{} TermT var
y <- [TermT var]
newTopes ]

        -- subtyping 2 <: II: endpoints and order of 2 lift to II
      , [ TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
x TermT var
forall var. TermT var
cubeI_0T | TopeEQT TypeInfo (TermT var)
_ty TermT var
x Cube2_0T{} <- [TermT var]
newTopes ]
      , [ TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
forall var. TermT var
cubeI_0T TermT var
x | TopeEQT TypeInfo (TermT var)
_ty Cube2_0T{} TermT var
x <- [TermT var]
newTopes ]
      , [ TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
x TermT var
forall var. TermT var
cubeI_1T | TopeEQT TypeInfo (TermT var)
_ty TermT var
x Cube2_1T{} <- [TermT var]
newTopes ]
      , [ TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
forall var. TermT var
cubeI_1T TermT var
x | TopeEQT TypeInfo (TermT var)
_ty Cube2_1T{} TermT var
x <- [TermT var]
newTopes ]
      , [ TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
x TermT var
forall var. TermT var
cubeI_0T | TopeLEQT TypeInfo (TermT var)
_ty TermT var
x Cube2_0T{} <- [TermT var]
newTopes ]
      , [ TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
forall var. TermT var
cubeI_0T TermT var
x | TopeLEQT TypeInfo (TermT var)
_ty Cube2_0T{} TermT var
x <- [TermT var]
newTopes ]
      , [ TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
x TermT var
forall var. TermT var
cubeI_1T | TopeLEQT TypeInfo (TermT var)
_ty TermT var
x Cube2_1T{} <- [TermT var]
newTopes ]
      , [ TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
forall var. TermT var
cubeI_1T TermT var
x | TopeLEQT TypeInfo (TermT var)
_ty Cube2_1T{} TermT var
x <- [TermT var]
newTopes ]
      ]

generateTopesForPointsM :: Eq var => [TermT var] -> TypeCheck var [TermT var]
generateTopesForPointsM :: forall var. Eq var => [TermT var] -> TypeCheck var [TermT var]
generateTopesForPointsM [TermT var]
points = do
  let pairs :: [(TermT var, TermT var)]
pairs = [(TermT var, TermT var)] -> [(TermT var, TermT var)]
forall a. Eq a => [a] -> [a]
nub ([(TermT var, TermT var)] -> [(TermT var, TermT var)])
-> [(TermT var, TermT var)] -> [(TermT var, TermT var)]
forall a b. (a -> b) -> a -> b
$ [[(TermT var, TermT var)]] -> [(TermT var, TermT var)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [ (TermT var
x, TermT var
y)
          | TermT var
x : [TermT var]
points' <- [TermT var] -> [[TermT var]]
forall a. [a] -> [[a]]
tails ((TermT var -> Bool) -> [TermT var] -> [TermT var]
forall a. (a -> Bool) -> [a] -> [a]
filter (TermT var -> [TermT var] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [TermT var
forall var. TermT var
cube2_0T, TermT var
forall var. TermT var
cube2_1T, TermT var
forall var. TermT var
cubeI_0T, TermT var
forall var. TermT var
cubeI_1T]) [TermT var]
points)
          , TermT var
y <- [TermT var]
points'
          , TermT var
x TermT var -> TermT var -> Bool
forall a. Eq a => a -> a -> Bool
/= TermT var
y ]
        ]
  stars <- [TermT var]
-> (TermT var
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         [TermT var])
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [[TermT var]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [TermT var]
points ((TermT var
  -> ReaderT
       (Context var)
       (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
       [TermT var])
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      [[TermT var]])
-> (TermT var
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         [TermT var])
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [[TermT var]]
forall a b. (a -> b) -> a -> b
$ \TermT var
x -> do
    xType <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
x
    return $ if (xType == cubeUnitT)
      then [topeEQT x cubeUnitStarT]
      else []
  topes <- forM pairs $ \(TermT var
x, TermT var
y) -> do
    xType <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
x
    yType <- typeOf y
    return $ if (xType == cube2T) && (yType == cube2T)
      then [topeOrT (topeLEQT x y) (topeLEQT y x)]
      else []
  return (concat (topes ++ stars))

allTopePoints :: Eq var => TermT var -> [TermT var]
allTopePoints :: forall var. Eq var => TermT var -> [TermT var]
allTopePoints = [TermT var] -> [TermT var]
forall a. Eq a => [a] -> [a]
nubTermT ([TermT var] -> [TermT var])
-> (TermT var -> [TermT var]) -> TermT var -> [TermT var]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TermT var -> [TermT var]) -> [TermT var] -> [TermT var]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TermT var -> [TermT var]
forall var. TermT var -> [TermT var]
subPoints ([TermT var] -> [TermT var])
-> (TermT var -> [TermT var]) -> TermT var -> [TermT var]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TermT var] -> [TermT var]
forall a. Eq a => [a] -> [a]
nubTermT ([TermT var] -> [TermT var])
-> (TermT var -> [TermT var]) -> TermT var -> [TermT var]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermT var -> [TermT var]
forall var. TermT var -> [TermT var]
topePoints

topePoints :: TermT var -> [TermT var]
topePoints :: forall var. TermT var -> [TermT var]
topePoints = \case
  TopeTopT{}     -> []
  TopeBottomT{}  -> []
  TopeAndT TypeInfo (TermT var)
_ TermT var
l TermT var
r -> TermT var -> [TermT var]
forall var. TermT var -> [TermT var]
topePoints TermT var
l [TermT var] -> [TermT var] -> [TermT var]
forall a. Semigroup a => a -> a -> a
<> TermT var -> [TermT var]
forall var. TermT var -> [TermT var]
topePoints TermT var
r
  TopeOrT  TypeInfo (TermT var)
_ TermT var
l TermT var
r -> TermT var -> [TermT var]
forall var. TermT var -> [TermT var]
topePoints TermT var
l [TermT var] -> [TermT var] -> [TermT var]
forall a. Semigroup a => a -> a -> a
<> TermT var -> [TermT var]
forall var. TermT var -> [TermT var]
topePoints TermT var
r
  TopeEQT  TypeInfo (TermT var)
_ TermT var
x TermT var
y -> [TermT var
x, TermT var
y]
  TopeLEQT TypeInfo (TermT var)
_ TermT var
x TermT var
y -> [TermT var
x, TermT var
y]
  TermT var
_              -> []

subPoints :: TermT var -> [TermT var]
subPoints :: forall var. TermT var -> [TermT var]
subPoints = \case
  p :: TermT var
p@(PairT TypeInfo (TermT var)
_ TermT var
x TermT var
y) -> TermT var
p TermT var -> [TermT var] -> [TermT var]
forall a. a -> [a] -> [a]
: (TermT var -> [TermT var]) -> [TermT var] -> [TermT var]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TermT var -> [TermT var]
forall var. TermT var -> [TermT var]
subPoints [TermT var
x, TermT var
y]
  p :: TermT var
p@Pure{} -> [TermT var
p]
  p :: TermT var
p@(Free (AnnF TypeInfo{Maybe (TermT var)
TermT var
infoType :: forall term. TypeInfo term -> term
infoWHNF :: forall term. TypeInfo term -> Maybe term
infoNF :: forall term. TypeInfo term -> Maybe term
infoType :: TermT var
infoWHNF :: Maybe (TermT var)
infoNF :: Maybe (TermT var)
..} TermF (Scope (FS (AnnF TypeInfo TermF)) var) (TermT var)
_))
    | Cube2T{} <- TermT var
infoType -> [TermT var
p]
    | CubeUnitT{} <- TermT var
infoType -> [TermT var
p]
  TermT var
_ -> []

-- | Simplify the context, including disjunctions. See also 'simplifyLHS'.
simplifyLHSwithDisjunctions :: Eq var => [ModalTope var] -> [[ModalTope var]]
simplifyLHSwithDisjunctions :: forall var. Eq var => [ModalTope var] -> [[ModalTope var]]
simplifyLHSwithDisjunctions [ModalTope var]
topes = ([ModalTope var] -> [ModalTope var])
-> [[ModalTope var]] -> [[ModalTope var]]
forall a b. (a -> b) -> [a] -> [b]
map [ModalTope var] -> [ModalTope var]
forall a. Eq a => [a] -> [a]
nubTermT ([[ModalTope var]] -> [[ModalTope var]])
-> [[ModalTope var]] -> [[ModalTope var]]
forall a b. (a -> b) -> a -> b
$
  case [ModalTope var]
topes of
    [] -> [[]]
    (ModalTope TModality
_ TModality
_ TopeTopT{}) : [ModalTope var]
topes' -> [ModalTope var] -> [[ModalTope var]]
forall var. Eq var => [ModalTope var] -> [[ModalTope var]]
simplifyLHSwithDisjunctions [ModalTope var]
topes'
    (ModalTope TModality
mAcc TModality
mVar TopeBottomT{}) : [ModalTope var]
_  -> [[TModality
-> TModality -> FS (AnnF TypeInfo TermF) var -> ModalTope var
forall var. TModality -> TModality -> TermT var -> ModalTope var
ModalTope TModality
mAcc TModality
mVar FS (AnnF TypeInfo TermF) var
forall var. TermT var
topeBottomT]]
    (ModalTope TModality
mAcc TModality
mVar (TopeAndT TypeInfo (FS (AnnF TypeInfo TermF) var)
_ FS (AnnF TypeInfo TermF) var
l FS (AnnF TypeInfo TermF) var
r)) : [ModalTope var]
topes' -> [ModalTope var] -> [[ModalTope var]]
forall var. Eq var => [ModalTope var] -> [[ModalTope var]]
simplifyLHSwithDisjunctions ((TModality
-> TModality -> FS (AnnF TypeInfo TermF) var -> ModalTope var
forall var. TModality -> TModality -> TermT var -> ModalTope var
ModalTope TModality
mAcc TModality
mVar FS (AnnF TypeInfo TermF) var
l) ModalTope var -> [ModalTope var] -> [ModalTope var]
forall a. a -> [a] -> [a]
: (TModality
-> TModality -> FS (AnnF TypeInfo TermF) var -> ModalTope var
forall var. TModality -> TModality -> TermT var -> ModalTope var
ModalTope TModality
mAcc TModality
mVar FS (AnnF TypeInfo TermF) var
r) ModalTope var -> [ModalTope var] -> [ModalTope var]
forall a. a -> [a] -> [a]
: [ModalTope var]
topes')

    -- NOTE: it is inefficient to expand disjunctions immediately
    (ModalTope TModality
mAcc TModality
mVar (TopeOrT  TypeInfo (FS (AnnF TypeInfo TermF) var)
_ FS (AnnF TypeInfo TermF) var
l FS (AnnF TypeInfo TermF) var
r)) : [ModalTope var]
topes' -> [ModalTope var] -> [[ModalTope var]]
forall var. Eq var => [ModalTope var] -> [[ModalTope var]]
simplifyLHSwithDisjunctions ((TModality
-> TModality -> FS (AnnF TypeInfo TermF) var -> ModalTope var
forall var. TModality -> TModality -> TermT var -> ModalTope var
ModalTope TModality
mAcc TModality
mVar FS (AnnF TypeInfo TermF) var
l) ModalTope var -> [ModalTope var] -> [ModalTope var]
forall a. a -> [a] -> [a]
: [ModalTope var]
topes') [[ModalTope var]] -> [[ModalTope var]] -> [[ModalTope var]]
forall a. Semigroup a => a -> a -> a
<> [ModalTope var] -> [[ModalTope var]]
forall var. Eq var => [ModalTope var] -> [[ModalTope var]]
simplifyLHSwithDisjunctions ((TModality
-> TModality -> FS (AnnF TypeInfo TermF) var -> ModalTope var
forall var. TModality -> TModality -> TermT var -> ModalTope var
ModalTope TModality
mAcc TModality
mVar FS (AnnF TypeInfo TermF) var
r) ModalTope var -> [ModalTope var] -> [ModalTope var]
forall a. a -> [a] -> [a]
: [ModalTope var]
topes')

    (ModalTope TModality
mAcc TModality
mVar (TopeEQT  TypeInfo (FS (AnnF TypeInfo TermF) var)
_ (PairT TypeInfo (FS (AnnF TypeInfo TermF) var)
_ FS (AnnF TypeInfo TermF) var
x FS (AnnF TypeInfo TermF) var
y) (PairT TypeInfo (FS (AnnF TypeInfo TermF) var)
_ FS (AnnF TypeInfo TermF) var
x' FS (AnnF TypeInfo TermF) var
y'))) : [ModalTope var]
topes' ->
      [ModalTope var] -> [[ModalTope var]]
forall var. Eq var => [ModalTope var] -> [[ModalTope var]]
simplifyLHSwithDisjunctions (TModality
-> TModality -> FS (AnnF TypeInfo TermF) var -> ModalTope var
forall var. TModality -> TModality -> TermT var -> ModalTope var
ModalTope TModality
mAcc TModality
mVar (FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var -> FS (AnnF TypeInfo TermF) var
forall var. TermT var -> TermT var -> TermT var
topeEQT FS (AnnF TypeInfo TermF) var
x FS (AnnF TypeInfo TermF) var
x') ModalTope var -> [ModalTope var] -> [ModalTope var]
forall a. a -> [a] -> [a]
: TModality
-> TModality -> FS (AnnF TypeInfo TermF) var -> ModalTope var
forall var. TModality -> TModality -> TermT var -> ModalTope var
ModalTope TModality
mAcc TModality
mVar (FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var -> FS (AnnF TypeInfo TermF) var
forall var. TermT var -> TermT var -> TermT var
topeEQT FS (AnnF TypeInfo TermF) var
y FS (AnnF TypeInfo TermF) var
y') ModalTope var -> [ModalTope var] -> [ModalTope var]
forall a. a -> [a] -> [a]
: [ModalTope var]
topes')
    (ModalTope TModality
mAcc TModality
mVar (TypeModalT TypeInfo (FS (AnnF TypeInfo TermF) var)
_ TModality
md FS (AnnF TypeInfo TermF) var
inTope)) : [ModalTope var]
topes' ->
      [ModalTope var] -> [[ModalTope var]]
forall var. Eq var => [ModalTope var] -> [[ModalTope var]]
simplifyLHSwithDisjunctions ((TModality
-> TModality -> FS (AnnF TypeInfo TermF) var -> ModalTope var
forall var. TModality -> TModality -> TermT var -> ModalTope var
ModalTope TModality
mAcc (TModality -> TModality -> TModality
forall m. ModeTheory m => m -> m -> m
comp TModality
mVar TModality
md) FS (AnnF TypeInfo TermF) var
inTope) ModalTope var -> [ModalTope var] -> [ModalTope var]
forall a. a -> [a] -> [a]
: [ModalTope var]
topes')
    ModalTope var
t : [ModalTope var]
topes' -> ([ModalTope var] -> [ModalTope var])
-> [[ModalTope var]] -> [[ModalTope var]]
forall a b. (a -> b) -> [a] -> [b]
map (ModalTope var
t ModalTope var -> [ModalTope var] -> [ModalTope var]
forall a. a -> [a] -> [a]
:) ([ModalTope var] -> [[ModalTope var]]
forall var. Eq var => [ModalTope var] -> [[ModalTope var]]
simplifyLHSwithDisjunctions [ModalTope var]
topes')

-- | Simplify the context, except disjunctions. See also 'simplifyLHSwithDisjunctions'.
simplifyLHS :: Eq var => [ModalTope var] -> [ModalTope var]
simplifyLHS :: forall var. Eq var => [ModalTope var] -> [ModalTope var]
simplifyLHS [ModalTope var]
topes = [ModalTope var] -> [ModalTope var]
forall a. Eq a => [a] -> [a]
nubTermT ([ModalTope var] -> [ModalTope var])
-> [ModalTope var] -> [ModalTope var]
forall a b. (a -> b) -> a -> b
$
  case [ModalTope var]
topes of
    [] -> []
    (ModalTope TModality
_ TModality
_ TopeTopT{}) : [ModalTope var]
topes' -> [ModalTope var] -> [ModalTope var]
forall var. Eq var => [ModalTope var] -> [ModalTope var]
simplifyLHS [ModalTope var]
topes'
    (ModalTope TModality
_ TModality
_ TopeBottomT{}) : [ModalTope var]
_  -> [FS (AnnF TypeInfo TermF) var -> ModalTope var
forall var. TermT var -> ModalTope var
plainTope FS (AnnF TypeInfo TermF) var
forall var. TermT var
topeBottomT]
    (ModalTope TModality
mAcc TModality
mVar (TopeAndT TypeInfo (FS (AnnF TypeInfo TermF) var)
_ FS (AnnF TypeInfo TermF) var
l FS (AnnF TypeInfo TermF) var
r)) : [ModalTope var]
topes' -> [ModalTope var] -> [ModalTope var]
forall var. Eq var => [ModalTope var] -> [ModalTope var]
simplifyLHS (TModality
-> TModality -> FS (AnnF TypeInfo TermF) var -> ModalTope var
forall var. TModality -> TModality -> TermT var -> ModalTope var
ModalTope TModality
mAcc TModality
mVar FS (AnnF TypeInfo TermF) var
l ModalTope var -> [ModalTope var] -> [ModalTope var]
forall a. a -> [a] -> [a]
: TModality
-> TModality -> FS (AnnF TypeInfo TermF) var -> ModalTope var
forall var. TModality -> TModality -> TermT var -> ModalTope var
ModalTope TModality
mAcc TModality
mVar FS (AnnF TypeInfo TermF) var
r ModalTope var -> [ModalTope var] -> [ModalTope var]
forall a. a -> [a] -> [a]
: [ModalTope var]
topes')

    -- NOTE: it is inefficient to expand disjunctions immediately
    -- (ModalTope mAcc mVar (TopeOrT _ l r)) : topes' -> simplifyLHS (ModalTope mAcc mVar l : topes') <> simplifyLHS (ModalTope mAcc mVar r : topes')

    (ModalTope TModality
mAcc TModality
mVar (TopeEQT TypeInfo (FS (AnnF TypeInfo TermF) var)
_ (PairT TypeInfo (FS (AnnF TypeInfo TermF) var)
_ FS (AnnF TypeInfo TermF) var
x FS (AnnF TypeInfo TermF) var
y) (PairT TypeInfo (FS (AnnF TypeInfo TermF) var)
_ FS (AnnF TypeInfo TermF) var
x' FS (AnnF TypeInfo TermF) var
y'))) : [ModalTope var]
topes' ->
      [ModalTope var] -> [ModalTope var]
forall var. Eq var => [ModalTope var] -> [ModalTope var]
simplifyLHS (TModality
-> TModality -> FS (AnnF TypeInfo TermF) var -> ModalTope var
forall var. TModality -> TModality -> TermT var -> ModalTope var
ModalTope TModality
mAcc TModality
mVar (FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var -> FS (AnnF TypeInfo TermF) var
forall var. TermT var -> TermT var -> TermT var
topeEQT FS (AnnF TypeInfo TermF) var
x FS (AnnF TypeInfo TermF) var
x') ModalTope var -> [ModalTope var] -> [ModalTope var]
forall a. a -> [a] -> [a]
: TModality
-> TModality -> FS (AnnF TypeInfo TermF) var -> ModalTope var
forall var. TModality -> TModality -> TermT var -> ModalTope var
ModalTope TModality
mAcc TModality
mVar (FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var -> FS (AnnF TypeInfo TermF) var
forall var. TermT var -> TermT var -> TermT var
topeEQT FS (AnnF TypeInfo TermF) var
y FS (AnnF TypeInfo TermF) var
y') ModalTope var -> [ModalTope var] -> [ModalTope var]
forall a. a -> [a] -> [a]
: [ModalTope var]
topes')
    (ModalTope TModality
mAcc TModality
mVar (TypeModalT TypeInfo (FS (AnnF TypeInfo TermF) var)
_ TModality
md FS (AnnF TypeInfo TermF) var
inTope)) : [ModalTope var]
topes' ->
      [ModalTope var] -> [ModalTope var]
forall var. Eq var => [ModalTope var] -> [ModalTope var]
simplifyLHS (TModality
-> TModality -> FS (AnnF TypeInfo TermF) var -> ModalTope var
forall var. TModality -> TModality -> TermT var -> ModalTope var
ModalTope TModality
mAcc (TModality -> TModality -> TModality
forall m. ModeTheory m => m -> m -> m
comp TModality
mVar TModality
md) FS (AnnF TypeInfo TermF) var
inTope ModalTope var -> [ModalTope var] -> [ModalTope var]
forall a. a -> [a] -> [a]
: [ModalTope var]
topes')
    ModalTope var
t : [ModalTope var]
topes' -> ModalTope var
t ModalTope var -> [ModalTope var] -> [ModalTope var]
forall a. a -> [a] -> [a]
: [ModalTope var] -> [ModalTope var]
forall var. Eq var => [ModalTope var] -> [ModalTope var]
simplifyLHS [ModalTope var]
topes'

solveRHSM :: Eq var => [ModalTope var] -> TermT var -> TypeCheck var Bool
solveRHSM :: forall var.
Eq var =>
[ModalTope var] -> TermT var -> TypeCheck var Bool
solveRHSM [ModalTope var]
modalTopes TermT var
goal =
  let topes :: [TermT var]
topes = [ModalTope var] -> [TermT var]
forall var. [ModalTope var] -> [TermT var]
accessibleTopes [ModalTope var]
modalTopes
  in case TermT var
goal of
    TermT var
_ | TermT var
forall var. TermT var
topeBottomT TermT var -> [TermT var] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TermT var]
topes -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    TopeTopT{}     -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    TypeModalT TypeInfo (TermT var)
_ty TModality
md TermT var
inTope -> do
      let shifted :: [ModalTope var]
shifted = TModality -> [ModalTope var] -> [ModalTope var]
forall var. TModality -> [ModalTope var] -> [ModalTope var]
applyModalityToTopes TModality
md [ModalTope var]
modalTopes
          resaturated :: [ModalTope var]
resaturated = [TermT var] -> [ModalTope var] -> [ModalTope var]
forall var.
Eq var =>
[TermT var] -> [ModalTope var] -> [ModalTope var]
saturateTopes [] [ModalTope var]
shifted
      resaturatedInv <- [ModalTope var] -> TypeCheck var [ModalTope var]
forall var.
Eq var =>
[ModalTope var] -> TypeCheck var [ModalTope var]
saturateInv [ModalTope var]
resaturated
      solveRHSM resaturatedInv inTope
    TopeEQT  TypeInfo (TermT var)
_ty (PairT TypeInfo (TermT var)
_ty1 TermT var
x TermT var
y) (PairT TypeInfo (TermT var)
_ty2 TermT var
x' TermT var
y') ->
      [ModalTope var] -> TermT var -> TypeCheck var Bool
forall var.
Eq var =>
[ModalTope var] -> TermT var -> TypeCheck var Bool
solveRHSM [ModalTope var]
modalTopes (TermT var -> TypeCheck var Bool)
-> TermT var -> TypeCheck var Bool
forall a b. (a -> b) -> a -> b
$ TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeAndT
        (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
x TermT var
x')
        (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
y TermT var
y')
    TopeEQT  TypeInfo (TermT var)
_ty (PairT TypeInfo{ infoType :: forall term. TypeInfo term -> term
infoType = CubeProductT TypeInfo (TermT var)
_ TermT var
cubeI TermT var
cubeJ } TermT var
x TermT var
y) TermT var
r ->
      [ModalTope var] -> TermT var -> TypeCheck var Bool
forall var.
Eq var =>
[ModalTope var] -> TermT var -> TypeCheck var Bool
solveRHSM [ModalTope var]
modalTopes (TermT var -> TypeCheck var Bool)
-> TermT var -> TypeCheck var Bool
forall a b. (a -> b) -> a -> b
$ TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeAndT
        (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
x (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
firstT TermT var
cubeI TermT var
r))
        (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
y (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
secondT TermT var
cubeJ TermT var
r))
    TopeEQT  TypeInfo (TermT var)
_ty TermT var
l (PairT TypeInfo{ infoType :: forall term. TypeInfo term -> term
infoType = CubeProductT TypeInfo (TermT var)
_ TermT var
cubeI TermT var
cubeJ } TermT var
x TermT var
y) ->
      [ModalTope var] -> TermT var -> TypeCheck var Bool
forall var.
Eq var =>
[ModalTope var] -> TermT var -> TypeCheck var Bool
solveRHSM [ModalTope var]
modalTopes (TermT var -> TypeCheck var Bool)
-> TermT var -> TypeCheck var Bool
forall a b. (a -> b) -> a -> b
$ TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeAndT
        (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
firstT TermT var
cubeI TermT var
l) TermT var
x)
        (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
secondT TermT var
cubeJ TermT var
l) TermT var
y)
    TopeEQT  TypeInfo (TermT var)
_ty TermT var
l TermT var
r
      | [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or
          [ TermT var
l TermT var -> TermT var -> Bool
forall a. Eq a => a -> a -> Bool
== TermT var
r
          , TermT var
goal TermT var -> [TermT var] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TermT var]
topes
          , TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
r TermT var
l TermT var -> [TermT var] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TermT var]
topes
          ] -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    TopeEQT  TypeInfo (TermT var)
_ty TermT var
l TermT var
r -> do
      lType <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
l
      rType <- typeOf r
      return $ case (lType, rType) of
        (CubeUnitT{}, CubeUnitT{}) -> Bool
True
        (TermT var, TermT var)
_                          -> Bool
False
    TopeLEQT TypeInfo (TermT var)
_ty TermT var
l TermT var
r
      | TermT var
l TermT var -> TermT var -> Bool
forall a. Eq a => a -> a -> Bool
== TermT var
r -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      | [TermT var] -> TermT var -> Bool
forall var. Eq var => [TermT var] -> TermT var -> Bool
solveRHS [TermT var]
topes (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
l TermT var
r) -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      | [TermT var] -> TermT var -> Bool
forall var. Eq var => [TermT var] -> TermT var -> Bool
solveRHS [TermT var]
topes (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
l TermT var
forall var. TermT var
cube2_0T) -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      | [TermT var] -> TermT var -> Bool
forall var. Eq var => [TermT var] -> TermT var -> Bool
solveRHS [TermT var]
topes (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
r TermT var
forall var. TermT var
cube2_1T) -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    TopeAndT TypeInfo (TermT var)
_ TermT var
l TermT var
r -> Bool -> Bool -> Bool
(&&)
      (Bool -> Bool -> Bool)
-> TypeCheck var Bool
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModalTope var] -> TermT var -> TypeCheck var Bool
forall var.
Eq var =>
[ModalTope var] -> TermT var -> TypeCheck var Bool
solveRHSM [ModalTope var]
modalTopes TermT var
l
      ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (Bool -> Bool)
-> TypeCheck var Bool -> TypeCheck var Bool
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (a -> b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [ModalTope var] -> TermT var -> TypeCheck var Bool
forall var.
Eq var =>
[ModalTope var] -> TermT var -> TypeCheck var Bool
solveRHSM [ModalTope var]
modalTopes TermT var
r
    TermT var
_ | TermT var
goal TermT var -> [TermT var] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TermT var]
topes -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    TopeInvT{} -> do
      goal' <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
goal
      case goal' of
        TopeInvT{} -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        TermT var
_          -> [ModalTope var] -> TermT var -> TypeCheck var Bool
forall var.
Eq var =>
[ModalTope var] -> TermT var -> TypeCheck var Bool
solveRHSM [ModalTope var]
modalTopes TermT var
goal'
    TopeUninvT{} -> do
      goal' <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
goal
      case goal' of
        TopeUninvT{} -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        TermT var
_            -> [ModalTope var] -> TermT var -> TypeCheck var Bool
forall var.
Eq var =>
[ModalTope var] -> TermT var -> TypeCheck var Bool
solveRHSM [ModalTope var]
modalTopes TermT var
goal'
    TopeOrT  TypeInfo (TermT var)
_ TermT var
l TermT var
r -> do
      l' <- [ModalTope var] -> TermT var -> TypeCheck var Bool
forall var.
Eq var =>
[ModalTope var] -> TermT var -> TypeCheck var Bool
solveRHSM [ModalTope var]
modalTopes TermT var
l
      r' <- solveRHSM modalTopes r
      if (l' || r')
        then return True
        else do
          lems <- generateTopesForPointsM (allTopePoints goal)
          let lems' = [ TermT var
lem | lem :: TermT var
lem@(TopeOrT TypeInfo (TermT var)
_ TermT var
t1 TermT var
t2) <- [TermT var]
lems, (TermT var -> Bool) -> [TermT var] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TermT var -> [TermT var] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [TermT var]
topes) [TermT var
t1, TermT var
t2] ]
              (accessible, hidden) = partitionAccessible modalTopes
              withTope TermT var
t = [ModalTope var]
hidden [ModalTope var] -> [ModalTope var] -> [ModalTope var]
forall a. [a] -> [a] -> [a]
++ [TermT var] -> [ModalTope var] -> [ModalTope var]
forall var.
Eq var =>
[TermT var] -> [ModalTope var] -> [ModalTope var]
saturateTopes [] (TermT var -> ModalTope var
forall var. TermT var -> ModalTope var
plainTope TermT var
t ModalTope var -> [ModalTope var] -> [ModalTope var]
forall a. a -> [a] -> [a]
: [ModalTope var]
accessible)

          case lems' of
            TopeOrT TypeInfo (TermT var)
_ TermT var
t1 TermT var
t2 : [TermT var]
_ -> do
              l'' <- [ModalTope var] -> TermT var -> TypeCheck var Bool
forall var.
Eq var =>
[ModalTope var] -> TermT var -> TypeCheck var Bool
solveRHSM (TermT var -> [ModalTope var]
withTope TermT var
t1) TermT var
goal
              r'' <- solveRHSM (withTope t2) goal
              return (l'' && r'')
            [TermT var]
_ -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    TermT var
_ -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

solveRHS :: Eq var => [TermT var] -> TermT var -> Bool
solveRHS :: forall var. Eq var => [TermT var] -> TermT var -> Bool
solveRHS [TermT var]
topes TermT var
tope =
  case TermT var
tope of
    TermT var
_ | TermT var
forall var. TermT var
topeBottomT TermT var -> [TermT var] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TermT var]
topes -> Bool
True
    TopeTopT{}     -> Bool
True
    TopeEQT  TypeInfo (TermT var)
_ty (PairT TypeInfo (TermT var)
_ty1 TermT var
x TermT var
y) (PairT TypeInfo (TermT var)
_ty2 TermT var
x' TermT var
y')
      | [TermT var] -> TermT var -> Bool
forall var. Eq var => [TermT var] -> TermT var -> Bool
solveRHS [TermT var]
topes (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
x TermT var
x') Bool -> Bool -> Bool
&& [TermT var] -> TermT var -> Bool
forall var. Eq var => [TermT var] -> TermT var -> Bool
solveRHS [TermT var]
topes (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
y TermT var
y') -> Bool
True
    TopeEQT  TypeInfo (TermT var)
_ty (PairT TypeInfo{ infoType :: forall term. TypeInfo term -> term
infoType = CubeProductT TypeInfo (TermT var)
_ TermT var
cubeI TermT var
cubeJ } TermT var
x TermT var
y) TermT var
r
      | [TermT var] -> TermT var -> Bool
forall var. Eq var => [TermT var] -> TermT var -> Bool
solveRHS [TermT var]
topes (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
x (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
firstT TermT var
cubeI TermT var
r)) Bool -> Bool -> Bool
&& [TermT var] -> TermT var -> Bool
forall var. Eq var => [TermT var] -> TermT var -> Bool
solveRHS [TermT var]
topes (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
y (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
secondT TermT var
cubeJ TermT var
r)) -> Bool
True
    TopeEQT  TypeInfo (TermT var)
_ty TermT var
l (PairT TypeInfo{ infoType :: forall term. TypeInfo term -> term
infoType = CubeProductT TypeInfo (TermT var)
_ TermT var
cubeI TermT var
cubeJ } TermT var
x TermT var
y)
      | [TermT var] -> TermT var -> Bool
forall var. Eq var => [TermT var] -> TermT var -> Bool
solveRHS [TermT var]
topes (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
firstT TermT var
cubeI TermT var
l) TermT var
x) Bool -> Bool -> Bool
&& [TermT var] -> TermT var -> Bool
forall var. Eq var => [TermT var] -> TermT var -> Bool
solveRHS [TermT var]
topes (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
secondT TermT var
cubeJ TermT var
l) TermT var
y) -> Bool
True
    TopeEQT  TypeInfo (TermT var)
_ty TermT var
l TermT var
r -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or
      [ TermT var
l TermT var -> TermT var -> Bool
forall a. Eq a => a -> a -> Bool
== TermT var
r
      , TermT var
tope TermT var -> [TermT var] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TermT var]
topes
      , TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
r TermT var
l TermT var -> [TermT var] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TermT var]
topes
      ]
    TopeLEQT TypeInfo (TermT var)
_ty TermT var
l TermT var
r
      | TermT var
l TermT var -> TermT var -> Bool
forall a. Eq a => a -> a -> Bool
== TermT var
r -> Bool
True
      | [TermT var] -> TermT var -> Bool
forall var. Eq var => [TermT var] -> TermT var -> Bool
solveRHS [TermT var]
topes (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
l TermT var
r) -> Bool
True
      | [TermT var] -> TermT var -> Bool
forall var. Eq var => [TermT var] -> TermT var -> Bool
solveRHS [TermT var]
topes (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
l TermT var
forall var. TermT var
cube2_0T) -> Bool
True
      | [TermT var] -> TermT var -> Bool
forall var. Eq var => [TermT var] -> TermT var -> Bool
solveRHS [TermT var]
topes (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
r TermT var
forall var. TermT var
cube2_1T) -> Bool
True
    -- TopeBottomT{}  -> solveLHS topes tope
    TopeAndT TypeInfo (TermT var)
_ TermT var
l TermT var
r -> [TermT var] -> TermT var -> Bool
forall var. Eq var => [TermT var] -> TermT var -> Bool
solveRHS [TermT var]
topes TermT var
l Bool -> Bool -> Bool
&& [TermT var] -> TermT var -> Bool
forall var. Eq var => [TermT var] -> TermT var -> Bool
solveRHS [TermT var]
topes TermT var
r
    TopeOrT  TypeInfo (TermT var)
_ TermT var
l TermT var
r -> [TermT var] -> TermT var -> Bool
forall var. Eq var => [TermT var] -> TermT var -> Bool
solveRHS [TermT var]
topes TermT var
l Bool -> Bool -> Bool
|| [TermT var] -> TermT var -> Bool
forall var. Eq var => [TermT var] -> TermT var -> Bool
solveRHS [TermT var]
topes TermT var
r
    TermT var
_ -> TermT var
tope TermT var -> [TermT var] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TermT var]
topes

checkTope :: Eq var => TermT var -> TypeCheck var Bool
checkTope :: forall var. Eq var => TermT var -> TypeCheck var Bool
checkTope TermT var
tope = do
  ctxTopes <- (Context var -> [TermT var])
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [TermT var]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context var -> [TermT var]
forall var. Context var -> [TermT var]
availableTopes
  performing (ActionContextEntails ctxTopes tope) $ do
    topes' <- asks localTopesNF
    tope' <- nfTope tope
    topes' `entailM` tope'

checkTopeEntails :: Eq var => TermT var -> TypeCheck var Bool
checkTopeEntails :: forall var. Eq var => TermT var -> TypeCheck var Bool
checkTopeEntails TermT var
tope = do
  ctxTopes <- (Context var -> [TermT var])
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [TermT var]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context var -> [TermT var]
forall var. Context var -> [TermT var]
availableTopes
  performing (ActionContextEntailedBy ctxTopes tope) $ do
    contextTopes <- asks availableTopesNF
    restrictionTope <- nfTope tope
    let contextTopesRHS = (TermT var -> TermT var -> TermT var)
-> TermT var -> [TermT var] -> TermT var
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeAndT TermT var
forall var. TermT var
topeTopT [TermT var]
contextTopes
    [plainTope restrictionTope] `entailM` contextTopesRHS

checkEntails :: Eq var => TermT var -> TermT var -> TypeCheck var Bool
checkEntails :: forall var. Eq var => TermT var -> TermT var -> TypeCheck var Bool
checkEntails TermT var
l TermT var
r = do  -- FIXME: add action
  l' <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
l
  r' <- nfTope r
  [plainTope l'] `entailM` r'

contextEntails :: Eq var => TermT var -> TypeCheck var ()
contextEntails :: forall var. Eq var => TermT var -> TypeCheck var ()
contextEntails TermT var
tope = do
  ctxTopes <- (Context var -> [TermT var])
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [TermT var]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context var -> [TermT var]
forall var. Context var -> [TermT var]
availableTopes
  performing (ActionContextEntails ctxTopes tope) $ do
    topeIsEntailed <- checkTope tope
    topes' <- asks availableTopesNF
    -- When a hole is used in a cube/tope position (e.g. as the argument of a
    -- shape-restricted function), the tope being checked mentions the hole and
    -- cannot be decided. Treat it as satisfied (defer) rather than failing.
    unless (topeIsEntailed || containsHole tope) $
      issueTypeError $ TypeErrorTopeNotSatisfied topes' tope

topesEquiv :: Eq var => TermT var -> TermT var -> TypeCheck var Bool
topesEquiv :: forall var. Eq var => TermT var -> TermT var -> TypeCheck var Bool
topesEquiv TermT var
expected TermT var
actual = Action var -> TypeCheck var Bool -> TypeCheck var Bool
forall var a.
Eq var =>
Action var -> TypeCheck var a -> TypeCheck var a
performing (TermT var -> TermT var -> Action var
forall var. TermT var -> TermT var -> Action var
ActionUnifyTerms TermT var
expected TermT var
actual) (TypeCheck var Bool -> TypeCheck var Bool)
-> TypeCheck var Bool -> TypeCheck var Bool
forall a b. (a -> b) -> a -> b
$ do
  expected' <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
expected
  actual' <- nfT actual
  (&&)
    <$> [plainTope expected'] `entailM` actual'
    <*> [plainTope actual'] `entailM` expected'

-- | Check that the local tope context is included in (entails) the union of
-- the given topes. This is the COVERAGE obligation of @recOR@: every point of the
-- context must be covered by some branch guard.
--
-- Note that only coverage is required, not equivalence: branch guards may overhang
-- the context (e.g. when splitting with an already-defined shape), so we do not
-- require @OR(guards) |- context@.
contextEntailsUnion :: Eq var => [TermT var] -> TypeCheck var ()
contextEntailsUnion :: forall var. Eq var => [TermT var] -> TypeCheck var ()
contextEntailsUnion [TermT var]
topes = do
  ctxTopes <- (Context var -> [TermT var])
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [TermT var]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context var -> [TermT var]
forall var. Context var -> [TermT var]
availableTopes
  performing (ActionContextEntailsUnion ctxTopes topes) $ do
    contextTopes <- asks localTopesNF
    topesNF <- mapM nfTope topes
    let unionRHS = (TermT var -> TermT var -> TermT var)
-> TermT var -> [TermT var] -> TermT var
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeOrT TermT var
forall var. TermT var
topeBottomT [TermT var]
topesNF
    contextTopes `entailM` unionRHS >>= \case
      -- a guard mentioning an (unfilled) hole can't be decided; defer coverage
      Bool
False | Bool -> Bool
not ((TermT var -> Bool) -> [TermT var] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TermT var -> Bool
forall var. TermT var -> Bool
containsHole [TermT var]
topesNF) ->
        TypeError var -> TypeCheck var ()
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var -> TypeCheck var ())
-> TypeError var -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$ [TermT var] -> TermT var -> TypeError var
forall var. [TermT var] -> TermT var -> TypeError var
TypeErrorTopeNotSatisfied ([ModalTope var] -> [TermT var]
forall var. [ModalTope var] -> [TermT var]
accessibleTopes [ModalTope var]
contextTopes) TermT var
unionRHS
      Bool
_ -> () -> TypeCheck var ()
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Diagnose a recOR branch guard or restriction face against the local tope
-- context. There are three cases, by how the tope relates to the context:
--
--   * DISJOINT — the tope and a consistent context have empty overlap (their
--     conjunction is ⊥). The face/branch is then vacuous everywhere, so this is a
--     hard error.
--   * OVERHANG — the tope is not entailed by the context but still overlaps it.
--     This is allowed and often intentional (e.g. splitting or restricting with an
--     already-defined shape, whose faces live on the whole cube rather than being
--     relativised to the context), so we only emit a non-fatal hint. The hint is
--     gated at 'Normal' verbosity, hence silent under 'Silent' (e.g. in tests).
--   * CONTAINED — the tope entails the context: nothing to report.
checkTopeAgainstContext :: Eq var => String -> TermT var -> TypeCheck var ()
checkTopeAgainstContext :: forall var. Eq var => String -> TermT var -> TypeCheck var ()
checkTopeAgainstContext String
what TermT var
tope = do
  -- a contradictory context is handled elsewhere (recBOT)
  ctxEntailsBottom <- TypeCheck var Bool
forall var. Eq var => TypeCheck var Bool
contextEntailsBottom
  unless ctxEntailsBottom $ do
    contextTopes <- asks localTopesNF
    let ctxTopes = (TermT var -> Bool) -> [TermT var] -> [TermT var]
forall a. (a -> Bool) -> [a] -> [a]
filter (TermT var -> TermT var -> Bool
forall a. Eq a => a -> a -> Bool
/= TermT var
forall var. TermT var
topeTopT) ([ModalTope var] -> [TermT var]
forall var. [ModalTope var] -> [TermT var]
accessibleTopes [ModalTope var]
contextTopes)
    disjoint <- (plainTope tope : contextTopes) `entailM` topeBottomT
    -- a face/guard mentioning an (unfilled) hole can't be decided; defer
    if disjoint && not (containsHole tope)
      then issueTypeError (TypeErrorTopeContextDisjoint tope ctxTopes)
      else do
        entailed <- checkTopeEntails tope     -- tope |- AND(accessible context)
        unless entailed $ do
          topeStr <- ppTermInContext tope
          ctxStrs <- mapM ppTermInContext ctxTopes
          traceTypeCheck Normal
            (intercalate "\n" $
              [ "Warning: " <> what <> " overhangs the local tope context"
              , "  " <> topeStr
              , "is not entailed by the local context (normalised)"
              ] <> map ("  " <>) ctxStrs)
            (return ())

switchVariance :: TypeCheck var a -> TypeCheck var a
switchVariance :: forall var a. TypeCheck var a -> TypeCheck var a
switchVariance = (Context var -> Context var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall a.
(Context var -> Context var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((Context var -> Context var)
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      a
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      a)
-> (Context var -> Context var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall a b. (a -> b) -> a -> b
$ \Context{Bool
[[ModalTope var]]
[VarIdent]
[ModalTope var]
[ScopeInfo var]
[Action var]
Maybe Bool
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: forall var. Context var -> Maybe LocationInfo
hintLemmas :: forall var. Context var -> [VarIdent]
deferHoleMismatches :: forall var. Context var -> Bool
holesAreErrors :: forall var. Context var -> Bool
renderHideTerm :: forall var. Context var -> Bool
renderBackend :: forall var. Context var -> Maybe RenderBackend
covariance :: forall var. Context var -> Covariance
verbosity :: forall var. Context var -> Verbosity
currentCommand :: forall var. Context var -> Maybe Command
actionStack :: forall var. Context var -> [Action var]
localTopesEntailBottom :: forall var. Context var -> Maybe Bool
localTopesNFUnion :: forall var. Context var -> [[ModalTope var]]
localTopesNF :: forall var. Context var -> [ModalTope var]
localTopes :: forall var. Context var -> [ModalTope var]
localScopes :: forall var. Context var -> [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopes :: [ModalTope var]
localTopesNF :: [ModalTope var]
localTopesNFUnion :: [[ModalTope var]]
localTopesEntailBottom :: Maybe Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
renderHideTerm :: Bool
holesAreErrors :: Bool
deferHoleMismatches :: Bool
hintLemmas :: [VarIdent]
..} -> Context
  { covariance :: Covariance
covariance = Covariance -> Covariance
switch Covariance
covariance, Bool
[[ModalTope var]]
[VarIdent]
[ModalTope var]
[ScopeInfo var]
[Action var]
Maybe Bool
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Verbosity
location :: Maybe LocationInfo
hintLemmas :: [VarIdent]
deferHoleMismatches :: Bool
holesAreErrors :: Bool
renderHideTerm :: Bool
renderBackend :: Maybe RenderBackend
verbosity :: Verbosity
currentCommand :: Maybe Command
actionStack :: [Action var]
localTopesEntailBottom :: Maybe Bool
localTopesNFUnion :: [[ModalTope var]]
localTopesNF :: [ModalTope var]
localTopes :: [ModalTope var]
localScopes :: [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopes :: [ModalTope var]
localTopesNF :: [ModalTope var]
localTopesNFUnion :: [[ModalTope var]]
localTopesEntailBottom :: Maybe Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
renderBackend :: Maybe RenderBackend
renderHideTerm :: Bool
holesAreErrors :: Bool
deferHoleMismatches :: Bool
hintLemmas :: [VarIdent]
.. }
    where
      switch :: Covariance -> Covariance
switch Covariance
Covariant     = Covariance
Contravariant
      switch Covariance
Contravariant = Covariance
Covariant
      switch Covariance
Invariant     = Covariance
Invariant

setVariance :: Covariance -> TypeCheck var a -> TypeCheck var a
setVariance :: forall var a. Covariance -> TypeCheck var a -> TypeCheck var a
setVariance Covariance
variance = (Context var -> Context var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall a.
(Context var -> Context var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((Context var -> Context var)
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      a
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      a)
-> (Context var -> Context var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall a b. (a -> b) -> a -> b
$ \Context{Bool
[[ModalTope var]]
[VarIdent]
[ModalTope var]
[ScopeInfo var]
[Action var]
Maybe Bool
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: forall var. Context var -> Maybe LocationInfo
hintLemmas :: forall var. Context var -> [VarIdent]
deferHoleMismatches :: forall var. Context var -> Bool
holesAreErrors :: forall var. Context var -> Bool
renderHideTerm :: forall var. Context var -> Bool
renderBackend :: forall var. Context var -> Maybe RenderBackend
covariance :: forall var. Context var -> Covariance
verbosity :: forall var. Context var -> Verbosity
currentCommand :: forall var. Context var -> Maybe Command
actionStack :: forall var. Context var -> [Action var]
localTopesEntailBottom :: forall var. Context var -> Maybe Bool
localTopesNFUnion :: forall var. Context var -> [[ModalTope var]]
localTopesNF :: forall var. Context var -> [ModalTope var]
localTopes :: forall var. Context var -> [ModalTope var]
localScopes :: forall var. Context var -> [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopes :: [ModalTope var]
localTopesNF :: [ModalTope var]
localTopesNFUnion :: [[ModalTope var]]
localTopesEntailBottom :: Maybe Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
renderHideTerm :: Bool
holesAreErrors :: Bool
deferHoleMismatches :: Bool
hintLemmas :: [VarIdent]
..} -> Context
  { covariance :: Covariance
covariance = Covariance
variance, Bool
[[ModalTope var]]
[VarIdent]
[ModalTope var]
[ScopeInfo var]
[Action var]
Maybe Bool
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Verbosity
location :: Maybe LocationInfo
hintLemmas :: [VarIdent]
deferHoleMismatches :: Bool
holesAreErrors :: Bool
renderHideTerm :: Bool
renderBackend :: Maybe RenderBackend
verbosity :: Verbosity
currentCommand :: Maybe Command
actionStack :: [Action var]
localTopesEntailBottom :: Maybe Bool
localTopesNFUnion :: [[ModalTope var]]
localTopesNF :: [ModalTope var]
localTopes :: [ModalTope var]
localScopes :: [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopes :: [ModalTope var]
localTopesNF :: [ModalTope var]
localTopesNFUnion :: [[ModalTope var]]
localTopesEntailBottom :: Maybe Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
renderBackend :: Maybe RenderBackend
renderHideTerm :: Bool
holesAreErrors :: Bool
deferHoleMismatches :: Bool
hintLemmas :: [VarIdent]
.. }

enterScopeContext :: Binder -> TModality -> TermT var -> Maybe (TermT var) -> Context var -> Context (Inc var)
enterScopeContext :: forall var.
Binder
-> TModality
-> TermT var
-> Maybe (TermT var)
-> Context var
-> Context (Inc var)
enterScopeContext Binder
orig TModality
md TermT var
ty Maybe (TermT var)
val Context var
context =
  Inc var
-> VarInfo (Inc var) -> Context (Inc var) -> Context (Inc var)
forall var. var -> VarInfo var -> Context var -> Context var
addVarInCurrentScope Inc var
forall var. Inc var
Z VarInfo
    { varType :: TermT (Inc var)
varType   = var -> Inc var
forall var. var -> Inc var
S (var -> Inc var) -> TermT var -> TermT (Inc var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
ty
    , varValue :: Maybe (TermT (Inc var))
varValue  = (TermT var -> TermT (Inc var))
-> Maybe (TermT var) -> Maybe (TermT (Inc var))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (var -> Inc var
forall var. var -> Inc var
S (var -> Inc var) -> TermT var -> TermT (Inc var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) Maybe (TermT var)
val
    , varOrig :: Binder
varOrig   = Binder
orig
    , varModality :: TModality
varModality = TModality
md
    , modAccum :: TModality
modAccum = TModality
Id
    , varIsAssumption :: Bool
varIsAssumption = Bool
False
    , varIsTopLevel :: Bool
varIsTopLevel = Bool
False
    , varDeclaredAssumptions :: [Inc var]
varDeclaredAssumptions = []
    , varLocation :: Maybe LocationInfo
varLocation = Context var -> Maybe LocationInfo
forall var. Context var -> Maybe LocationInfo
location Context var
context
    }
    (var -> Inc var
forall var. var -> Inc var
S (var -> Inc var) -> Context var -> Context (Inc var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context var
context)

enterScopeMaybe :: Binder -> TModality -> TermT var -> Maybe (TermT var) -> TypeCheck (Inc var) b -> TypeCheck var b
enterScopeMaybe :: forall var b.
Binder
-> TModality
-> TermT var
-> Maybe (TermT var)
-> TypeCheck (Inc var) b
-> TypeCheck var b
enterScopeMaybe Binder
orig TModality
md TermT var
ty Maybe (TermT var)
mval TypeCheck (Inc var) b
action = do
  newContext <- (Context var -> Context (Inc var))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Context (Inc var))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Binder
-> TModality
-> TermT var
-> Maybe (TermT var)
-> Context var
-> Context (Inc var)
forall var.
Binder
-> TModality
-> TermT var
-> Maybe (TermT var)
-> Context var
-> Context (Inc var)
enterScopeContext Binder
orig TModality
md TermT var
ty Maybe (TermT var)
mval)
  closeScope orig (runReaderT action newContext)

enterScope :: Binder -> TModality -> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope :: forall var b.
Binder
-> TModality
-> TermT var
-> TypeCheck (Inc var) b
-> TypeCheck var b
enterScope Binder
orig TModality
md TermT var
ty = Binder
-> TModality
-> TermT var
-> Maybe (TermT var)
-> TypeCheck (Inc var) b
-> TypeCheck var b
forall var b.
Binder
-> TModality
-> TermT var
-> Maybe (TermT var)
-> TypeCheck (Inc var) b
-> TypeCheck var b
enterScopeMaybe Binder
orig TModality
md TermT var
ty Maybe (TermT var)
forall a. Maybe a
Nothing

enterScopeWithBind :: Binder -> TModality -> TermT var -> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScopeWithBind :: forall var b.
Binder
-> TModality
-> TermT var
-> TermT var
-> TypeCheck (Inc var) b
-> TypeCheck var b
enterScopeWithBind Binder
orig TModality
md TermT var
ty TermT var
val = Binder
-> TModality
-> TermT var
-> Maybe (TermT var)
-> TypeCheck (Inc var) b
-> TypeCheck var b
forall var b.
Binder
-> TModality
-> TermT var
-> Maybe (TermT var)
-> TypeCheck (Inc var) b
-> TypeCheck var b
enterScopeMaybe Binder
orig TModality
md TermT var
ty (TermT var -> Maybe (TermT var)
forall a. a -> Maybe a
Just TermT var
val)

-- | Run a sub-scope computation and lift it back to the enclosing scope: close
-- the error channel one binder with 'ScopedTypeError' (as before), and re-emit
-- the holes it recorded. 'HoleInfo' is already rendered to 'VarIdent' names, so
-- no De Bruijn re-indexing is needed — only a plain re-'tell'. On a thrown
-- error the sub-scope's holes are dropped, which is intended: holes only matter
-- on the success path (lenient mode), and strict mode wants the error anyway.
closeScope
  :: Binder
  -> WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))) b
  -> TypeCheck var b
closeScope :: forall var b.
Binder
-> WriterT
     [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))) b
-> TypeCheck var b
closeScope Binder
orig WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))) b
inner = do
  (b, holes) <- WriterT
  [HoleInfo] (Except (TypeErrorInScopedContext var)) (b, [HoleInfo])
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (b, [HoleInfo])
forall (m :: * -> *) a. Monad m => m a -> ReaderT (Context var) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT
   [HoleInfo] (Except (TypeErrorInScopedContext var)) (b, [HoleInfo])
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      (b, [HoleInfo]))
-> (ExceptT
      (TypeErrorInScopedContext (Inc var)) Identity (b, [HoleInfo])
    -> WriterT
         [HoleInfo] (Except (TypeErrorInScopedContext var)) (b, [HoleInfo]))
-> ExceptT
     (TypeErrorInScopedContext (Inc var)) Identity (b, [HoleInfo])
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (b, [HoleInfo])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Except (TypeErrorInScopedContext var) (b, [HoleInfo])
-> WriterT
     [HoleInfo] (Except (TypeErrorInScopedContext var)) (b, [HoleInfo])
forall (m :: * -> *) a. Monad m => m a -> WriterT [HoleInfo] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Except (TypeErrorInScopedContext var) (b, [HoleInfo])
 -> WriterT
      [HoleInfo] (Except (TypeErrorInScopedContext var)) (b, [HoleInfo]))
-> (ExceptT
      (TypeErrorInScopedContext (Inc var)) Identity (b, [HoleInfo])
    -> Except (TypeErrorInScopedContext var) (b, [HoleInfo]))
-> ExceptT
     (TypeErrorInScopedContext (Inc var)) Identity (b, [HoleInfo])
-> WriterT
     [HoleInfo] (Except (TypeErrorInScopedContext var)) (b, [HoleInfo])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeErrorInScopedContext (Inc var)
 -> TypeErrorInScopedContext var)
-> ExceptT
     (TypeErrorInScopedContext (Inc var)) Identity (b, [HoleInfo])
-> Except (TypeErrorInScopedContext var) (b, [HoleInfo])
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (Maybe VarIdent
-> TypeErrorInScopedContext (Inc var)
-> TypeErrorInScopedContext var
forall var.
Maybe VarIdent
-> TypeErrorInScopedContext (Inc var)
-> TypeErrorInScopedContext var
ScopedTypeError (Binder -> Maybe VarIdent
binderName Binder
orig)) (ExceptT
   (TypeErrorInScopedContext (Inc var)) Identity (b, [HoleInfo])
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      (b, [HoleInfo]))
-> ExceptT
     (TypeErrorInScopedContext (Inc var)) Identity (b, [HoleInfo])
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (b, [HoleInfo])
forall a b. (a -> b) -> a -> b
$ WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))) b
-> ExceptT
     (TypeErrorInScopedContext (Inc var)) Identity (b, [HoleInfo])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))) b
inner
  lift (tell holes)
  return b

enterModality :: TModality -> TypeCheck var b -> TypeCheck var b
enterModality :: forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
Id TypeCheck var b
action = TypeCheck var b
action
enterModality TModality
md TypeCheck var b
action = do
  newContext <- (Context var -> Context var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Context var)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (TModality -> Context var -> Context var
forall var. TModality -> Context var -> Context var
applyModality TModality
md)
  let newContext' = Context var
newContext { localTopesEntailBottom = Nothing }
  lift $ runReaderT action newContext'

performing :: Eq var => Action var -> TypeCheck var a -> TypeCheck var a
performing :: forall var a.
Eq var =>
Action var -> TypeCheck var a -> TypeCheck var a
performing Action var
action TypeCheck var a
tc = do
  ctx@Context{..} <- ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (Context var)
forall r (m :: * -> *). MonadReader r m => m r
ask
  unless (length actionStack < 1000) $  -- FIXME: which depth is reasonable? factor out into a parameter
    issueTypeError $ TypeErrorOther "maximum depth reached"
  traceTypeCheck Debug (ppSomeAction (varOrigs ctx) (length actionStack) action) $
    local (const Context { actionStack = action : actionStack, .. }) $ tc

stripTypeRestrictions :: TermT var -> TermT var
stripTypeRestrictions :: forall var. TermT var -> TermT var
stripTypeRestrictions (TypeRestrictedT TypeInfo (FS (AnnF TypeInfo TermF) var)
_ty FS (AnnF TypeInfo TermF) var
ty [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
_restriction) = FS (AnnF TypeInfo TermF) var -> FS (AnnF TypeInfo TermF) var
forall var. TermT var -> TermT var
stripTypeRestrictions FS (AnnF TypeInfo TermF) var
ty
stripTypeRestrictions FS (AnnF TypeInfo TermF) var
t = FS (AnnF TypeInfo TermF) var
t

-- | Perform at most one \(\eta\)-expansion at the top-level to assist unification.
etaMatch :: Eq var => Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var (TermT var, TermT var)
-- FIXME: double check the next 3 rules
etaMatch :: forall var.
Eq var =>
Maybe (TermT var)
-> TermT var -> TermT var -> TypeCheck var (TermT var, TermT var)
etaMatch Maybe (TermT var)
_mterm expected :: TermT var
expected@TypeRestrictedT{} actual :: TermT var
actual@TypeRestrictedT{} = (TermT var, TermT var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var, TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT var
expected, TermT var
actual)
etaMatch  Maybe (TermT var)
mterm TermT var
expected (TypeRestrictedT TypeInfo (TermT var)
_ty TermT var
ty [(TermT var, TermT var)]
_rs) = Maybe (TermT var)
-> TermT var
-> TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var, TermT var)
forall var.
Eq var =>
Maybe (TermT var)
-> TermT var -> TermT var -> TypeCheck var (TermT var, TermT var)
etaMatch Maybe (TermT var)
mterm TermT var
expected TermT var
ty
etaMatch (Just TermT var
term) expected :: TermT var
expected@TypeRestrictedT{} TermT var
actual =
  Maybe (TermT var)
-> TermT var
-> TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var, TermT var)
forall var.
Eq var =>
Maybe (TermT var)
-> TermT var -> TermT var -> TypeCheck var (TermT var, TermT var)
etaMatch (TermT var -> Maybe (TermT var)
forall a. a -> Maybe a
Just TermT var
term) TermT var
expected (TermT var -> [(TermT var, TermT var)] -> TermT var
forall var. TermT var -> [(TermT var, TermT var)] -> TermT var
typeRestrictedT TermT var
actual [(TermT var
forall var. TermT var
topeTopT, TermT var
term)])
-- ------------------------------------
-- | Subtyping on interval
etaMatch Maybe (TermT var)
_mterm CubeIT{} Cube2T{} = (TermT var, TermT var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var, TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT var
forall var. TermT var
cubeIT, TermT var
forall var. TermT var
cubeIT)
-- ------------------------------------
etaMatch Maybe (TermT var)
_mterm expected :: TermT var
expected@LambdaT{} actual :: TermT var
actual@LambdaT{} = (TermT var, TermT var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var, TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT var
expected, TermT var
actual)
etaMatch Maybe (TermT var)
_mterm expected :: TermT var
expected@PairT{}   actual :: TermT var
actual@PairT{}   = (TermT var, TermT var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var, TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT var
expected, TermT var
actual)
etaMatch Maybe (TermT var)
_mterm expected :: TermT var
expected@LambdaT{} TermT var
actual = do
  actual' <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
etaExpand TermT var
actual
  pure (expected, actual')
etaMatch Maybe (TermT var)
_mterm TermT var
expected actual :: TermT var
actual@LambdaT{} = do
  expected' <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
etaExpand TermT var
expected
  pure (expected', actual)
etaMatch Maybe (TermT var)
_mterm expected :: TermT var
expected@PairT{} TermT var
actual = do
  actual' <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
etaExpand TermT var
actual
  pure (expected, actual')
etaMatch Maybe (TermT var)
_mterm TermT var
expected actual :: TermT var
actual@PairT{} = do
  expected' <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
etaExpand TermT var
expected
  pure (expected', actual)
etaMatch Maybe (TermT var)
_mterm TermT var
expected TermT var
actual = (TermT var, TermT var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var, TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT var
expected, TermT var
actual)

etaExpand :: Eq var => TermT var -> TypeCheck var (TermT var)
etaExpand :: forall var. Eq var => TermT var -> TypeCheck var (TermT var)
etaExpand term :: TermT var
term@LambdaT{} = TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
term
etaExpand term :: TermT var
term@PairT{} = TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
term
etaExpand TermT var
term = do
  ty <- TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
term
  case stripTypeRestrictions ty of
    TypeFunT TypeInfo (TermT var)
_ty Binder
orig TModality
md TermT var
param Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope Scope (FS (AnnF TypeInfo TermF)) var
ret -> TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT var
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      (TermT var))
-> TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var)
forall a b. (a -> b) -> a -> b
$
      TermT var
-> Binder
-> Maybe
     (TModality, TermT var,
      Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall var.
TermT var
-> Binder
-> Maybe
     (TModality, TermT var,
      Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
lambdaT TermT var
ty Binder
orig ((TModality, TermT var,
 Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> Maybe
     (TModality, TermT var,
      Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
forall a. a -> Maybe a
Just (TModality
md, TermT var
param, Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope))
        (Scope (FS (AnnF TypeInfo TermF)) var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> Scope (FS (AnnF TypeInfo TermF)) var
forall var. TermT var -> TermT var -> TermT var -> TermT var
appT Scope (FS (AnnF TypeInfo TermF)) var
ret (var -> Inc var
forall var. var -> Inc var
S (var -> Inc var)
-> TermT var -> Scope (FS (AnnF TypeInfo TermF)) var
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
term) (Inc var -> Scope (FS (AnnF TypeInfo TermF)) var
forall (t :: * -> * -> *) a. a -> FS t a
Pure Inc var
forall var. Inc var
Z))

    TypeSigmaT TypeInfo (TermT var)
_ty Binder
_orig TModality
_md TermT var
a Scope (FS (AnnF TypeInfo TermF)) var
b -> TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT var
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      (TermT var))
-> TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var)
forall a b. (a -> b) -> a -> b
$
      TermT var -> TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var -> TermT var
pairT TermT var
ty
        (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
firstT TermT var
a TermT var
term)
        (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
secondT (TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
forall var.
TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
substituteT (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
firstT TermT var
a TermT var
term) Scope (FS (AnnF TypeInfo TermF)) var
b) TermT var
term)

    CubeProductT TypeInfo (TermT var)
_ty TermT var
a TermT var
b -> TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT var
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      (TermT var))
-> TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var)
forall a b. (a -> b) -> a -> b
$
      TermT var -> TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var -> TermT var
pairT TermT var
ty
        (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
firstT TermT var
a TermT var
term)
        (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
secondT TermT var
b TermT var
term)

    TermT var
_ -> TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
term

inCubeLayer :: Eq var => TermT var -> TypeCheck var Bool
inCubeLayer :: forall var. Eq var => TermT var -> TypeCheck var Bool
inCubeLayer = \case
  RecBottomT{}    -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  UniverseT{}     -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

  UniverseCubeT{} -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  CubeProductT{}  -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  CubeUnitT{}     -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  CubeUnitStarT{} -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  Cube2T{}        -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  Cube2_0T{}      -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  Cube2_1T{}      -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

  TermT var
t               -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
t TypeCheck var (TermT var)
-> (TermT var -> TypeCheck var Bool) -> TypeCheck var Bool
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TermT var -> TypeCheck var Bool
forall var. Eq var => TermT var -> TypeCheck var Bool
inCubeLayer

inTopeLayer :: Eq var => TermT var -> TypeCheck var Bool
inTopeLayer :: forall var. Eq var => TermT var -> TypeCheck var Bool
inTopeLayer = \case
  RecBottomT{} -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  UniverseT{} -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

  UniverseCubeT{} -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  UniverseTopeT{} -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

  CubeProductT{} -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  CubeUnitT{} -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  CubeUnitStarT{} -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  Cube2T{} -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  Cube2_0T{} -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  Cube2_1T{} -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

  TopeTopT{} -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  TopeBottomT{} -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  TopeAndT{} -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  TopeOrT{} -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  TopeEQT{} -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  TopeLEQT{} -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

  TypeFunT TypeInfo (TermT var)
_ty Binder
orig TModality
md TermT var
param Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
_mtope Scope (FS (AnnF TypeInfo TermF)) var
ret -> do
    Binder
-> TModality
-> TermT var
-> TypeCheck (Inc var) Bool
-> TypeCheck var Bool
forall var b.
Binder
-> TModality
-> TermT var
-> TypeCheck (Inc var) b
-> TypeCheck var b
enterScope Binder
orig TModality
md TermT var
param (TypeCheck (Inc var) Bool -> TypeCheck var Bool)
-> TypeCheck (Inc var) Bool -> TypeCheck var Bool
forall a b. (a -> b) -> a -> b
$ Scope (FS (AnnF TypeInfo TermF)) var -> TypeCheck (Inc var) Bool
forall var. Eq var => TermT var -> TypeCheck var Bool
inTopeLayer Scope (FS (AnnF TypeInfo TermF)) var
ret

  TermT var
t -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOfUncomputed TermT var
t TypeCheck var (TermT var)
-> (TermT var -> TypeCheck var Bool) -> TypeCheck var Bool
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TermT var -> TypeCheck var Bool
forall var. Eq var => TermT var -> TypeCheck var Bool
inTopeLayer

tryRestriction :: Eq var => TermT var -> TypeCheck var (Maybe (TermT var))
tryRestriction :: forall var.
Eq var =>
TermT var -> TypeCheck var (Maybe (TermT var))
tryRestriction = \case
  TypeRestrictedT TypeInfo (TermT var)
_ TermT var
_ [(TermT var, TermT var)]
rs -> do
    let go :: [(TermT var, a)]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe a)
go [] = Maybe a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe a)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
        go ((TermT var
tope, a
term') : [(TermT var, a)]
rs') = do
          TermT var -> TypeCheck var Bool
forall var. Eq var => TermT var -> TypeCheck var Bool
checkTope TermT var
tope TypeCheck var Bool
-> (Bool
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         (Maybe a))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe a)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Bool
True  -> Maybe a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe a)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Maybe a
forall a. a -> Maybe a
Just a
term')
            Bool
False -> [(TermT var, a)]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe a)
go [(TermT var, a)]
rs'
    [(TermT var, TermT var)] -> TypeCheck var (Maybe (TermT var))
forall {var} {a}.
Eq var =>
[(TermT var, a)]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe a)
go [(TermT var, TermT var)]
rs
  TermT var
_ -> Maybe (TermT var) -> TypeCheck var (Maybe (TermT var))
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TermT var)
forall a. Maybe a
Nothing

-- | Memoise a term's WHNF on its top node without reducing the term itself.
--
-- The returned term has the same (unreduced) structure, so free-variable and
-- @uses@ detection see exactly what the user wrote, while a later 'whnfT' is
-- O(1) via the cached 'infoWHNF'. Used when storing a definition's elaborated
-- type and value, where an in-place reduction could otherwise discard or
-- expose a variable occurrence.
memoizeWHNF :: Eq var => TermT var -> TypeCheck var (TermT var)
memoizeWHNF :: forall var. Eq var => TermT var -> TypeCheck var (TermT var)
memoizeWHNF t :: TermT var
t@Pure{} = TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
t
memoizeWHNF t :: TermT var
t@(Free (AnnF TypeInfo (TermT var)
info TermF (Scope (FS (AnnF TypeInfo TermF)) var) (TermT var)
f)) = do
  w <- TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
t
  pure (Free (AnnF info { infoWHNF = Just w } f))

-- | Compute a typed term to its WHNF.
--
-- >>> unsafeTypeCheck' $ whnfT "(\\ (x : Unit) -> x) unit"
-- unit : Unit
whnfT :: Eq var => TermT var -> TypeCheck var (TermT var)
whnfT :: forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT FS (AnnF TypeInfo TermF) var
tt = Action var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var a.
Eq var =>
Action var -> TypeCheck var a -> TypeCheck var a
performing (FS (AnnF TypeInfo TermF) var -> Action var
forall var. TermT var -> Action var
ActionWHNF FS (AnnF TypeInfo TermF) var
tt) (TypeCheck var (FS (AnnF TypeInfo TermF) var)
 -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b. (a -> b) -> a -> b
$ case FS (AnnF TypeInfo TermF) var
tt of
  -- use cached result if it exists
  Free (AnnF TypeInfo (FS (AnnF TypeInfo TermF) var)
info TermF
  (Scope (FS (AnnF TypeInfo TermF)) var)
  (FS (AnnF TypeInfo TermF) var)
_)
    | Just FS (AnnF TypeInfo TermF) var
tt' <- TypeInfo (FS (AnnF TypeInfo TermF) var)
-> Maybe (FS (AnnF TypeInfo TermF) var)
forall term. TypeInfo term -> Maybe term
infoWHNF TypeInfo (FS (AnnF TypeInfo TermF) var)
info -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt'

  -- universe constants
  UniverseT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt
  UniverseCubeT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt
  UniverseTopeT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt

  -- cube layer (except vars, pairs, and applications)
  CubeProductT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope FS (AnnF TypeInfo TermF) var
tt
  CubeUnitT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt
  CubeUnitStarT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt
  Cube2T{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt
  Cube2_0T{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt
  Cube2_1T{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt
  CubeIT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt
  CubeI_0T{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt
  CubeI_1T{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt
  CubeFlipT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope FS (AnnF TypeInfo TermF) var
tt
  CubeUnflipT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope FS (AnnF TypeInfo TermF) var
tt

  -- tope layer (except vars, pairs of points, and applications)
  TopeTopT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt
  TopeBottomT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt
  TopeAndT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope FS (AnnF TypeInfo TermF) var
tt
  TopeOrT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope FS (AnnF TypeInfo TermF) var
tt
  TopeEQT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope FS (AnnF TypeInfo TermF) var
tt
  TopeLEQT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope FS (AnnF TypeInfo TermF) var
tt
  TopeInvT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope FS (AnnF TypeInfo TermF) var
tt
  TopeUninvT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope FS (AnnF TypeInfo TermF) var
tt

  -- type layer terms that should not be evaluated further
  LambdaT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt
  PairT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt
  ReflT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt
  TypeFunT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt
  TypeSigmaT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt
  TypeIdT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt
  TypeModalT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt
  RecBottomT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt
  TypeUnitT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt
  UnitT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt

  -- type ascriptions are ignored, since we already have a typechecked term
  TypeAscT TypeInfo (FS (AnnF TypeInfo TermF) var)
_ty FS (AnnF TypeInfo TermF) var
term FS (AnnF TypeInfo TermF) var
_ty' -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT FS (AnnF TypeInfo TermF) var
term

  -- check if we have cube or a tope term (if so, compute NF)
  FS (AnnF TypeInfo TermF) var
_ -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf FS (AnnF TypeInfo TermF) var
tt TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> (FS (AnnF TypeInfo TermF) var
    -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    UniverseCubeT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope FS (AnnF TypeInfo TermF) var
tt
    UniverseTopeT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope FS (AnnF TypeInfo TermF) var
tt

    -- CubeUnitT{} -> pure cubeUnitStarT -- compute an expression of 1 cube to its only point
    TypeUnitT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
forall var. TermT var
unitT -- compute an expression of Unit type to unit
    -- FIXME: next line is ad hoc, should be improved!
    TypeRestrictedT TypeInfo (FS (AnnF TypeInfo TermF) var)
_info TypeUnitT{} [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
_rs -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
forall var. TermT var
unitT -- compute an expression of Unit type to unit

    -- check if we have cube point term (if so, compute NF)
    FS (AnnF TypeInfo TermF) var
typeOf_tt -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf FS (AnnF TypeInfo TermF) var
typeOf_tt TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> (FS (AnnF TypeInfo TermF) var
    -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      UniverseCubeT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope FS (AnnF TypeInfo TermF) var
tt

      -- now we are in the type layer
      FS (AnnF TypeInfo TermF) var
_ -> (FS (AnnF TypeInfo TermF) var -> FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b.
(a -> b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FS (AnnF TypeInfo TermF) var -> FS (AnnF TypeInfo TermF) var
forall var. TermT var -> TermT var
termIsWHNF (TypeCheck var (FS (AnnF TypeInfo TermF) var)
 -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b. (a -> b) -> a -> b
$ do
        FS (AnnF TypeInfo TermF) var
-> TypeCheck var (Maybe (FS (AnnF TypeInfo TermF) var))
forall var.
Eq var =>
TermT var -> TypeCheck var (Maybe (TermT var))
tryRestriction FS (AnnF TypeInfo TermF) var
typeOf_tt TypeCheck var (Maybe (FS (AnnF TypeInfo TermF) var))
-> (Maybe (FS (AnnF TypeInfo TermF) var)
    -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just FS (AnnF TypeInfo TermF) var
tt' -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT FS (AnnF TypeInfo TermF) var
tt'
            Maybe (FS (AnnF TypeInfo TermF) var)
Nothing -> case FS (AnnF TypeInfo TermF) var
tt of
              -- a hole is opaque: it never reduces, it is already a normal form
              HoleT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt
              t :: FS (AnnF TypeInfo TermF) var
t@(Pure var
var) ->
                var -> TypeCheck var (Maybe (FS (AnnF TypeInfo TermF) var))
forall var. Eq var => var -> TypeCheck var (Maybe (TermT var))
valueOfVar var
var TypeCheck var (Maybe (FS (AnnF TypeInfo TermF) var))
-> (Maybe (FS (AnnF TypeInfo TermF) var)
    -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  Maybe (FS (AnnF TypeInfo TermF) var)
Nothing   -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
t
                  Just FS (AnnF TypeInfo TermF) var
term -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT FS (AnnF TypeInfo TermF) var
term

              AppT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty FS (AnnF TypeInfo TermF) var
f FS (AnnF TypeInfo TermF) var
x ->
                FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT FS (AnnF TypeInfo TermF) var
f TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> (FS (AnnF TypeInfo TermF) var
    -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  LambdaT TypeInfo (FS (AnnF TypeInfo TermF) var)
_ty Binder
_orig Maybe
  (TModality, FS (AnnF TypeInfo TermF) var,
   Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
_arg Scope (FS (AnnF TypeInfo TermF)) var
body ->
                    FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT (FS (AnnF TypeInfo TermF) var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> FS (AnnF TypeInfo TermF) var
forall var.
TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
substituteT FS (AnnF TypeInfo TermF) var
x Scope (FS (AnnF TypeInfo TermF)) var
body)
                  FS (AnnF TypeInfo TermF) var
f' -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf FS (AnnF TypeInfo TermF) var
f' TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> (FS (AnnF TypeInfo TermF) var
    -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    TypeFunT TypeInfo (FS (AnnF TypeInfo TermF) var)
_ty Binder
_orig TModality
md FS (AnnF TypeInfo TermF) var
_param (Just Scope (FS (AnnF TypeInfo TermF)) var
tope) UniverseTopeT{} -> do
                      x' <- TModality
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
md (TypeCheck var (FS (AnnF TypeInfo TermF) var)
 -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b. (a -> b) -> a -> b
$ FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
x
                      topeAndT
                        <$> pure (AppT ty f' x')
                        <*> nfT (substituteT x' tope)
                    -- FIXME: this seems to be a hack, and will not work in all situations!
                    -- FIXME: need to check performance of this code thoroughly
                    -- FIXME: for now, it seems to add ~2x slowdown
                    TypeFunT TypeInfo (FS (AnnF TypeInfo TermF) var)
info Binder
_orig TModality
md FS (AnnF TypeInfo TermF) var
_param Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
_mtope ret :: Scope (FS (AnnF TypeInfo TermF)) var
ret@TypeRestrictedT{}
                      | TypeRestrictedT{} <- TypeInfo (FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var
forall term. TypeInfo term -> term
infoType TypeInfo (FS (AnnF TypeInfo TermF) var)
info -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
AppT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty FS (AnnF TypeInfo TermF) var
f' FS (AnnF TypeInfo TermF) var
x)
                      | Bool
otherwise -> do
                          x' <- TModality
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
md (TypeCheck var (FS (AnnF TypeInfo TermF) var)
 -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b. (a -> b) -> a -> b
$ FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT FS (AnnF TypeInfo TermF) var
x
                          let ret' = FS (AnnF TypeInfo TermF) var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> FS (AnnF TypeInfo TermF) var
forall var.
TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
substituteT FS (AnnF TypeInfo TermF) var
x' Scope (FS (AnnF TypeInfo TermF)) var
ret
                          tryRestriction ret' >>= \case -- FIXME: too many unnecessary checks?
                            Maybe (FS (AnnF TypeInfo TermF) var)
Nothing  -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
AppT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty { infoType = ret' } FS (AnnF TypeInfo TermF) var
f' FS (AnnF TypeInfo TermF) var
x')
                            Just FS (AnnF TypeInfo TermF) var
tt' -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT FS (AnnF TypeInfo TermF) var
tt'
                    FS (AnnF TypeInfo TermF) var
_ -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
AppT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty FS (AnnF TypeInfo TermF) var
f' FS (AnnF TypeInfo TermF) var
x)

              LetT TypeInfo (FS (AnnF TypeInfo TermF) var)
_ty Binder
_orig Maybe (FS (AnnF TypeInfo TermF) var)
_mparam FS (AnnF TypeInfo TermF) var
val Scope (FS (AnnF TypeInfo TermF)) var
body ->
                FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT (FS (AnnF TypeInfo TermF) var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> FS (AnnF TypeInfo TermF) var
forall var.
TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
substituteT FS (AnnF TypeInfo TermF) var
val Scope (FS (AnnF TypeInfo TermF)) var
body)
              LetModT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty Binder
orig TModality
app TModality
inn Maybe (FS (AnnF TypeInfo TermF) var)
mparam FS (AnnF TypeInfo TermF) var
val Scope (FS (AnnF TypeInfo TermF)) var
body -> do
                (TModality
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
app (TypeCheck var (FS (AnnF TypeInfo TermF) var)
 -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b. (a -> b) -> a -> b
$ FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT FS (AnnF TypeInfo TermF) var
val) TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> (FS (AnnF TypeInfo TermF) var
    -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  ModAppT TypeInfo (FS (AnnF TypeInfo TermF) var)
_ TModality
md FS (AnnF TypeInfo TermF) var
t | TModality
md TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
== TModality
inn -> do
                    val' <- TModality
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
md (TypeCheck var (FS (AnnF TypeInfo TermF) var)
 -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b. (a -> b) -> a -> b
$ FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT FS (AnnF TypeInfo TermF) var
t
                    whnfT (substituteT val' body)
                  FS (AnnF TypeInfo TermF) var
b' | TModality -> Bool
forall m. ModeTheory m => m -> Bool
isRA TModality
inn -> do
                    bty <- FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf FS (AnnF TypeInfo TermF) var
b' TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> (FS (AnnF TypeInfo TermF) var
    -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                      TypeModalT TypeInfo (FS (AnnF TypeInfo TermF) var)
_ TModality
_ FS (AnnF TypeInfo TermF) var
t -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
t
                      FS (AnnF TypeInfo TermF) var
_ -> String -> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a. String -> a
panicImpossible String
"not modal in letmod"
                    whnfT (substituteT (modExtractT bty app inn b') body)
                  FS (AnnF TypeInfo TermF) var
_ -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (FS (AnnF TypeInfo TermF) var)
-> Binder
-> TModality
-> TModality
-> Maybe (FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> FS (AnnF TypeInfo TermF) var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> Binder
-> TModality
-> TModality
-> Maybe (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a
-> Scope (FS (AnnF ann TermF)) a
-> FS (AnnF ann TermF) a
LetModT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty Binder
orig TModality
app TModality
inn Maybe (FS (AnnF TypeInfo TermF) var)
mparam FS (AnnF TypeInfo TermF) var
val Scope (FS (AnnF TypeInfo TermF)) var
body)
              FirstT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty FS (AnnF TypeInfo TermF) var
t ->
                FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT FS (AnnF TypeInfo TermF) var
t TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> (FS (AnnF TypeInfo TermF) var
    -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  PairT TypeInfo (FS (AnnF TypeInfo TermF) var)
_ FS (AnnF TypeInfo TermF) var
l FS (AnnF TypeInfo TermF) var
_r -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT FS (AnnF TypeInfo TermF) var
l
                  FS (AnnF TypeInfo TermF) var
t'           -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var -> FS (AnnF TypeInfo TermF) var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a -> FS (AnnF ann TermF) a
FirstT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty FS (AnnF TypeInfo TermF) var
t')

              SecondT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty FS (AnnF TypeInfo TermF) var
t ->
                FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT FS (AnnF TypeInfo TermF) var
t TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> (FS (AnnF TypeInfo TermF) var
    -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  PairT TypeInfo (FS (AnnF TypeInfo TermF) var)
_ FS (AnnF TypeInfo TermF) var
_l FS (AnnF TypeInfo TermF) var
r -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT FS (AnnF TypeInfo TermF) var
r
                  FS (AnnF TypeInfo TermF) var
t'           -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var -> FS (AnnF TypeInfo TermF) var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a -> FS (AnnF ann TermF) a
SecondT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty FS (AnnF TypeInfo TermF) var
t')
              ModAppT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty TModality
md FS (AnnF TypeInfo TermF) var
b -> do
                (TModality
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
md (TypeCheck var (FS (AnnF TypeInfo TermF) var)
 -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b. (a -> b) -> a -> b
$ FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT FS (AnnF TypeInfo TermF) var
b) TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> (FS (AnnF TypeInfo TermF) var
    -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  ModExtractT TypeInfo (FS (AnnF TypeInfo TermF) var)
_ TModality
app TModality
inn FS (AnnF TypeInfo TermF) var
t | TModality
inn TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
== TModality
md -> TModality
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality (TModality -> TModality -> TModality
forall m. ModeTheory m => m -> m -> m
comp TModality
md TModality
app) (TypeCheck var (FS (AnnF TypeInfo TermF) var)
 -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b. (a -> b) -> a -> b
$ FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT FS (AnnF TypeInfo TermF) var
t
                  FS (AnnF TypeInfo TermF) var
b' -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FS (AnnF TypeInfo TermF) var
 -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b. (a -> b) -> a -> b
$ TypeInfo (FS (AnnF TypeInfo TermF) var)
-> TModality
-> FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> TModality -> FS (AnnF ann TermF) a -> FS (AnnF ann TermF) a
ModAppT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty TModality
md FS (AnnF TypeInfo TermF) var
b'
              ModExtractT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty TModality
app TModality
inn FS (AnnF TypeInfo TermF) var
b -> do
                (TModality
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
app (TypeCheck var (FS (AnnF TypeInfo TermF) var)
 -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b. (a -> b) -> a -> b
$ FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT FS (AnnF TypeInfo TermF) var
b) TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> (FS (AnnF TypeInfo TermF) var
    -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  ModAppT TypeInfo (FS (AnnF TypeInfo TermF) var)
_ TModality
md FS (AnnF TypeInfo TermF) var
t | TModality
inn TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
== TModality
md -> TModality
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
inn (TypeCheck var (FS (AnnF TypeInfo TermF) var)
 -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b. (a -> b) -> a -> b
$ FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT FS (AnnF TypeInfo TermF) var
t
                  FS (AnnF TypeInfo TermF) var
b' -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (FS (AnnF TypeInfo TermF) var)
-> TModality
-> TModality
-> FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> TModality
-> TModality
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
ModExtractT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty TModality
app TModality
inn FS (AnnF TypeInfo TermF) var
b')
              IdJT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty FS (AnnF TypeInfo TermF) var
tA FS (AnnF TypeInfo TermF) var
a FS (AnnF TypeInfo TermF) var
tC FS (AnnF TypeInfo TermF) var
d FS (AnnF TypeInfo TermF) var
x FS (AnnF TypeInfo TermF) var
p ->
                FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT FS (AnnF TypeInfo TermF) var
p TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> (FS (AnnF TypeInfo TermF) var
    -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  ReflT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT FS (AnnF TypeInfo TermF) var
d
                  FS (AnnF TypeInfo TermF) var
p'      -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
IdJT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty FS (AnnF TypeInfo TermF) var
tA FS (AnnF TypeInfo TermF) var
a FS (AnnF TypeInfo TermF) var
tC FS (AnnF TypeInfo TermF) var
d FS (AnnF TypeInfo TermF) var
x FS (AnnF TypeInfo TermF) var
p')

              RecOrT TypeInfo (FS (AnnF TypeInfo TermF) var)
_ty [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
rs -> do
                let go :: [(TermT var, a)]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe a)
go [] = Maybe a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe a)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
                    go ((TermT var
tope, a
tt') : [(TermT var, a)]
rs') = do
                      TermT var -> TypeCheck var Bool
forall var. Eq var => TermT var -> TypeCheck var Bool
checkTope TermT var
tope TypeCheck var Bool
-> (Bool
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         (Maybe a))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe a)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                        Bool
True  -> Maybe a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe a)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Maybe a
forall a. a -> Maybe a
Just a
tt')
                        Bool
False -> [(TermT var, a)]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe a)
go [(TermT var, a)]
rs'
                [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
-> TypeCheck var (Maybe (FS (AnnF TypeInfo TermF) var))
forall {var} {a}.
Eq var =>
[(TermT var, a)]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe a)
go [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
rs TypeCheck var (Maybe (FS (AnnF TypeInfo TermF) var))
-> (Maybe (FS (AnnF TypeInfo TermF) var)
    -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  Just FS (AnnF TypeInfo TermF) var
tt' -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT FS (AnnF TypeInfo TermF) var
tt'
                  Maybe (FS (AnnF TypeInfo TermF) var)
Nothing
                    | [FS (AnnF TypeInfo TermF) var
tt'] <- [FS (AnnF TypeInfo TermF) var] -> [FS (AnnF TypeInfo TermF) var]
forall a. Eq a => [a] -> [a]
nubTermT (((FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)
 -> FS (AnnF TypeInfo TermF) var)
-> [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
-> [FS (AnnF TypeInfo TermF) var]
forall a b. (a -> b) -> [a] -> [b]
map (FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var
forall a b. (a, b) -> b
snd [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
rs) -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT FS (AnnF TypeInfo TermF) var
tt'
                    | Bool
otherwise -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt

              TypeRestrictedT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty FS (AnnF TypeInfo TermF) var
type_ [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
rs -> do
                rs' <- ((FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      (FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var))
-> [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
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 (\(FS (AnnF TypeInfo TermF) var
tope, FS (AnnF TypeInfo TermF) var
term) -> (,) (FS (AnnF TypeInfo TermF) var
 -> FS (AnnF TypeInfo TermF) var
 -> (FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (FS (AnnF TypeInfo TermF) var
      -> (FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
tope ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (FS (AnnF TypeInfo TermF) var
   -> (FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (a -> b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
term) [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
rs
                case filter ((/= topeBottomT) . fst) rs' of
                  []   -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT FS (AnnF TypeInfo TermF) var
type_  -- get rid of restrictions at BOT
                  [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
rs'' -> TypeInfo (FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var
-> [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
-> FS (AnnF TypeInfo TermF) var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a
-> [(FS (AnnF ann TermF) a, FS (AnnF ann TermF) a)]
-> FS (AnnF ann TermF) a
TypeRestrictedT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty (FS (AnnF TypeInfo TermF) var
 -> [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
 -> FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     ([(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
      -> FS (AnnF TypeInfo TermF) var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT FS (AnnF TypeInfo TermF) var
type_ ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  ([(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
   -> FS (AnnF TypeInfo TermF) var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (a -> b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
rs''

nfTope :: Eq var => TermT var -> TypeCheck var (TermT var)
nfTope :: forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
tt = Action var
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall var a.
Eq var =>
Action var -> TypeCheck var a -> TypeCheck var a
performing (TermT var -> Action var
forall var. TermT var -> Action var
ActionNF TermT var
tt) (TypeCheck var (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ (TermT var -> TermT var)
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b.
(a -> b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TermT var -> TermT var
forall var. TermT var -> TermT var
termIsNF (TypeCheck var (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ case TermT var
tt of
  HoleT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  Pure var
var ->
    var -> TypeCheck var (Maybe (TermT var))
forall var. Eq var => var -> TypeCheck var (Maybe (TermT var))
valueOfVar var
var TypeCheck var (Maybe (TermT var))
-> (Maybe (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (TermT var)
Nothing   -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return TermT var
tt
      Just TermT var
term -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
term

  -- see if normal form is already available
  Free (AnnF TypeInfo (TermT var)
info TermF (Scope (FS (AnnF TypeInfo TermF)) var) (TermT var)
_) | Just TermT var
tt' <- TypeInfo (TermT var) -> Maybe (TermT var)
forall term. TypeInfo term -> Maybe term
infoNF TypeInfo (TermT var)
info -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt'

  -- universe constants
  UniverseT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  UniverseCubeT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  UniverseTopeT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt

  -- cube layer constants
  CubeUnitT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  CubeUnitStarT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  Cube2T{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  Cube2_0T{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  Cube2_1T{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  CubeIT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  CubeI_0T{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  CubeI_1T{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt

  -- type layer constants
  TypeUnitT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  UnitT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt

  -- cube layer with computation
  CubeProductT TypeInfo (TermT var)
_ty TermT var
l TermT var
r -> TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
cubeProductT (TermT var -> TermT var -> TermT var)
-> TypeCheck var (TermT var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var -> TermT var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
l ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (TermT var -> TermT var)
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (a -> b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
r

  CubeFlipT TypeInfo (TermT var)
ty TermT var
t ->
    TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
t TypeCheck var (TermT var)
-> (TermT var -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      CubeUnflipT TypeInfo (TermT var)
_ TermT var
t' -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
t'
      Cube2_0T{}       -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT var -> TModality -> TermT var -> TermT var
forall var. TermT var -> TModality -> TermT var -> TermT var
modAppT (TermT var -> TModality -> TermT var -> TermT var
forall var. TermT var -> TModality -> TermT var -> TermT var
typeModalT TermT var
forall var. TermT var
cubeT TModality
Op TermT var
forall var. TermT var
cube2T) TModality
Op TermT var
forall var. TermT var
cube2_1T)
      Cube2_1T{}       -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT var -> TModality -> TermT var -> TermT var
forall var. TermT var -> TModality -> TermT var -> TermT var
modAppT (TermT var -> TModality -> TermT var -> TermT var
forall var. TermT var -> TModality -> TermT var -> TermT var
typeModalT TermT var
forall var. TermT var
cubeT TModality
Op TermT var
forall var. TermT var
cube2T) TModality
Op TermT var
forall var. TermT var
cube2_0T)
      CubeI_0T{}       -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT var -> TModality -> TermT var -> TermT var
forall var. TermT var -> TModality -> TermT var -> TermT var
modAppT (TermT var -> TModality -> TermT var -> TermT var
forall var. TermT var -> TModality -> TermT var -> TermT var
typeModalT TermT var
forall var. TermT var
cubeT TModality
Op TermT var
forall var. TermT var
cubeIT) TModality
Op TermT var
forall var. TermT var
cubeI_1T)
      CubeI_1T{}       -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT var -> TModality -> TermT var -> TermT var
forall var. TermT var -> TModality -> TermT var -> TermT var
modAppT (TermT var -> TModality -> TermT var -> TermT var
forall var. TermT var -> TModality -> TermT var -> TermT var
typeModalT TermT var
forall var. TermT var
cubeT TModality
Op TermT var
forall var. TermT var
cubeIT) TModality
Op TermT var
forall var. TermT var
cubeI_0T)
      TermT var
t'               -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (TermT var) -> TermT var -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a -> FS (AnnF ann TermF) a
CubeFlipT TypeInfo (TermT var)
ty TermT var
t')

  CubeUnflipT TypeInfo (TermT var)
ty TermT var
t -> 
    TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
t TypeCheck var (TermT var)
-> (TermT var -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      CubeFlipT TypeInfo (TermT var)
_ TermT var
t'          -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
t'
      ModAppT TypeInfo (TermT var)
_ TModality
Op Cube2_0T{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
forall var. TermT var
cube2_1T
      ModAppT TypeInfo (TermT var)
_ TModality
Op Cube2_1T{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
forall var. TermT var
cube2_0T
      ModAppT TypeInfo (TermT var)
_ TModality
Op CubeI_0T{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
forall var. TermT var
cubeI_1T
      ModAppT TypeInfo (TermT var)
_ TModality
Op CubeI_1T{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
forall var. TermT var
cubeI_0T
      TermT var
t'                      -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (TermT var) -> TermT var -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a -> FS (AnnF ann TermF) a
CubeUnflipT TypeInfo (TermT var)
ty TermT var
t')

  -- tope layer constants
  TopeTopT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  TopeBottomT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt

  -- tope layer with computation
  TopeAndT TypeInfo (TermT var)
ty TermT var
l TermT var
r ->
    TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
l TypeCheck var (TermT var)
-> (TermT var -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      TopeBottomT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
forall var. TermT var
topeBottomT
      TermT var
l' -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
r TypeCheck var (TermT var)
-> (TermT var -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        TopeBottomT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
forall var. TermT var
topeBottomT
        TermT var
r'            -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (TermT var) -> TermT var -> TermT var -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
TopeAndT TypeInfo (TermT var)
ty TermT var
l' TermT var
r')

  TopeOrT  TypeInfo (TermT var)
ty TermT var
l TermT var
r -> do
    l' <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
l
    r' <- nfTope r
    case (l', r') of
      (TopeBottomT{}, TermT var
_) -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
r'
      (TermT var
_, TopeBottomT{}) -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
l'
      (TermT var, TermT var)
_                  -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (TermT var) -> TermT var -> TermT var -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
TopeOrT TypeInfo (TermT var)
ty TermT var
l' TermT var
r')

  TopeEQT  TypeInfo (TermT var)
ty TermT var
l TermT var
r -> TypeInfo (TermT var) -> TermT var -> TermT var -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
TopeEQT  TypeInfo (TermT var)
ty (TermT var -> TermT var -> TermT var)
-> TypeCheck var (TermT var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var -> TermT var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
l ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (TermT var -> TermT var)
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (a -> b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
r
  TopeLEQT TypeInfo (TermT var)
ty TermT var
l TermT var
r -> TypeInfo (TermT var) -> TermT var -> TermT var -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
TopeLEQT TypeInfo (TermT var)
ty (TermT var -> TermT var -> TermT var)
-> TypeCheck var (TermT var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var -> TermT var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
l ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (TermT var -> TermT var)
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (a -> b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
r

  TopeInvT TypeInfo (TermT var)
ty TermT var
t ->
    -- Match And/Or on the *unnormalized* input: nfTope of a shape-restricted
    -- App produces a TopeAnd via shape-side-condition propagation, and
    -- distributing inv over that synthetic conjunction loops forever because
    -- the recursive topeInvT renormalizes the same App back into a TopeAnd.
    case TermT var
t of
      TopeTopT TypeInfo (TermT var)
_ -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT var -> TypeCheck var (TermT var))
-> TermT var -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ TermT var -> TModality -> TermT var -> TermT var
forall var. TermT var -> TModality -> TermT var -> TermT var
modAppT TermT var
forall var. TermT var
topeT TModality
Op TermT var
forall var. TermT var
topeTopT
      TopeBottomT TypeInfo (TermT var)
_ -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT var -> TypeCheck var (TermT var))
-> TermT var -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ TermT var -> TModality -> TermT var -> TermT var
forall var. TermT var -> TModality -> TermT var -> TermT var
modAppT TermT var
forall var. TermT var
topeT TModality
Op TermT var
forall var. TermT var
topeBottomT
      TopeLEQT TypeInfo (TermT var)
_ TermT var
x TermT var
y -> do
        xTy <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
x
        yTy <- typeOf y
        nfTope $
          modAppT (typeModalT universeT Op topeT) Op
            (topeLEQT
              (modExtractT topeT Id Op (cubeFlipT xTy y))
              (modExtractT topeT Id Op (cubeFlipT yTy x)))
      TopeEQT TypeInfo (TermT var)
_ TermT var
x TermT var
y -> do
        xTy <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
x
        yTy <- typeOf y
        nfTope $
          modAppT (typeModalT universeT Op topeT) Op
            (topeEQT
              (modExtractT topeT Id Op (cubeFlipT xTy y))
              (modExtractT topeT Id Op (cubeFlipT yTy x)))
      TopeAndT TypeInfo (TermT var)
_ TermT var
phi TermT var
psi -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope (TermT var -> TypeCheck var (TermT var))
-> TermT var -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$
        TermT var -> TModality -> TermT var -> TermT var
forall var. TermT var -> TModality -> TermT var -> TermT var
modAppT (TermT var -> TModality -> TermT var -> TermT var
forall var. TermT var -> TModality -> TermT var -> TermT var
typeModalT TermT var
forall var. TermT var
universeT TModality
Op TermT var
forall var. TermT var
topeT) TModality
Op
          (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeAndT
            (TermT var -> TModality -> TModality -> TermT var -> TermT var
forall var.
TermT var -> TModality -> TModality -> TermT var -> TermT var
modExtractT TermT var
forall var. TermT var
topeT TModality
Id TModality
Op (TermT var -> TermT var
forall var. TermT var -> TermT var
topeInvT TermT var
phi))
            (TermT var -> TModality -> TModality -> TermT var -> TermT var
forall var.
TermT var -> TModality -> TModality -> TermT var -> TermT var
modExtractT TermT var
forall var. TermT var
topeT TModality
Id TModality
Op (TermT var -> TermT var
forall var. TermT var -> TermT var
topeInvT TermT var
psi)))
      TopeOrT TypeInfo (TermT var)
_ TermT var
phi TermT var
psi -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope (TermT var -> TypeCheck var (TermT var))
-> TermT var -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$
        TermT var -> TModality -> TermT var -> TermT var
forall var. TermT var -> TModality -> TermT var -> TermT var
modAppT (TermT var -> TModality -> TermT var -> TermT var
forall var. TermT var -> TModality -> TermT var -> TermT var
typeModalT TermT var
forall var. TermT var
universeT TModality
Op TermT var
forall var. TermT var
topeT) TModality
Op
          (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeOrT
            (TermT var -> TModality -> TModality -> TermT var -> TermT var
forall var.
TermT var -> TModality -> TModality -> TermT var -> TermT var
modExtractT TermT var
forall var. TermT var
topeT TModality
Id TModality
Op (TermT var -> TermT var
forall var. TermT var -> TermT var
topeInvT TermT var
phi))
            (TermT var -> TModality -> TModality -> TermT var -> TermT var
forall var.
TermT var -> TModality -> TModality -> TermT var -> TermT var
modExtractT TermT var
forall var. TermT var
topeT TModality
Id TModality
Op (TermT var -> TermT var
forall var. TermT var -> TermT var
topeInvT TermT var
psi)))
      TermT var
_ ->
        TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
t TypeCheck var (TermT var)
-> (TermT var -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          TopeTopT TypeInfo (TermT var)
_ -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
forall var. TermT var
topeTopT
          TopeBottomT TypeInfo (TermT var)
_ -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
forall var. TermT var
topeBottomT
          TopeUninvT TypeInfo (TermT var)
_ TermT var
phi -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
phi
          TopeLEQT TypeInfo (TermT var)
_ TermT var
x TermT var
y -> do
            xTy <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
x
            yTy <- typeOf y
            nfTope $
              modAppT (typeModalT universeT Op topeT) Op
                (topeLEQT
                  (modExtractT topeT Id Op (cubeFlipT xTy y))
                  (modExtractT topeT Id Op (cubeFlipT yTy x)))
          TopeEQT TypeInfo (TermT var)
_ TermT var
x TermT var
y -> do
            xTy <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
x
            yTy <- typeOf y
            nfTope $
              modAppT (typeModalT universeT Op topeT) Op
                (topeEQT
                  (modExtractT topeT Id Op (cubeFlipT xTy y))
                  (modExtractT topeT Id Op (cubeFlipT yTy x)))
          TermT var
t' -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (TermT var) -> TermT var -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a -> FS (AnnF ann TermF) a
TopeInvT TypeInfo (TermT var)
ty TermT var
t')

  TopeUninvT TypeInfo (TermT var)
ty TermT var
t ->
    case TermT var
t of
      ModAppT TypeInfo (TermT var)
_ TModality
Op TermT var
inner -> case TermT var
inner of
        TopeTopT TypeInfo (TermT var)
_ -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
forall var. TermT var
topeTopT
        TopeBottomT TypeInfo (TermT var)
_ -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
forall var. TermT var
topeBottomT 
        TopeAndT TypeInfo (TermT var)
_ TermT var
phi TermT var
psi ->
          TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope (TermT var -> TypeCheck var (TermT var))
-> TermT var -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$
              (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeAndT
                (TermT var -> TermT var
forall var. TermT var -> TermT var
topeUninvT TermT var
phi)
                (TermT var -> TermT var
forall var. TermT var -> TermT var
topeUninvT TermT var
psi))
        TopeOrT TypeInfo (TermT var)
_ TermT var
phi TermT var
psi ->
          TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope (TermT var -> TypeCheck var (TermT var))
-> TermT var -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$
              (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeOrT
                (TermT var -> TermT var
forall var. TermT var -> TermT var
topeUninvT TermT var
phi)
                (TermT var -> TermT var
forall var. TermT var -> TermT var
topeUninvT TermT var
psi))
        TermT var
_ ->
          TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
t TypeCheck var (TermT var)
-> (TermT var -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            TopeTopT TypeInfo (TermT var)
_ -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
forall var. TermT var
topeTopT
            TopeBottomT TypeInfo (TermT var)
_ -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
forall var. TermT var
topeBottomT
            TopeInvT TypeInfo (TermT var)
_ TermT var
phi -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
phi
            ModAppT TypeInfo (TermT var)
_ TModality
Op TermT var
inner'' -> case TermT var
inner'' of
              TopeLEQT TypeInfo (TermT var)
_ TermT var
x TermT var
y -> do
                xTy <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
x
                yTy <- typeOf y
                nfTope $
                  (topeLEQT
                    (cubeUnflipT xTy (modAppT (typeModalT cubeT Op xTy) Op y))
                    (cubeUnflipT yTy (modAppT (typeModalT cubeT Op yTy) Op x)))
              TopeEQT TypeInfo (TermT var)
_ TermT var
x TermT var
y -> do
                xTy <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
x
                yTy <- typeOf y
                nfTope $
                  (topeEQT
                    (cubeUnflipT xTy (modAppT (typeModalT cubeT Op xTy) Op y))
                    (cubeUnflipT yTy (modAppT (typeModalT cubeT Op yTy) Op x)))
              TermT var
inner' ->
                TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT var -> TypeCheck var (TermT var))
-> TermT var -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$
                  TypeInfo (TermT var) -> TermT var -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a -> FS (AnnF ann TermF) a
TopeUninvT TypeInfo (TermT var)
ty
                    (TermT var -> TModality -> TermT var -> TermT var
forall var. TermT var -> TModality -> TermT var -> TermT var
modAppT (TermT var -> TModality -> TermT var -> TermT var
forall var. TermT var -> TModality -> TermT var -> TermT var
typeModalT TermT var
forall var. TermT var
universeT TModality
Op TermT var
forall var. TermT var
topeT) TModality
Op TermT var
inner')
            TermT var
t' ->
                TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (TermT var) -> TermT var -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a -> FS (AnnF ann TermF) a
TopeUninvT TypeInfo (TermT var)
ty TermT var
t')
      TermT var
_ ->
        TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
t TypeCheck var (TermT var)
-> (TermT var -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          TopeInvT TypeInfo (TermT var)
_ TermT var
phi -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
phi
          t' :: TermT var
t'@(ModAppT TypeInfo (TermT var)
_ TModality
Op TermT var
_) -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope (TypeInfo (TermT var) -> TermT var -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a -> FS (AnnF ann TermF) a
TopeUninvT TypeInfo (TermT var)
ty TermT var
t')
          TermT var
t' -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (TermT var) -> TermT var -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a -> FS (AnnF ann TermF) a
TopeUninvT TypeInfo (TermT var)
ty TermT var
t')

  -- type ascriptions are ignored, since we already have a typechecked term
  TypeAscT TypeInfo (TermT var)
_ty TermT var
term TermT var
_ty' -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
term

  PairT TypeInfo (TermT var)
ty TermT var
l TermT var
r -> TypeInfo (TermT var) -> TermT var -> TermT var -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
PairT TypeInfo (TermT var)
ty (TermT var -> TermT var -> TermT var)
-> TypeCheck var (TermT var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var -> TermT var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
l ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (TermT var -> TermT var)
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (a -> b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
r

  AppT TypeInfo (TermT var)
ty TermT var
f TermT var
x ->
    TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
f TypeCheck var (TermT var)
-> (TermT var -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      LambdaT TypeInfo (TermT var)
_ty Binder
_orig Maybe
  (TModality, TermT var,
   Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
_arg Scope (FS (AnnF TypeInfo TermF)) var
body ->
        TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope (TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
forall var.
TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
substituteT TermT var
x Scope (FS (AnnF TypeInfo TermF)) var
body)
      TermT var
f' -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOfUncomputed TermT var
f' TypeCheck var (TermT var)
-> (TermT var -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        TypeFunT TypeInfo (TermT var)
_ty Binder
_orig TModality
md TermT var
_param (Just Scope (FS (AnnF TypeInfo TermF)) var
tope) UniverseTopeT{} -> do
          x' <- TModality -> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
md (TypeCheck var (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
x
          topeAndT
            <$> pure (AppT ty f' x')
            <*> nfTope (substituteT x' tope)
        TermT var
_ -> TypeInfo (TermT var) -> TermT var -> TermT var -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
AppT TypeInfo (TermT var)
ty TermT var
f' (TermT var -> TermT var)
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
x

  FirstT TypeInfo (TermT var)
ty TermT var
t ->
    TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
t TypeCheck var (TermT var)
-> (TermT var -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      PairT TypeInfo (TermT var)
_ty TermT var
x TermT var
_y -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
x
      TermT var
t'             -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (TermT var) -> TermT var -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a -> FS (AnnF ann TermF) a
FirstT TypeInfo (TermT var)
ty TermT var
t')

  SecondT TypeInfo (TermT var)
ty TermT var
t ->
    TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
t TypeCheck var (TermT var)
-> (TermT var -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      PairT TypeInfo (TermT var)
_ty TermT var
_x TermT var
y -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
y
      TermT var
t'             -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (TermT var) -> TermT var -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a -> FS (AnnF ann TermF) a
SecondT TypeInfo (TermT var)
ty TermT var
t')

  LambdaT TypeInfo (TermT var)
ty Binder
orig Maybe
  (TModality, TermT var,
   Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
_mparam Scope (FS (AnnF TypeInfo TermF)) var
body
    | TypeFunT TypeInfo (TermT var)
_ty Binder
_origF TModality
md TermT var
param Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope Scope (FS (AnnF TypeInfo TermF)) var
_ret <- TypeInfo (TermT var) -> TermT var
forall term. TypeInfo term -> term
infoType TypeInfo (TermT var)
ty ->
        -- NOTE: the domain @param@ is left unnormalised: in the tope layer it may
        -- be a shape (a function type into TOPE), which nfTope cannot normalise.
        TypeInfo (TermT var)
-> Binder
-> Maybe
     (TModality, TermT var,
      Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> Binder
-> Maybe
     (TModality, FS (AnnF ann TermF) a,
      Maybe (Scope (FS (AnnF ann TermF)) a))
-> Scope (FS (AnnF ann TermF)) a
-> FS (AnnF ann TermF) a
LambdaT TypeInfo (TermT var)
ty Binder
orig ((TModality, TermT var,
 Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> Maybe
     (TModality, TermT var,
      Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
forall a. a -> Maybe a
Just (TModality
md, TermT var
param, Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope)) (Scope (FS (AnnF TypeInfo TermF)) var -> TermT var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Scope (FS (AnnF TypeInfo TermF)) var)
-> TypeCheck var (TermT var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Binder
-> TModality
-> TermT var
-> TypeCheck (Inc var) (Scope (FS (AnnF TypeInfo TermF)) var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Scope (FS (AnnF TypeInfo TermF)) var)
forall var b.
Binder
-> TModality
-> TermT var
-> TypeCheck (Inc var) b
-> TypeCheck var b
enterScope Binder
orig TModality
md TermT var
param (Scope (FS (AnnF TypeInfo TermF)) var
-> TypeCheck (Inc var) (Scope (FS (AnnF TypeInfo TermF)) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope Scope (FS (AnnF TypeInfo TermF)) var
body)
  LambdaT{} -> String -> TypeCheck var (TermT var)
forall a. String -> a
panicImpossible String
"lambda with a non-function type in the tope layer"
  ModAppT TypeInfo (TermT var)
ty TModality
md TermT var
b ->
    (TModality -> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
md (TypeCheck var (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
b) TypeCheck var (TermT var)
-> (TermT var -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      ModExtractT TypeInfo (TermT var)
_ TModality
_ TModality
inn TermT var
t | TModality
inn TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
== TModality
md -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
t
      TermT var
b' -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT var -> TypeCheck var (TermT var))
-> TermT var -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ TypeInfo (TermT var) -> TModality -> TermT var -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> TModality -> FS (AnnF ann TermF) a -> FS (AnnF ann TermF) a
ModAppT TypeInfo (TermT var)
ty TModality
md TermT var
b'
  ModExtractT TypeInfo (TermT var)
ty TModality
app TModality
inn TermT var
b ->
    (TModality -> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
app (TypeCheck var (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
b) TypeCheck var (TermT var)
-> (TermT var -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      ModAppT TypeInfo (TermT var)
_ TModality
md TermT var
t | TModality
inn TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
== TModality
md -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
t
      TermT var
b' -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT var -> TypeCheck var (TermT var))
-> TermT var -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ TypeInfo (TermT var)
-> TModality -> TModality -> TermT var -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> TModality
-> TModality
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
ModExtractT TypeInfo (TermT var)
ty TModality
app TModality
inn TermT var
b'
  LetModT TypeInfo (TermT var)
ty Binder
orig TModality
app TModality
inn Maybe (TermT var)
mparam TermT var
val Scope (FS (AnnF TypeInfo TermF)) var
body -> do
    (TModality -> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
app (TypeCheck var (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
val) TypeCheck var (TermT var)
-> (TermT var -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      ModAppT TypeInfo (TermT var)
_ TModality
md TermT var
t | TModality
md TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
== TModality
inn -> do
        val' <- TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return TermT var
t
        nfTope (substituteT val' body)
      TermT var
b' | TModality -> Bool
forall m. ModeTheory m => m -> Bool
isRA TModality
inn -> do
        bty <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
b' TypeCheck var (TermT var)
-> (TermT var -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          TypeModalT TypeInfo (TermT var)
_ TModality
_ TermT var
t -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
t
          TermT var
_ -> String -> TypeCheck var (TermT var)
forall a. String -> a
panicImpossible String
"not modal in letmod"
        nfTope (substituteT (modExtractT bty app inn b') body)
      TermT var
b' -> do
        bty <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
b' TypeCheck var (TermT var)
-> (TermT var -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          TypeModalT TypeInfo (TermT var)
_ TModality
_ TermT var
t -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
t
          TermT var
_ -> String -> TypeCheck var (TermT var)
forall a. String -> a
panicImpossible String
"not modal in letmod"
        val' <- enterModality app $ nfTope b'
        body' <- enterScope orig (comp app inn) bty $ nfTope body
        pure (LetModT ty orig app inn mparam val' body')

  TypeModalT TypeInfo (TermT var)
ty TModality
md TermT var
inner -> TypeInfo (TermT var) -> TModality -> TermT var -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> TModality -> FS (AnnF ann TermF) a -> FS (AnnF ann TermF) a
TypeModalT TypeInfo (TermT var)
ty TModality
md (TermT var -> TermT var)
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TModality -> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
md (TypeCheck var (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
inner)
  LetT TypeInfo (TermT var)
_ty Binder
_orig Maybe (TermT var)
_mparam TermT var
val Scope (FS (AnnF TypeInfo TermF)) var
body -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope (TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
forall var.
TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
substituteT TermT var
val Scope (FS (AnnF TypeInfo TermF)) var
body)
  TypeFunT{} -> String -> TypeCheck var (TermT var)
forall a. String -> a
panicImpossible String
"exposed function type in the tope layer"
  TypeSigmaT{} -> String -> TypeCheck var (TermT var)
forall a. String -> a
panicImpossible String
"dependent sum type in the tope layer"
  TypeIdT{} -> String -> TypeCheck var (TermT var)
forall a. String -> a
panicImpossible String
"identity type in the tope layer"
  ReflT{} -> String -> TypeCheck var (TermT var)
forall a. String -> a
panicImpossible String
"refl in the tope layer"
  IdJT{} -> String -> TypeCheck var (TermT var)
forall a. String -> a
panicImpossible String
"idJ eliminator in the tope layer"
  TypeRestrictedT{} -> String -> TypeCheck var (TermT var)
forall a. String -> a
panicImpossible String
"extension types in the tope layer"

  -- A recOR/recBOT is a term-level eliminator, never a tope. It should have
  -- been rejected before reaching here (see the RecOr case of 'typecheck'); as
  -- a safety net for any other path, report a type error rather than panicking.
  RecOrT{} -> TypeError var -> TypeCheck var (TermT var)
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var -> TypeCheck var (TermT var))
-> TypeError var -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ String -> TypeError var
forall var. String -> TypeError var
TypeErrorOther String
"a recOR cannot appear in the tope layer"
  RecBottomT{} -> TypeError var -> TypeCheck var (TermT var)
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var -> TypeCheck var (TermT var))
-> TypeError var -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ String -> TypeError var
forall var. String -> TypeError var
TypeErrorOther String
"a recBOT cannot appear in the tope layer"

-- | Compute a typed term to its NF.
--
-- >>> unsafeTypeCheck' $ nfT "(\\ (x : Unit) -> x) unit"
-- unit : Unit
nfT :: Eq var => TermT var -> TypeCheck var (TermT var)
nfT :: forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
tt = Action var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var a.
Eq var =>
Action var -> TypeCheck var a -> TypeCheck var a
performing (FS (AnnF TypeInfo TermF) var -> Action var
forall var. TermT var -> Action var
ActionNF FS (AnnF TypeInfo TermF) var
tt) (TypeCheck var (FS (AnnF TypeInfo TermF) var)
 -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b. (a -> b) -> a -> b
$ case FS (AnnF TypeInfo TermF) var
tt of
  -- universe constants
  UniverseT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt
  UniverseCubeT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt
  UniverseTopeT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt

  -- cube layer constants
  CubeUnitT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt
  CubeUnitStarT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt
  Cube2T{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt
  Cube2_0T{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt
  Cube2_1T{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt
  CubeIT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt
  CubeI_0T{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt
  CubeI_1T{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt

  -- cube layer with computation
  CubeProductT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope FS (AnnF TypeInfo TermF) var
tt
  CubeFlipT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope FS (AnnF TypeInfo TermF) var
tt
  CubeUnflipT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope FS (AnnF TypeInfo TermF) var
tt

  -- tope layer constants
  TopeTopT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt
  TopeBottomT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt

  -- tope layer with computation
  TopeAndT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope FS (AnnF TypeInfo TermF) var
tt
  TopeOrT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope FS (AnnF TypeInfo TermF) var
tt
  TopeEQT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope FS (AnnF TypeInfo TermF) var
tt
  TopeLEQT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope FS (AnnF TypeInfo TermF) var
tt
  TopeInvT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope FS (AnnF TypeInfo TermF) var
tt
  TopeUninvT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope FS (AnnF TypeInfo TermF) var
tt

  -- type layer constants
  ReflT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty Maybe
  (FS (AnnF TypeInfo TermF) var,
   Maybe (FS (AnnF TypeInfo TermF) var))
_x -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (FS (AnnF TypeInfo TermF) var)
-> Maybe
     (FS (AnnF TypeInfo TermF) var,
      Maybe (FS (AnnF TypeInfo TermF) var))
-> FS (AnnF TypeInfo TermF) var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> Maybe (FS (AnnF ann TermF) a, Maybe (FS (AnnF ann TermF) a))
-> FS (AnnF ann TermF) a
ReflT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty Maybe
  (FS (AnnF TypeInfo TermF) var,
   Maybe (FS (AnnF TypeInfo TermF) var))
forall a. Maybe a
Nothing)
  RecBottomT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt
  TypeUnitT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt
  UnitT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt

  -- type ascriptions are ignored, since we already have a typechecked term
  TypeAscT TypeInfo (FS (AnnF TypeInfo TermF) var)
_ty FS (AnnF TypeInfo TermF) var
term FS (AnnF TypeInfo TermF) var
_ty' -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
term

  -- now we are in the type layer
  FS (AnnF TypeInfo TermF) var
_ -> do
    FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf FS (AnnF TypeInfo TermF) var
tt TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> (FS (AnnF TypeInfo TermF) var
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         (Maybe (FS (AnnF TypeInfo TermF) var)))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe (FS (AnnF TypeInfo TermF) var))
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FS (AnnF TypeInfo TermF) var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe (FS (AnnF TypeInfo TermF) var))
forall var.
Eq var =>
TermT var -> TypeCheck var (Maybe (TermT var))
tryRestriction ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (Maybe (FS (AnnF TypeInfo TermF) var))
-> (Maybe (FS (AnnF TypeInfo TermF) var)
    -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just FS (AnnF TypeInfo TermF) var
tt' -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
tt'
        Maybe (FS (AnnF TypeInfo TermF) var)
Nothing -> case FS (AnnF TypeInfo TermF) var
tt of
          -- a hole is opaque: it never reduces, it is already a normal form
          HoleT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt
          t :: FS (AnnF TypeInfo TermF) var
t@(Pure var
var) ->
            var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe (FS (AnnF TypeInfo TermF) var))
forall var. Eq var => var -> TypeCheck var (Maybe (TermT var))
valueOfVar var
var ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (Maybe (FS (AnnF TypeInfo TermF) var))
-> (Maybe (FS (AnnF TypeInfo TermF) var)
    -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Maybe (FS (AnnF TypeInfo TermF) var)
Nothing   -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
t
              Just FS (AnnF TypeInfo TermF) var
term -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
term

          TypeFunT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty Binder
orig TModality
md FS (AnnF TypeInfo TermF) var
param Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope Scope (FS (AnnF TypeInfo TermF)) var
ret -> do
            param' <- TModality
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
md (TypeCheck var (FS (AnnF TypeInfo TermF) var)
 -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b. (a -> b) -> a -> b
$ FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
param
            enterScope orig md param' $ do
              mtope' <- traverse nfT mtope
              maybe id localTope mtope' $
                TypeFunT ty orig md param' mtope' <$> nfT ret
          AppT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty FS (AnnF TypeInfo TermF) var
f FS (AnnF TypeInfo TermF) var
x ->
            FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT FS (AnnF TypeInfo TermF) var
f TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> (FS (AnnF TypeInfo TermF) var
    -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              LambdaT TypeInfo (FS (AnnF TypeInfo TermF) var)
_ty Binder
_orig Maybe
  (TModality, FS (AnnF TypeInfo TermF) var,
   Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
_arg Scope (FS (AnnF TypeInfo TermF)) var
body ->
                FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT (FS (AnnF TypeInfo TermF) var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> FS (AnnF TypeInfo TermF) var
forall var.
TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
substituteT FS (AnnF TypeInfo TermF) var
x Scope (FS (AnnF TypeInfo TermF)) var
body)
              FS (AnnF TypeInfo TermF) var
f' -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf FS (AnnF TypeInfo TermF) var
f' TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> (FS (AnnF TypeInfo TermF) var
    -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                TypeFunT TypeInfo (FS (AnnF TypeInfo TermF) var)
_ty Binder
_orig TModality
md FS (AnnF TypeInfo TermF) var
_param (Just Scope (FS (AnnF TypeInfo TermF)) var
tope) UniverseTopeT{} -> do
                  x' <- TModality
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
md (TypeCheck var (FS (AnnF TypeInfo TermF) var)
 -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b. (a -> b) -> a -> b
$ FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
x
                  topeAndT
                    <$> pure (AppT ty f' x')
                    <*> nfT (substituteT x' tope)
                FS (AnnF TypeInfo TermF) var
_ -> TypeInfo (FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
AppT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty (FS (AnnF TypeInfo TermF) var
 -> FS (AnnF TypeInfo TermF) var -> FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (FS (AnnF TypeInfo TermF) var -> FS (AnnF TypeInfo TermF) var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
f' ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (FS (AnnF TypeInfo TermF) var -> FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (a -> b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
x
          LetT TypeInfo (FS (AnnF TypeInfo TermF) var)
_ty Binder
_orig Maybe (FS (AnnF TypeInfo TermF) var)
_mparam FS (AnnF TypeInfo TermF) var
val Scope (FS (AnnF TypeInfo TermF)) var
body ->
            FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT (FS (AnnF TypeInfo TermF) var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> FS (AnnF TypeInfo TermF) var
forall var.
TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
substituteT FS (AnnF TypeInfo TermF) var
val Scope (FS (AnnF TypeInfo TermF)) var
body)
          LetModT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty Binder
orig TModality
app TModality
inn Maybe (FS (AnnF TypeInfo TermF) var)
mparam FS (AnnF TypeInfo TermF) var
val Scope (FS (AnnF TypeInfo TermF)) var
body -> do
            (TModality
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
app (TypeCheck var (FS (AnnF TypeInfo TermF) var)
 -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b. (a -> b) -> a -> b
$ FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT FS (AnnF TypeInfo TermF) var
val) TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> (FS (AnnF TypeInfo TermF) var
    -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              ModAppT TypeInfo (FS (AnnF TypeInfo TermF) var)
_ TModality
md FS (AnnF TypeInfo TermF) var
t | TModality
md TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
== TModality
inn -> do
                val' <- TModality
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
md (TypeCheck var (FS (AnnF TypeInfo TermF) var)
 -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b. (a -> b) -> a -> b
$ FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
t
                nfT (substituteT val' body)
              FS (AnnF TypeInfo TermF) var
b' | TModality -> Bool
forall m. ModeTheory m => m -> Bool
isRA TModality
inn -> do
                bty <- FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf FS (AnnF TypeInfo TermF) var
b' TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> (FS (AnnF TypeInfo TermF) var
    -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  TypeModalT TypeInfo (FS (AnnF TypeInfo TermF) var)
_ TModality
_ FS (AnnF TypeInfo TermF) var
t -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
t
                  FS (AnnF TypeInfo TermF) var
_ -> String -> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a. String -> a
panicImpossible String
"not modal in letmod"
                nfT (substituteT (modExtractT bty app inn b') body)
              FS (AnnF TypeInfo TermF) var
b' -> do
                bty <- FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf FS (AnnF TypeInfo TermF) var
b' TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> (FS (AnnF TypeInfo TermF) var
    -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  TypeModalT TypeInfo (FS (AnnF TypeInfo TermF) var)
_ TModality
_ FS (AnnF TypeInfo TermF) var
t -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
t
                  FS (AnnF TypeInfo TermF) var
_ -> String -> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a. String -> a
panicImpossible String
"not modal in letmod"
                val' <- enterModality app $ nfT b'
                body' <- enterScope orig (comp app inn) bty $ nfT body
                pure (LetModT ty orig app inn mparam val' body')
          LambdaT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty Binder
orig Maybe
  (TModality, FS (AnnF TypeInfo TermF) var,
   Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
_mparam Scope (FS (AnnF TypeInfo TermF)) var
body -> do
            case FS (AnnF TypeInfo TermF) var -> FS (AnnF TypeInfo TermF) var
forall var. TermT var -> TermT var
stripTypeRestrictions (TypeInfo (FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var
forall term. TypeInfo term -> term
infoType TypeInfo (FS (AnnF TypeInfo TermF) var)
ty) of
              TypeFunT TypeInfo (FS (AnnF TypeInfo TermF) var)
_ty Binder
_orig TModality
md FS (AnnF TypeInfo TermF) var
param Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope Scope (FS (AnnF TypeInfo TermF)) var
_ret -> do
                param' <- TModality
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
md (TypeCheck var (FS (AnnF TypeInfo TermF) var)
 -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b. (a -> b) -> a -> b
$ FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
param
                enterScope orig md param' $ do
                  mtope' <- traverse nfT mtope
                  maybe id localTope mtope' $
                    LambdaT ty orig (Just (md, param', mtope')) <$> nfT body
              FS (AnnF TypeInfo TermF) var
_ -> String -> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a. String -> a
panicImpossible String
"lambda with a non-function type"


          TypeSigmaT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty Binder
orig TModality
md FS (AnnF TypeInfo TermF) var
a Scope (FS (AnnF TypeInfo TermF)) var
b -> do
            a' <- TModality
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
md (TypeCheck var (FS (AnnF TypeInfo TermF) var)
 -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b. (a -> b) -> a -> b
$ FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
a
            enterScope orig md a' $ do
              TypeSigmaT ty orig md a' <$> nfT b
          PairT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty FS (AnnF TypeInfo TermF) var
l FS (AnnF TypeInfo TermF) var
r -> TypeInfo (FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
PairT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty (FS (AnnF TypeInfo TermF) var
 -> FS (AnnF TypeInfo TermF) var -> FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (FS (AnnF TypeInfo TermF) var -> FS (AnnF TypeInfo TermF) var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
l ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (FS (AnnF TypeInfo TermF) var -> FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (a -> b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
r
          FirstT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty FS (AnnF TypeInfo TermF) var
t ->
            FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT FS (AnnF TypeInfo TermF) var
t TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> (FS (AnnF TypeInfo TermF) var
    -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              PairT TypeInfo (FS (AnnF TypeInfo TermF) var)
_ FS (AnnF TypeInfo TermF) var
l FS (AnnF TypeInfo TermF) var
_r -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
l
              FS (AnnF TypeInfo TermF) var
t'           -> TypeInfo (FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var -> FS (AnnF TypeInfo TermF) var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a -> FS (AnnF ann TermF) a
FirstT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty (FS (AnnF TypeInfo TermF) var -> FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
t'
          SecondT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty FS (AnnF TypeInfo TermF) var
t ->
            FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT FS (AnnF TypeInfo TermF) var
t TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> (FS (AnnF TypeInfo TermF) var
    -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              PairT TypeInfo (FS (AnnF TypeInfo TermF) var)
_ FS (AnnF TypeInfo TermF) var
_l FS (AnnF TypeInfo TermF) var
r -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
r
              FS (AnnF TypeInfo TermF) var
t'           -> TypeInfo (FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var -> FS (AnnF TypeInfo TermF) var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a -> FS (AnnF ann TermF) a
SecondT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty (FS (AnnF TypeInfo TermF) var -> FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
t'

          TypeIdT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty FS (AnnF TypeInfo TermF) var
x Maybe (FS (AnnF TypeInfo TermF) var)
_tA FS (AnnF TypeInfo TermF) var
y -> TypeInfo (FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var
-> Maybe (FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a
-> Maybe (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
TypeIdT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty (FS (AnnF TypeInfo TermF) var
 -> Maybe (FS (AnnF TypeInfo TermF) var)
 -> FS (AnnF TypeInfo TermF) var
 -> FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe (FS (AnnF TypeInfo TermF) var)
      -> FS (AnnF TypeInfo TermF) var -> FS (AnnF TypeInfo TermF) var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
x ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (Maybe (FS (AnnF TypeInfo TermF) var)
   -> FS (AnnF TypeInfo TermF) var -> FS (AnnF TypeInfo TermF) var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe (FS (AnnF TypeInfo TermF) var))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (FS (AnnF TypeInfo TermF) var -> FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (a -> b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (FS (AnnF TypeInfo TermF) var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe (FS (AnnF TypeInfo TermF) var))
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (FS (AnnF TypeInfo TermF) var)
forall a. Maybe a
Nothing ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (FS (AnnF TypeInfo TermF) var -> FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (a -> b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
y
          IdJT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty FS (AnnF TypeInfo TermF) var
tA FS (AnnF TypeInfo TermF) var
a FS (AnnF TypeInfo TermF) var
tC FS (AnnF TypeInfo TermF) var
d FS (AnnF TypeInfo TermF) var
x FS (AnnF TypeInfo TermF) var
p ->
            FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT FS (AnnF TypeInfo TermF) var
p TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> (FS (AnnF TypeInfo TermF) var
    -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              ReflT{} -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
d
              FS (AnnF TypeInfo TermF) var
p' -> TypeInfo (FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
IdJT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty (FS (AnnF TypeInfo TermF) var
 -> FS (AnnF TypeInfo TermF) var
 -> FS (AnnF TypeInfo TermF) var
 -> FS (AnnF TypeInfo TermF) var
 -> FS (AnnF TypeInfo TermF) var
 -> FS (AnnF TypeInfo TermF) var
 -> FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (FS (AnnF TypeInfo TermF) var
      -> FS (AnnF TypeInfo TermF) var
      -> FS (AnnF TypeInfo TermF) var
      -> FS (AnnF TypeInfo TermF) var
      -> FS (AnnF TypeInfo TermF) var
      -> FS (AnnF TypeInfo TermF) var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
tA ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (FS (AnnF TypeInfo TermF) var
   -> FS (AnnF TypeInfo TermF) var
   -> FS (AnnF TypeInfo TermF) var
   -> FS (AnnF TypeInfo TermF) var
   -> FS (AnnF TypeInfo TermF) var
   -> FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (FS (AnnF TypeInfo TermF) var
      -> FS (AnnF TypeInfo TermF) var
      -> FS (AnnF TypeInfo TermF) var
      -> FS (AnnF TypeInfo TermF) var
      -> FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (a -> b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
a ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (FS (AnnF TypeInfo TermF) var
   -> FS (AnnF TypeInfo TermF) var
   -> FS (AnnF TypeInfo TermF) var
   -> FS (AnnF TypeInfo TermF) var
   -> FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (FS (AnnF TypeInfo TermF) var
      -> FS (AnnF TypeInfo TermF) var
      -> FS (AnnF TypeInfo TermF) var
      -> FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (a -> b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
tC ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (FS (AnnF TypeInfo TermF) var
   -> FS (AnnF TypeInfo TermF) var
   -> FS (AnnF TypeInfo TermF) var
   -> FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (FS (AnnF TypeInfo TermF) var
      -> FS (AnnF TypeInfo TermF) var -> FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (a -> b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
d ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (FS (AnnF TypeInfo TermF) var
   -> FS (AnnF TypeInfo TermF) var -> FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (FS (AnnF TypeInfo TermF) var -> FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (a -> b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
x ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (FS (AnnF TypeInfo TermF) var -> FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (a -> b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
p'

          RecOrT TypeInfo (FS (AnnF TypeInfo TermF) var)
_ty [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
rs -> do
            let go :: [(TermT var, a)]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe a)
go [] = Maybe a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe a)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
                go ((TermT var
tope, a
tt') : [(TermT var, a)]
rs') = do
                  TermT var -> TypeCheck var Bool
forall var. Eq var => TermT var -> TypeCheck var Bool
checkTope TermT var
tope TypeCheck var Bool
-> (Bool
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         (Maybe a))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe a)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    Bool
True  -> Maybe a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe a)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Maybe a
forall a. a -> Maybe a
Just a
tt')
                    Bool
False -> [(TermT var, a)]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe a)
go [(TermT var, a)]
rs'
            [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe (FS (AnnF TypeInfo TermF) var))
forall {var} {a}.
Eq var =>
[(TermT var, a)]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe a)
go [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
rs ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (Maybe (FS (AnnF TypeInfo TermF) var))
-> (Maybe (FS (AnnF TypeInfo TermF) var)
    -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Just FS (AnnF TypeInfo TermF) var
tt' -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
tt'
              Maybe (FS (AnnF TypeInfo TermF) var)
Nothing
                | [FS (AnnF TypeInfo TermF) var
tt'] <- [FS (AnnF TypeInfo TermF) var] -> [FS (AnnF TypeInfo TermF) var]
forall a. Eq a => [a] -> [a]
nubTermT (((FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)
 -> FS (AnnF TypeInfo TermF) var)
-> [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
-> [FS (AnnF TypeInfo TermF) var]
forall a b. (a -> b) -> [a] -> [b]
map (FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var
forall a b. (a, b) -> b
snd [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
rs) -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
tt'
                | Bool
otherwise -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FS (AnnF TypeInfo TermF) var
tt
          TypeModalT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty TModality
md FS (AnnF TypeInfo TermF) var
b -> do
            b' <- TModality
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
md (TypeCheck var (FS (AnnF TypeInfo TermF) var)
 -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b. (a -> b) -> a -> b
$ FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
b
            pure (TypeModalT ty md b')
          ModAppT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty TModality
md FS (AnnF TypeInfo TermF) var
b -> do
            (TModality
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
md (TypeCheck var (FS (AnnF TypeInfo TermF) var)
 -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b. (a -> b) -> a -> b
$ FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT FS (AnnF TypeInfo TermF) var
b) TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> (FS (AnnF TypeInfo TermF) var
    -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              ModExtractT TypeInfo (FS (AnnF TypeInfo TermF) var)
_ TModality
app TModality
inn FS (AnnF TypeInfo TermF) var
t | TModality
inn TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
== TModality
md -> TModality
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality (TModality -> TModality -> TModality
forall m. ModeTheory m => m -> m -> m
comp TModality
app TModality
inn) (TypeCheck var (FS (AnnF TypeInfo TermF) var)
 -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b. (a -> b) -> a -> b
$ FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
t
              FS (AnnF TypeInfo TermF) var
b' -> TypeInfo (FS (AnnF TypeInfo TermF) var)
-> TModality
-> FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> TModality -> FS (AnnF ann TermF) a -> FS (AnnF ann TermF) a
ModAppT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty TModality
md (FS (AnnF TypeInfo TermF) var -> FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TModality
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
md (TypeCheck var (FS (AnnF TypeInfo TermF) var)
 -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b. (a -> b) -> a -> b
$ FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
b')
          ModExtractT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty TModality
app TModality
inn FS (AnnF TypeInfo TermF) var
b -> do
            (TModality
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
app (TypeCheck var (FS (AnnF TypeInfo TermF) var)
 -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b. (a -> b) -> a -> b
$ FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT FS (AnnF TypeInfo TermF) var
b) TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> (FS (AnnF TypeInfo TermF) var
    -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              ModAppT TypeInfo (FS (AnnF TypeInfo TermF) var)
_ TModality
md FS (AnnF TypeInfo TermF) var
t | TModality
inn TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
== TModality
md -> TModality
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality (TModality -> TModality -> TModality
forall m. ModeTheory m => m -> m -> m
comp TModality
app TModality
inn) (TypeCheck var (FS (AnnF TypeInfo TermF) var)
 -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b. (a -> b) -> a -> b
$ FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
t
              FS (AnnF TypeInfo TermF) var
b' -> TypeInfo (FS (AnnF TypeInfo TermF) var)
-> TModality
-> TModality
-> FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> TModality
-> TModality
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
ModExtractT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty TModality
app TModality
inn (FS (AnnF TypeInfo TermF) var -> FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TModality
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
app (TypeCheck var (FS (AnnF TypeInfo TermF) var)
 -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b. (a -> b) -> a -> b
$ FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
b') 
          TypeRestrictedT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty FS (AnnF TypeInfo TermF) var
type_ [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
rs -> do
            rs' <- [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
-> ((FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         (Maybe
            (FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [Maybe
        (FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
rs (((FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)
  -> ReaderT
       (Context var)
       (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
       (Maybe
          (FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)))
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      [Maybe
         (FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)])
-> ((FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         (Maybe
            (FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [Maybe
        (FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
forall a b. (a -> b) -> a -> b
$ \(FS (AnnF TypeInfo TermF) var
tope, FS (AnnF TypeInfo TermF) var
term) -> do
              FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope FS (AnnF TypeInfo TermF) var
tope TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> (FS (AnnF TypeInfo TermF) var
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         (Maybe
            (FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe
        (FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var))
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                TopeBottomT{} -> Maybe (FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe
        (FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var))
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)
forall a. Maybe a
Nothing
                FS (AnnF TypeInfo TermF) var
tope' -> do
                  term' <- FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope FS (AnnF TypeInfo TermF) var
tope' (TypeCheck var (FS (AnnF TypeInfo TermF) var)
 -> TypeCheck var (FS (AnnF TypeInfo TermF) var))
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b. (a -> b) -> a -> b
$
                    FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
term
                  return (Just (tope', term'))
            case catMaybes rs' of
              []   -> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
type_
              [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
rs'' -> TypeInfo (FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var
-> [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
-> FS (AnnF TypeInfo TermF) var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a
-> [(FS (AnnF ann TermF) a, FS (AnnF ann TermF) a)]
-> FS (AnnF ann TermF) a
TypeRestrictedT TypeInfo (FS (AnnF TypeInfo TermF) var)
ty (FS (AnnF TypeInfo TermF) var
 -> [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
 -> FS (AnnF TypeInfo TermF) var)
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     ([(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
      -> FS (AnnF TypeInfo TermF) var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FS (AnnF TypeInfo TermF) var
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) var
type_ ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  ([(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
   -> FS (AnnF TypeInfo TermF) var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
-> TypeCheck var (FS (AnnF TypeInfo TermF) var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (a -> b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
rs''

checkDefinedVar :: VarIdent -> TypeCheck VarIdent ()
checkDefinedVar :: VarIdent
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     ()
checkDefinedVar VarIdent
x = (Context VarIdent -> Maybe (VarInfo VarIdent))
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     (Maybe (VarInfo VarIdent))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (VarIdent
-> [(VarIdent, VarInfo VarIdent)] -> Maybe (VarInfo VarIdent)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup VarIdent
x ([(VarIdent, VarInfo VarIdent)] -> Maybe (VarInfo VarIdent))
-> (Context VarIdent -> [(VarIdent, VarInfo VarIdent)])
-> Context VarIdent
-> Maybe (VarInfo VarIdent)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context VarIdent -> [(VarIdent, VarInfo VarIdent)]
forall var. Context var -> [(var, VarInfo var)]
varInfos) ReaderT
  (Context VarIdent)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
  (Maybe (VarInfo VarIdent))
-> (Maybe (VarInfo VarIdent)
    -> ReaderT
         (Context VarIdent)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
         ())
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     ()
forall a b.
ReaderT
  (Context VarIdent)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
  a
-> (a
    -> ReaderT
         (Context VarIdent)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
         b)
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Maybe (VarInfo VarIdent)
Nothing  -> TypeError VarIdent
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     ()
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError VarIdent
 -> ReaderT
      (Context VarIdent)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
      ())
-> TypeError VarIdent
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     ()
forall a b. (a -> b) -> a -> b
$ VarIdent -> TypeError VarIdent
forall var. var -> TypeError var
TypeErrorUndefined VarIdent
x
  Just VarInfo VarIdent
_ty -> ()
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     ()
forall a.
a
-> ReaderT
     (Context VarIdent)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext VarIdent)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

valueOfVar :: Eq var => var -> TypeCheck var (Maybe (TermT var))
valueOfVar :: forall var. Eq var => var -> TypeCheck var (Maybe (TermT var))
valueOfVar var
x = (Context var -> Maybe (Maybe (TermT var)))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe (Maybe (TermT var)))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (var -> [(var, Maybe (TermT var))] -> Maybe (Maybe (TermT var))
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup var
x ([(var, Maybe (TermT var))] -> Maybe (Maybe (TermT var)))
-> (Context var -> [(var, Maybe (TermT var))])
-> Context var
-> Maybe (Maybe (TermT var))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context var -> [(var, Maybe (TermT var))]
forall var. Context var -> [(var, Maybe (TermT var))]
varValues) ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (Maybe (Maybe (TermT var)))
-> (Maybe (Maybe (TermT var))
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         (Maybe (TermT var)))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe (TermT var))
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Maybe (Maybe (TermT var))
Nothing -> TypeError var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe (TermT var))
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      (Maybe (TermT var)))
-> TypeError var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe (TermT var))
forall a b. (a -> b) -> a -> b
$ var -> TypeError var
forall var. var -> TypeError var
TypeErrorUndefined var
x
  Just Maybe (TermT var)
ty -> Maybe (TermT var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe (TermT var))
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (TermT var)
ty

typeOfVar :: Eq var => var -> TypeCheck var (TermT var)
typeOfVar :: forall var. Eq var => var -> TypeCheck var (TermT var)
typeOfVar var
x = (Context var -> Maybe (TermT var))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe (TermT var))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (var -> [(var, TermT var)] -> Maybe (TermT var)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup var
x ([(var, TermT var)] -> Maybe (TermT var))
-> (Context var -> [(var, TermT var)])
-> Context var
-> Maybe (TermT var)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context var -> [(var, TermT var)]
forall var. Context var -> [(var, TermT var)]
varTypes) ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (Maybe (TermT var))
-> (Maybe (TermT var)
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         (TermT var))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Maybe (TermT var)
Nothing -> TypeError var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var)
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      (TermT var))
-> TypeError var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var)
forall a b. (a -> b) -> a -> b
$ var -> TypeError var
forall var. var -> TypeError var
TypeErrorUndefined var
x
  Just TermT var
ty -> TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return TermT var
ty

modalityOfVar :: Eq var => var -> TypeCheck var (TModality)
modalityOfVar :: forall var. Eq var => var -> TypeCheck var TModality
modalityOfVar var
x = (Context var -> Maybe TModality)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe TModality)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (var -> [(var, TModality)] -> Maybe TModality
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup var
x ([(var, TModality)] -> Maybe TModality)
-> (Context var -> [(var, TModality)])
-> Context var
-> Maybe TModality
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context var -> [(var, TModality)]
forall var. Context var -> [(var, TModality)]
varModalities) ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (Maybe TModality)
-> (Maybe TModality
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         TModality)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     TModality
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Maybe TModality
Nothing -> TypeError var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     TModality
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      TModality)
-> TypeError var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     TModality
forall a b. (a -> b) -> a -> b
$ var -> TypeError var
forall var. var -> TypeError var
TypeErrorUndefined var
x
  Just TModality
m -> TModality
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     TModality
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return TModality
m

locksOfVar :: Eq var => var -> TypeCheck var (TModality)
locksOfVar :: forall var. Eq var => var -> TypeCheck var TModality
locksOfVar var
x = (Context var -> Maybe TModality)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe TModality)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (var -> [(var, TModality)] -> Maybe TModality
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup var
x ([(var, TModality)] -> Maybe TModality)
-> (Context var -> [(var, TModality)])
-> Context var
-> Maybe TModality
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context var -> [(var, TModality)]
forall var. Context var -> [(var, TModality)]
varLocks) ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (Maybe TModality)
-> (Maybe TModality
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         TModality)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     TModality
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Maybe TModality
Nothing -> TypeError var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     TModality
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      TModality)
-> TypeError var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     TModality
forall a b. (a -> b) -> a -> b
$ var -> TypeError var
forall var. var -> TypeError var
TypeErrorUndefined var
x
  Just TModality
m -> TModality
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     TModality
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return TModality
m

isTopLevelVar :: Eq var => var -> TypeCheck var Bool
isTopLevelVar :: forall var. Eq var => var -> TypeCheck var Bool
isTopLevelVar var
x = (Context var -> Maybe Bool)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe Bool)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (var -> [(var, Bool)] -> Maybe Bool
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup var
x ([(var, Bool)] -> Maybe Bool)
-> (Context var -> [(var, Bool)]) -> Context var -> Maybe Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context var -> [(var, Bool)]
forall var. Context var -> [(var, Bool)]
varTopLevels) ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (Maybe Bool)
-> (Maybe Bool
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         Bool)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     Bool
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Maybe Bool
Nothing -> TypeError var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     Bool
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      Bool)
-> TypeError var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     Bool
forall a b. (a -> b) -> a -> b
$ var -> TypeError var
forall var. var -> TypeError var
TypeErrorUndefined var
x
  Just Bool
b -> Bool
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
b

typeOfUncomputed :: Eq var => TermT var -> TypeCheck var (TermT var)
typeOfUncomputed :: forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOfUncomputed = \case
  Pure var
x                     -> var -> TypeCheck var (TermT var)
forall var. Eq var => var -> TypeCheck var (TermT var)
typeOfVar var
x
  Free (AnnF TypeInfo{Maybe (TermT var)
TermT var
infoType :: forall term. TypeInfo term -> term
infoWHNF :: forall term. TypeInfo term -> Maybe term
infoNF :: forall term. TypeInfo term -> Maybe term
infoType :: TermT var
infoWHNF :: Maybe (TermT var)
infoNF :: Maybe (TermT var)
..} TermF (Scope (FS (AnnF TypeInfo TermF)) var) (TermT var)
_) -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
infoType

typeOf :: Eq var => TermT var -> TypeCheck var (TermT var)
typeOf :: forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
t = TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOfUncomputed TermT var
t TypeCheck var (TermT var)
-> (TermT var -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT

unifyTopes :: Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTopes :: forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTopes TermT var
l TermT var
r = do
  equiv <- Bool -> Bool -> Bool
(&&)
    (Bool -> Bool -> Bool)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     Bool
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TermT var -> ModalTope var
forall var. TermT var -> ModalTope var
plainTope TermT var
l] [ModalTope var]
-> TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     Bool
forall var.
Eq var =>
[ModalTope var] -> TermT var -> TypeCheck var Bool
`entailM` TermT var
r
    ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (Bool -> Bool)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     Bool
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     Bool
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (a -> b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [TermT var -> ModalTope var
forall var. TermT var -> ModalTope var
plainTope TermT var
r] [ModalTope var]
-> TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     Bool
forall var.
Eq var =>
[ModalTope var] -> TermT var -> TypeCheck var Bool
`entailM` TermT var
l
  unless equiv $
    issueTypeError (TypeErrorTopesNotEquivalent l r)

inAllSubContexts :: TypeCheck var () -> TypeCheck var () -> TypeCheck var ()
inAllSubContexts :: forall var.
TypeCheck var () -> TypeCheck var () -> TypeCheck var ()
inAllSubContexts TypeCheck var ()
handleSingle TypeCheck var ()
tc = do
  topeSubContexts <- (Context var -> [[ModalTope var]])
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [[ModalTope var]]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context var -> [[ModalTope var]]
forall var. Context var -> [[ModalTope var]]
localTopesNFUnion
  case topeSubContexts of
    [] -> String -> TypeCheck var ()
forall a. String -> a
panicImpossible String
"empty set of alternative contexts"
    [[ModalTope var]
_] -> TypeCheck var ()
handleSingle
    [ModalTope var]
_:[ModalTope var]
_:[[ModalTope var]]
_ -> do
      [[ModalTope var]]
-> ([ModalTope var] -> TypeCheck var ()) -> TypeCheck var ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[ModalTope var]]
topeSubContexts (([ModalTope var] -> TypeCheck var ()) -> TypeCheck var ())
-> ([ModalTope var] -> TypeCheck var ()) -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$ \[ModalTope var]
topes' -> do
        (Context var -> Context var)
-> TypeCheck var () -> TypeCheck var ()
forall a.
(Context var -> Context var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\Context{Bool
[[ModalTope var]]
[VarIdent]
[ModalTope var]
[ScopeInfo var]
[Action var]
Maybe Bool
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: forall var. Context var -> Maybe LocationInfo
hintLemmas :: forall var. Context var -> [VarIdent]
deferHoleMismatches :: forall var. Context var -> Bool
holesAreErrors :: forall var. Context var -> Bool
renderHideTerm :: forall var. Context var -> Bool
renderBackend :: forall var. Context var -> Maybe RenderBackend
covariance :: forall var. Context var -> Covariance
verbosity :: forall var. Context var -> Verbosity
currentCommand :: forall var. Context var -> Maybe Command
actionStack :: forall var. Context var -> [Action var]
localTopesEntailBottom :: forall var. Context var -> Maybe Bool
localTopesNFUnion :: forall var. Context var -> [[ModalTope var]]
localTopesNF :: forall var. Context var -> [ModalTope var]
localTopes :: forall var. Context var -> [ModalTope var]
localScopes :: forall var. Context var -> [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopes :: [ModalTope var]
localTopesNF :: [ModalTope var]
localTopesNFUnion :: [[ModalTope var]]
localTopesEntailBottom :: Maybe Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
renderHideTerm :: Bool
holesAreErrors :: Bool
deferHoleMismatches :: Bool
hintLemmas :: [VarIdent]
..} -> Context
            { localTopes :: [ModalTope var]
localTopes = [ModalTope var]
topes'
            , localTopesNF :: [ModalTope var]
localTopesNF = [ModalTope var]
topes'
            , localTopesNFUnion :: [[ModalTope var]]
localTopesNFUnion = [[ModalTope var]
topes']
            , Bool
[VarIdent]
[ScopeInfo var]
[Action var]
Maybe Bool
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: Maybe LocationInfo
hintLemmas :: [VarIdent]
deferHoleMismatches :: Bool
holesAreErrors :: Bool
renderHideTerm :: Bool
renderBackend :: Maybe RenderBackend
covariance :: Covariance
verbosity :: Verbosity
currentCommand :: Maybe Command
actionStack :: [Action var]
localTopesEntailBottom :: Maybe Bool
localScopes :: [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopesEntailBottom :: Maybe Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
renderHideTerm :: Bool
holesAreErrors :: Bool
deferHoleMismatches :: Bool
hintLemmas :: [VarIdent]
.. }) (TypeCheck var () -> TypeCheck var ())
-> TypeCheck var () -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$
          TypeCheck var ()
tc

unify :: Eq var => Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify :: forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify Maybe (TermT var)
mterm TermT var
expected TermT var
actual = TypeCheck var ()
performUnification TypeCheck var ()
-> (TypeErrorInScopedContext var -> TypeCheck var ())
-> TypeCheck var ()
forall a.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (TypeErrorInScopedContext var
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         a)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \TypeErrorInScopedContext var
typeError -> do
  TypeCheck var () -> TypeCheck var () -> TypeCheck var ()
forall var.
TypeCheck var () -> TypeCheck var () -> TypeCheck var ()
inAllSubContexts (TypeErrorInScopedContext var -> TypeCheck var ()
forall a.
TypeErrorInScopedContext var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError TypeErrorInScopedContext var
typeError) TypeCheck var ()
performUnification
  where
    performUnification :: TypeCheck var ()
performUnification = Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unifyInCurrentContext Maybe (TermT var)
mterm TermT var
expected TermT var
actual

unifyViaDecompose :: Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyViaDecompose :: forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyViaDecompose TermT var
expected TermT var
actual | TermT var
expected TermT var -> TermT var -> Bool
forall a. Eq a => a -> a -> Bool
== TermT var
actual = ()
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     ()
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
unifyViaDecompose (AppT TypeInfo (TermT var)
_ TermT var
f TermT var
x) (AppT TypeInfo (TermT var)
_ TermT var
g TermT var
y) = do
  Maybe (TermT var)
-> TermT var
-> TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     ()
forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify Maybe (TermT var)
forall a. Maybe a
Nothing TermT var
f TermT var
g
  Covariance
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     ()
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     ()
forall var a. Covariance -> TypeCheck var a -> TypeCheck var a
setVariance Covariance
Invariant (ReaderT
   (Context var)
   (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
   ()
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      ())
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     ()
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     ()
forall a b. (a -> b) -> a -> b
$ Maybe (TermT var)
-> TermT var
-> TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     ()
forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify Maybe (TermT var)
forall a. Maybe a
Nothing TermT var
x TermT var
y
unifyViaDecompose TermT var
_ TermT var
_ = TypeError var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     ()
forall var a. TypeError var -> TypeCheck var a
issueTypeError (String -> TypeError var
forall var. String -> TypeError var
TypeErrorOther String
"cannot decompose")

unifyInCurrentContext :: Eq var => Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unifyInCurrentContext :: forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unifyInCurrentContext Maybe (TermT var)
mterm TermT var
expected TermT var
actual = Action var -> TypeCheck var () -> TypeCheck var ()
forall var a.
Eq var =>
Action var -> TypeCheck var a -> TypeCheck var a
performing Action var
action (TypeCheck var () -> TypeCheck var ())
-> TypeCheck var () -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$ do
  inBottom <- TypeCheck var Bool
forall var. Eq var => TypeCheck var Bool
contextEntailsBottom
  unless inBottom $
    unifyViaDecompose expected actual `catchError` \TypeErrorInScopedContext var
_ -> do      -- NOTE: this gives a small, but noticeable speedup
      expectedVal <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
expected
      actualVal <- whnfT actual
      mea <- asks covariance >>= \case
        Covariance
Covariant     -> (TermT var, TermT var) -> Maybe (TermT var, TermT var)
forall a. a -> Maybe a
Just ((TermT var, TermT var) -> Maybe (TermT var, TermT var))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var, TermT var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe (TermT var, TermT var))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (TermT var)
-> TermT var
-> TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var, TermT var)
forall var.
Eq var =>
Maybe (TermT var)
-> TermT var -> TermT var -> TypeCheck var (TermT var, TermT var)
etaMatch Maybe (TermT var)
mterm TermT var
expectedVal TermT var
actualVal
        Covariance
Contravariant -> (TermT var, TermT var) -> Maybe (TermT var, TermT var)
forall a. a -> Maybe a
Just ((TermT var, TermT var) -> Maybe (TermT var, TermT var))
-> ((TermT var, TermT var) -> (TermT var, TermT var))
-> (TermT var, TermT var)
-> Maybe (TermT var, TermT var)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TermT var, TermT var) -> (TermT var, TermT var)
forall a b. (a, b) -> (b, a)
swap ((TermT var, TermT var) -> Maybe (TermT var, TermT var))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var, TermT var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe (TermT var, TermT var))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (TermT var)
-> TermT var
-> TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var, TermT var)
forall var.
Eq var =>
Maybe (TermT var)
-> TermT var -> TermT var -> TypeCheck var (TermT var, TermT var)
etaMatch Maybe (TermT var)
mterm TermT var
actualVal TermT var
expectedVal
        Covariance
Invariant     -> Verbosity
-> String
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe (TermT var, TermT var))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe (TermT var, TermT var))
forall var a.
Verbosity -> String -> TypeCheck var a -> TypeCheck var a
traceTypeCheck Verbosity
Debug String
"invariant" (ReaderT
   (Context var)
   (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
   (Maybe (TermT var, TermT var))
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      (Maybe (TermT var, TermT var)))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe (TermT var, TermT var))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe (TermT var, TermT var))
forall a b. (a -> b) -> a -> b
$ do
          -- FIXME: inefficient
          Verbosity -> String -> TypeCheck var () -> TypeCheck var ()
forall var a.
Verbosity -> String -> TypeCheck var a -> TypeCheck var a
traceTypeCheck Verbosity
Debug String
"invariant->covariant" (TypeCheck var () -> TypeCheck var ())
-> TypeCheck var () -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$
            Covariance -> TypeCheck var () -> TypeCheck var ()
forall var a. Covariance -> TypeCheck var a -> TypeCheck var a
setVariance Covariance
Covariant     (TypeCheck var () -> TypeCheck var ())
-> TypeCheck var () -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$ Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unifyInCurrentContext Maybe (TermT var)
mterm TermT var
expectedVal TermT var
actualVal
          Verbosity -> String -> TypeCheck var () -> TypeCheck var ()
forall var a.
Verbosity -> String -> TypeCheck var a -> TypeCheck var a
traceTypeCheck Verbosity
Debug String
"invariant->contravariant" (TypeCheck var () -> TypeCheck var ())
-> TypeCheck var () -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$
            Covariance -> TypeCheck var () -> TypeCheck var ()
forall var a. Covariance -> TypeCheck var a -> TypeCheck var a
setVariance Covariance
Contravariant (TypeCheck var () -> TypeCheck var ())
-> TypeCheck var () -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$ Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unifyInCurrentContext Maybe (TermT var)
mterm TermT var
expectedVal TermT var
actualVal
          Maybe (TermT var, TermT var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe (TermT var, TermT var))
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (TermT var, TermT var)
forall a. Maybe a
Nothing
      case mea of
        Maybe (TermT var, TermT var)
Nothing -> () -> TypeCheck var ()
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        -- A hole (lenient mode) stands for a term of the expected type, so it
        -- unifies with anything; accept it instead of falling through to the
        -- dispatch below (which would panic on an unexpected term).
        Just (TermT var
expected', TermT var
actual') | TermT var -> Bool
forall var. TermT var -> Bool
isHoleT TermT var
expected' Bool -> Bool -> Bool
|| TermT var -> Bool
forall var. TermT var -> Bool
isHoleT TermT var
actual' -> () -> TypeCheck var ()
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just (TermT var
expected', TermT var
actual') ->
          Bool -> TypeCheck var () -> TypeCheck var ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TermT var
expected' TermT var -> TermT var -> Bool
forall a. Eq a => a -> a -> Bool
== TermT var
actual') (TypeCheck var () -> TypeCheck var ())
-> TypeCheck var () -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$ do  -- NOTE: this gives a small, but noticeable speedup
            case TermT var
actual' of
              RecBottomT{} -> () -> TypeCheck var ()
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              RecOrT TypeInfo (TermT var)
_ty [(TermT var, TermT var)]
rs' ->
                case TermT var
expected' of
                  RecOrT TypeInfo (TermT var)
_ty [(TermT var, TermT var)]
rs -> [TypeCheck var ()] -> TypeCheck var ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([TypeCheck var ()] -> TypeCheck var ())
-> [TypeCheck var ()] -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$
                    (TermT var, TermT var)
-> (TermT var, TermT var) -> TypeCheck var ()
forall var.
Eq var =>
(TermT var, TermT var)
-> (TermT var, TermT var) -> TypeCheck var ()
checkCoherence ((TermT var, TermT var)
 -> (TermT var, TermT var) -> TypeCheck var ())
-> [(TermT var, TermT var)]
-> [(TermT var, TermT var) -> TypeCheck var ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TermT var, TermT var)]
rs [(TermT var, TermT var) -> TypeCheck var ()]
-> [(TermT var, TermT var)] -> [TypeCheck var ()]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [(TermT var, TermT var)]
rs'
                  TermT var
_ -> do
                    [(TermT var, TermT var)]
-> ((TermT var, TermT var) -> TypeCheck var ()) -> TypeCheck var ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(TermT var, TermT var)]
rs' (((TermT var, TermT var) -> TypeCheck var ()) -> TypeCheck var ())
-> ((TermT var, TermT var) -> TypeCheck var ()) -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$ \(TermT var
tope, TermT var
term) ->
                      TermT var -> TypeCheck var () -> TypeCheck var ()
forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope TermT var
tope (TypeCheck var () -> TypeCheck var ())
-> TypeCheck var () -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$
                        TermT var -> TermT var -> TypeCheck var ()
forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms TermT var
expected' TermT var
term
              TermT var
_ -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
expected' TypeCheck var (TermT var)
-> (TermT var -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TypeCheck var (TermT var)
-> (TermT var -> TypeCheck var ()) -> TypeCheck var ()
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                UniverseCubeT{} -> TermT var -> TypeCheck var ()
forall var. Eq var => TermT var -> TypeCheck var ()
contextEntails (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
expected' TermT var
actual')
                TermT var
_ -> do
                  -- A hole stands for a term of the expected type, so a
                  -- unification that would otherwise fail is deferred when either
                  -- side still contains an (unfilled) hole — including one nested
                  -- in a larger term, e.g. @f ?@ checked against an extension-type
                  -- boundary. The hole may also sit in the tope context rather
                  -- than the terms: a hole standing for a whole shape point makes
                  -- the enclosing 'recOR' split over hole-dependent faces, and a
                  -- branch reduction can drop the hole from the terms while the
                  -- assumed face (e.g. @π₁ ? ≤ π₂ ?@) still mentions it. Such a
                  -- branch is only entered because the hole is unfilled, so a
                  -- mismatch under it is deferred too. 'structuralHoleUnify' turns
                  -- this off, keeping a structural mismatch around a hole an
                  -- error. Lazy: only runs on the failure path.
                  defer <- (Context var -> Bool) -> TypeCheck var Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context var -> Bool
forall var. Context var -> Bool
deferHoleMismatches
                  topeContextHasHole <- asks (any (containsHole . tTope) . localTopes)
                  let def = Bool -> TypeCheck var () -> TypeCheck var ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TermT var
expected' TermT var -> TermT var -> Bool
forall a. Eq a => a -> a -> Bool
== TermT var
actual') TypeCheck var ()
err
                      holePresent = Bool
defer Bool -> Bool -> Bool
&&
                        (TermT var -> Bool
forall var. TermT var -> Bool
containsHole TermT var
expected' Bool -> Bool -> Bool
|| TermT var -> Bool
forall var. TermT var -> Bool
containsHole TermT var
actual' Bool -> Bool -> Bool
|| Bool
topeContextHasHole)
                      err
                        | Bool
holePresent = () -> TypeCheck var ()
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        | Bool
otherwise =
                            case Maybe (TermT var)
mterm of
                              Maybe (TermT var)
Nothing   -> TypeError var -> TypeCheck var ()
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TermT var -> TermT var -> TypeError var
forall var. TermT var -> TermT var -> TypeError var
TypeErrorUnifyTerms TermT var
expected' TermT var
actual')
                              Just TermT var
term -> TypeError var -> TypeCheck var ()
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TermT var -> TermT var -> TermT var -> TypeError var
forall var. TermT var -> TermT var -> TermT var -> TypeError var
TypeErrorUnify TermT var
term TermT var
expected' TermT var
actual')
                      errS
                        | Bool
holePresent = ()
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     ()
forall a.
a
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        | Bool
otherwise = do
                            let expectedS :: FS (AnnF TypeInfo TermF) (Inc var)
expectedS = var -> Inc var
forall var. var -> Inc var
S (var -> Inc var) -> TermT var -> FS (AnnF TypeInfo TermF) (Inc var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
expected'
                                actualS :: FS (AnnF TypeInfo TermF) (Inc var)
actualS = var -> Inc var
forall var. var -> Inc var
S (var -> Inc var) -> TermT var -> FS (AnnF TypeInfo TermF) (Inc var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
actual'
                            case Maybe (TermT var)
mterm of
                              Maybe (TermT var)
Nothing   -> TypeError (Inc var)
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     ()
forall var a. TypeError var -> TypeCheck var a
issueTypeError (FS (AnnF TypeInfo TermF) (Inc var)
-> FS (AnnF TypeInfo TermF) (Inc var) -> TypeError (Inc var)
forall var. TermT var -> TermT var -> TypeError var
TypeErrorUnifyTerms FS (AnnF TypeInfo TermF) (Inc var)
expectedS FS (AnnF TypeInfo TermF) (Inc var)
actualS)
                              Just TermT var
term -> TypeError (Inc var)
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     ()
forall var a. TypeError var -> TypeCheck var a
issueTypeError (FS (AnnF TypeInfo TermF) (Inc var)
-> FS (AnnF TypeInfo TermF) (Inc var)
-> FS (AnnF TypeInfo TermF) (Inc var)
-> TypeError (Inc var)
forall var. TermT var -> TermT var -> TermT var -> TypeError var
TypeErrorUnify (var -> Inc var
forall var. var -> Inc var
S (var -> Inc var) -> TermT var -> FS (AnnF TypeInfo TermF) (Inc var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
term) FS (AnnF TypeInfo TermF) (Inc var)
expectedS FS (AnnF TypeInfo TermF) (Inc var)
actualS)
                  case expected' of
                    Pure{} -> TypeCheck var ()
def

                    UniverseT{} -> TypeCheck var ()
def
                    UniverseCubeT{} -> TypeCheck var ()
def
                    UniverseTopeT{} -> TypeCheck var ()
def

                    TypeUnitT{} -> TypeCheck var ()
def
                    UnitT{} -> () -> TypeCheck var ()
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- Unit always unifies!

                    CubeUnitT{} -> TypeCheck var ()
def
                    CubeUnitStarT{} -> TypeCheck var ()
def
                    Cube2T{} -> TypeCheck var ()
def
                    Cube2_0T{} -> TypeCheck var ()
def
                    Cube2_1T{} -> TypeCheck var ()
def
                    CubeIT{} -> TypeCheck var ()
def
                    CubeI_0T{} -> TypeCheck var ()
def
                    CubeI_1T{} -> TypeCheck var ()
def
                    CubeProductT TypeInfo (TermT var)
_ TermT var
l TermT var
r ->
                      case TermT var
actual' of
                        CubeProductT TypeInfo (TermT var)
_ TermT var
l' TermT var
r' -> do
                          TermT var -> TermT var -> TypeCheck var ()
forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms TermT var
l TermT var
l'
                          TermT var -> TermT var -> TypeCheck var ()
forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms TermT var
r TermT var
r'
                        TermT var
_ -> TypeCheck var ()
err

                    PairT TypeInfo (TermT var)
_ty TermT var
l TermT var
r ->
                      case TermT var
actual' of
                        PairT TypeInfo (TermT var)
_ty' TermT var
l' TermT var
r' -> do
                          TermT var -> TermT var -> TypeCheck var ()
forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms TermT var
l TermT var
l'
                          TermT var -> TermT var -> TypeCheck var ()
forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms TermT var
r TermT var
r'

                        -- one part of eta-expansion for pairs
                        -- FIXME: add symmetric version!
                        TermT var
_ -> TypeCheck var ()
err

                    FirstT TypeInfo (TermT var)
_ty TermT var
t ->
                      case TermT var
actual' of
                        FirstT TypeInfo (TermT var)
_ty' TermT var
t' -> TermT var -> TermT var -> TypeCheck var ()
forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms TermT var
t TermT var
t'
                        TermT var
_              -> TypeCheck var ()
err

                    SecondT TypeInfo (TermT var)
_ty TermT var
t ->
                      case TermT var
actual' of
                        SecondT TypeInfo (TermT var)
_ty' TermT var
t' -> TermT var -> TermT var -> TypeCheck var ()
forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms TermT var
t TermT var
t'
                        TermT var
_               -> TypeCheck var ()
err

                    TopeTopT{}    -> TermT var -> TermT var -> TypeCheck var ()
forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTopes TermT var
expected' TermT var
actual'
                    TopeBottomT{} -> TermT var -> TermT var -> TypeCheck var ()
forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTopes TermT var
expected' TermT var
actual'
                    TopeEQT{}     -> TermT var -> TermT var -> TypeCheck var ()
forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTopes TermT var
expected' TermT var
actual'
                    TopeLEQT{}    -> TermT var -> TermT var -> TypeCheck var ()
forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTopes TermT var
expected' TermT var
actual'
                    TopeAndT{}    -> TermT var -> TermT var -> TypeCheck var ()
forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTopes TermT var
expected' TermT var
actual'
                    TopeOrT{}     -> TermT var -> TermT var -> TypeCheck var ()
forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTopes TermT var
expected' TermT var
actual'

                    RecBottomT{} -> () -> TypeCheck var ()
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- unifies with anything
                    RecOrT TypeInfo (TermT var)
_ty [(TermT var, TermT var)]
rs ->
                      case TermT var
actual' of
                        -- ----------------------------------------------
                        -- IMPORTANT: this pattern matching is redundant,
                        -- but it is not obvious, so
                        -- take care when refactoring!
                        -- ----------------------------------------------
        --                RecOrT _ty rs' -> sequence_ $
        --                  checkCoherence <$> rs <*> rs'
                        -- ----------------------------------------------
                        TermT var
_ -> do
                          [(TermT var, TermT var)]
-> ((TermT var, TermT var) -> TypeCheck var ()) -> TypeCheck var ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(TermT var, TermT var)]
rs (((TermT var, TermT var) -> TypeCheck var ()) -> TypeCheck var ())
-> ((TermT var, TermT var) -> TypeCheck var ()) -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$ \(TermT var
tope, TermT var
term) ->
                            TermT var -> TypeCheck var () -> TypeCheck var ()
forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope TermT var
tope (TypeCheck var () -> TypeCheck var ())
-> TypeCheck var () -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$
                              TermT var -> TermT var -> TypeCheck var ()
forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms TermT var
term TermT var
actual'

                    TypeFunT TypeInfo (TermT var)
_ty Binder
_orig TModality
md TermT var
cube Maybe (FS (AnnF TypeInfo TermF) (Inc var))
mtope FS (AnnF TypeInfo TermF) (Inc var)
ret ->
                      case TermT var
actual' of
                        TypeFunT TypeInfo (TermT var)
_ty' Binder
orig' TModality
md' TermT var
cube' Maybe (FS (AnnF TypeInfo TermF) (Inc var))
mtope' FS (AnnF TypeInfo TermF) (Inc var)
ret' -> do
                          Bool -> TypeCheck var () -> TypeCheck var ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TModality
md TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
/= TModality
md') (TypeCheck var () -> TypeCheck var ())
-> TypeCheck var () -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$
                            TypeError var -> TypeCheck var ()
forall var a. TypeError var -> TypeCheck var a
issueTypeError (String -> TypeError var
forall var. String -> TypeError var
TypeErrorOther (String -> TypeError var) -> String -> TypeError var
forall a b. (a -> b) -> a -> b
$ String
"modality mismatch in function type: expected " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TModality -> String
forall a. Show a => a -> String
show TModality
md String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" but got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TModality -> String
forall a. Show a => a -> String
show TModality
md')
                          TypeCheck var () -> TypeCheck var ()
forall var a. TypeCheck var a -> TypeCheck var a
switchVariance (TypeCheck var () -> TypeCheck var ())
-> TypeCheck var () -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$  -- unifying in the negative position!
                            TermT var -> TermT var -> TypeCheck var ()
forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms TermT var
cube TermT var
cube' -- FIXME: unifyCubes
                          Binder
-> TModality
-> TermT var
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     ()
-> TypeCheck var ()
forall var b.
Binder
-> TModality
-> TermT var
-> TypeCheck (Inc var) b
-> TypeCheck var b
enterScope Binder
orig' TModality
md TermT var
cube' (ReaderT
   (Context (Inc var))
   (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
   ()
 -> TypeCheck var ())
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     ()
-> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$ do
                            case FS (AnnF TypeInfo TermF) (Inc var)
ret' of
                              UniverseTopeT{} -> do
                                -- This is the case for tope families (shapes)
                                --
                                -- (Λ → TOPE) <: (Δ → TOPE)
                                -- since if φ : Λ → TOPE
                                -- then φ ⊢ Δ
                                --
                                -- we DO NOT take tope context Φ into account!
                                expectedTopeNF <- FS (AnnF TypeInfo TermF) (Inc var)
-> Maybe (FS (AnnF TypeInfo TermF) (Inc var))
-> FS (AnnF TypeInfo TermF) (Inc var)
forall a. a -> Maybe a -> a
fromMaybe FS (AnnF TypeInfo TermF) (Inc var)
forall var. TermT var
topeTopT (Maybe (FS (AnnF TypeInfo TermF) (Inc var))
 -> FS (AnnF TypeInfo TermF) (Inc var))
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     (Maybe (FS (AnnF TypeInfo TermF) (Inc var)))
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     (FS (AnnF TypeInfo TermF) (Inc var))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FS (AnnF TypeInfo TermF) (Inc var)
 -> ReaderT
      (Context (Inc var))
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
      (FS (AnnF TypeInfo TermF) (Inc var)))
-> Maybe (FS (AnnF TypeInfo TermF) (Inc var))
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     (Maybe (FS (AnnF TypeInfo TermF) (Inc var)))
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) -> Maybe a -> f (Maybe b)
traverse FS (AnnF TypeInfo TermF) (Inc var)
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     (FS (AnnF TypeInfo TermF) (Inc var))
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT Maybe (FS (AnnF TypeInfo TermF) (Inc var))
mtope
                                actualTopeNF   <- fromMaybe topeTopT <$> traverse nfT mtope'
                                actualEntailsExpected <- [plainTope actualTopeNF] `entailM` expectedTopeNF
                                unless (actualEntailsExpected || containsHole expectedTopeNF || containsHole actualTopeNF) $
                                  issueTypeError (TypeErrorTopeNotSatisfied [actualTopeNF] expectedTopeNF)
                              FS (AnnF TypeInfo TermF) (Inc var)
_ -> do
                                -- this is the case for Π-types and extension types
                                --
                                -- Ξ | Φ | Γ   ⊢   {t : I | φ} → A t   <:   {s : J | ψ} → B s
                                -- when
                                -- Ξ | Φ, ψ ⊢ φ
                                expectedTopeNF <- FS (AnnF TypeInfo TermF) (Inc var)
-> Maybe (FS (AnnF TypeInfo TermF) (Inc var))
-> FS (AnnF TypeInfo TermF) (Inc var)
forall a. a -> Maybe a -> a
fromMaybe FS (AnnF TypeInfo TermF) (Inc var)
forall var. TermT var
topeTopT (Maybe (FS (AnnF TypeInfo TermF) (Inc var))
 -> FS (AnnF TypeInfo TermF) (Inc var))
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     (Maybe (FS (AnnF TypeInfo TermF) (Inc var)))
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     (FS (AnnF TypeInfo TermF) (Inc var))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FS (AnnF TypeInfo TermF) (Inc var)
 -> ReaderT
      (Context (Inc var))
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
      (FS (AnnF TypeInfo TermF) (Inc var)))
-> Maybe (FS (AnnF TypeInfo TermF) (Inc var))
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     (Maybe (FS (AnnF TypeInfo TermF) (Inc var)))
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) -> Maybe a -> f (Maybe b)
traverse FS (AnnF TypeInfo TermF) (Inc var)
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     (FS (AnnF TypeInfo TermF) (Inc var))
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT Maybe (FS (AnnF TypeInfo TermF) (Inc var))
mtope
                                actualTopeNF   <- fromMaybe topeTopT <$> traverse nfT mtope'
                                localTope expectedTopeNF $
                                  contextEntails actualTopeNF
                            case Maybe (TermT var)
mterm of
                              Maybe (TermT var)
Nothing -> FS (AnnF TypeInfo TermF) (Inc var)
-> FS (AnnF TypeInfo TermF) (Inc var)
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     ()
forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms FS (AnnF TypeInfo TermF) (Inc var)
ret FS (AnnF TypeInfo TermF) (Inc var)
ret'
                              Just TermT var
term -> FS (AnnF TypeInfo TermF) (Inc var)
-> FS (AnnF TypeInfo TermF) (Inc var)
-> FS (AnnF TypeInfo TermF) (Inc var)
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     ()
forall var.
Eq var =>
TermT var -> TermT var -> TermT var -> TypeCheck var ()
unifyTypes (FS (AnnF TypeInfo TermF) (Inc var)
-> FS (AnnF TypeInfo TermF) (Inc var)
-> FS (AnnF TypeInfo TermF) (Inc var)
-> FS (AnnF TypeInfo TermF) (Inc var)
forall var. TermT var -> TermT var -> TermT var -> TermT var
appT FS (AnnF TypeInfo TermF) (Inc var)
ret' (var -> Inc var
forall var. var -> Inc var
S (var -> Inc var) -> TermT var -> FS (AnnF TypeInfo TermF) (Inc var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
term) (Inc var -> FS (AnnF TypeInfo TermF) (Inc var)
forall (t :: * -> * -> *) a. a -> FS t a
Pure Inc var
forall var. Inc var
Z)) FS (AnnF TypeInfo TermF) (Inc var)
ret FS (AnnF TypeInfo TermF) (Inc var)
ret'
                        TermT var
_ -> TypeCheck var ()
err

                    TypeSigmaT TypeInfo (TermT var)
_ty Binder
_orig TModality
md TermT var
a FS (AnnF TypeInfo TermF) (Inc var)
b ->
                      case TermT var
actual' of
                        TypeSigmaT TypeInfo (TermT var)
_ty' Binder
orig' TModality
md' TermT var
a' FS (AnnF TypeInfo TermF) (Inc var)
b' -> do
                          Bool -> TypeCheck var () -> TypeCheck var ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TModality
md TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
/= TModality
md') (TypeCheck var () -> TypeCheck var ())
-> TypeCheck var () -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$
                            TypeError var -> TypeCheck var ()
forall var a. TypeError var -> TypeCheck var a
issueTypeError (String -> TypeError var
forall var. String -> TypeError var
TypeErrorOther (String -> TypeError var) -> String -> TypeError var
forall a b. (a -> b) -> a -> b
$ String
"modality mismatch in sigma type: expected " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TModality -> String
forall a. Show a => a -> String
show TModality
md String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" but got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TModality -> String
forall a. Show a => a -> String
show TModality
md')
                          Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify Maybe (TermT var)
forall a. Maybe a
Nothing TermT var
a TermT var
a'
                          Binder
-> TModality
-> TermT var
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     ()
-> TypeCheck var ()
forall var b.
Binder
-> TModality
-> TermT var
-> TypeCheck (Inc var) b
-> TypeCheck var b
enterScope Binder
orig' TModality
md TermT var
a' (ReaderT
   (Context (Inc var))
   (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
   ()
 -> TypeCheck var ())
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     ()
-> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$ Maybe (FS (AnnF TypeInfo TermF) (Inc var))
-> FS (AnnF TypeInfo TermF) (Inc var)
-> FS (AnnF TypeInfo TermF) (Inc var)
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     ()
forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify Maybe (FS (AnnF TypeInfo TermF) (Inc var))
forall a. Maybe a
Nothing FS (AnnF TypeInfo TermF) (Inc var)
b FS (AnnF TypeInfo TermF) (Inc var)
b'
                        TermT var
_ -> TypeCheck var ()
err

                    TypeIdT TypeInfo (TermT var)
_ty TermT var
x Maybe (TermT var)
_tA TermT var
y ->
                      case TermT var
actual' of
                        TypeIdT TypeInfo (TermT var)
_ty' TermT var
x' Maybe (TermT var)
_tA' TermT var
y' -> do
                          -- unify Nothing tA tA' -- TODO: do we need this check?
                          Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify Maybe (TermT var)
forall a. Maybe a
Nothing TermT var
x TermT var
x'
                          Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify Maybe (TermT var)
forall a. Maybe a
Nothing TermT var
y TermT var
y'
                        TermT var
_ -> TypeCheck var ()
err

                    AppT TypeInfo (TermT var)
_ty TermT var
f TermT var
x ->
                      case TermT var
actual' of
                        AppT TypeInfo (TermT var)
_ty' TermT var
f' TermT var
x' -> do
                          Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify Maybe (TermT var)
forall a. Maybe a
Nothing TermT var
f TermT var
f'
                          Covariance -> TypeCheck var () -> TypeCheck var ()
forall var a. Covariance -> TypeCheck var a -> TypeCheck var a
setVariance Covariance
Invariant (TypeCheck var () -> TypeCheck var ())
-> TypeCheck var () -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$
                            Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify Maybe (TermT var)
forall a. Maybe a
Nothing TermT var
x TermT var
x'
                        TermT var
_ -> TypeCheck var ()
err

                    LambdaT TypeInfo (TermT var)
ty Binder
_orig Maybe
  (TModality, TermT var, Maybe (FS (AnnF TypeInfo TermF) (Inc var)))
_mparam FS (AnnF TypeInfo TermF) (Inc var)
body ->
                      case TermT var -> TermT var
forall var. TermT var -> TermT var
stripTypeRestrictions (TypeInfo (TermT var) -> TermT var
forall term. TypeInfo term -> term
infoType TypeInfo (TermT var)
ty) of
                        TypeFunT TypeInfo (TermT var)
_ty Binder
_origF TModality
md TermT var
param Maybe (FS (AnnF TypeInfo TermF) (Inc var))
mtope FS (AnnF TypeInfo TermF) (Inc var)
_ret ->
                          case TermT var
actual' of
                            LambdaT TypeInfo (TermT var)
ty' Binder
orig' Maybe
  (TModality, TermT var, Maybe (FS (AnnF TypeInfo TermF) (Inc var)))
_mparam' FS (AnnF TypeInfo TermF) (Inc var)
body' ->
                              case TermT var -> TermT var
forall var. TermT var -> TermT var
stripTypeRestrictions (TypeInfo (TermT var) -> TermT var
forall term. TypeInfo term -> term
infoType TypeInfo (TermT var)
ty') of
                                TypeFunT TypeInfo (TermT var)
_ty' Binder
_origF' TModality
md' TermT var
param' Maybe (FS (AnnF TypeInfo TermF) (Inc var))
mtope' FS (AnnF TypeInfo TermF) (Inc var)
_ret' -> do
                                  Bool -> TypeCheck var () -> TypeCheck var ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TModality
md TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
/= TModality
md') (TypeCheck var () -> TypeCheck var ())
-> TypeCheck var () -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$
                                    TypeError var -> TypeCheck var ()
forall var a. TypeError var -> TypeCheck var a
issueTypeError (String -> TypeError var
forall var. String -> TypeError var
TypeErrorOther (String -> TypeError var) -> String -> TypeError var
forall a b. (a -> b) -> a -> b
$ String
"modality mismatch in lambda: expected " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TModality -> String
forall a. Show a => a -> String
show TModality
md String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" but got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TModality -> String
forall a. Show a => a -> String
show TModality
md')
                                  Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify Maybe (TermT var)
forall a. Maybe a
Nothing TermT var
param TermT var
param' -- we (should) have already checked this in types!
                                  Binder
-> TModality
-> TermT var
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     ()
-> TypeCheck var ()
forall var b.
Binder
-> TModality
-> TermT var
-> TypeCheck (Inc var) b
-> TypeCheck var b
enterScope Binder
orig' TModality
md TermT var
param (ReaderT
   (Context (Inc var))
   (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
   ()
 -> TypeCheck var ())
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     ()
-> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$ do
                                    case (Maybe (FS (AnnF TypeInfo TermF) (Inc var))
mtope, Maybe (FS (AnnF TypeInfo TermF) (Inc var))
mtope') of
                                      (Just FS (AnnF TypeInfo TermF) (Inc var)
tope, Just FS (AnnF TypeInfo TermF) (Inc var)
tope') -> do
                                        Maybe (FS (AnnF TypeInfo TermF) (Inc var))
-> FS (AnnF TypeInfo TermF) (Inc var)
-> FS (AnnF TypeInfo TermF) (Inc var)
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     ()
forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify Maybe (FS (AnnF TypeInfo TermF) (Inc var))
forall a. Maybe a
Nothing FS (AnnF TypeInfo TermF) (Inc var)
tope FS (AnnF TypeInfo TermF) (Inc var)
tope' -- we (should) have already checked this in types!
                                        FS (AnnF TypeInfo TermF) (Inc var)
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     ()
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     ()
forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope FS (AnnF TypeInfo TermF) (Inc var)
tope (ReaderT
   (Context (Inc var))
   (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
   ()
 -> ReaderT
      (Context (Inc var))
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
      ())
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     ()
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     ()
forall a b. (a -> b) -> a -> b
$ Maybe (FS (AnnF TypeInfo TermF) (Inc var))
-> FS (AnnF TypeInfo TermF) (Inc var)
-> FS (AnnF TypeInfo TermF) (Inc var)
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     ()
forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify Maybe (FS (AnnF TypeInfo TermF) (Inc var))
forall a. Maybe a
Nothing FS (AnnF TypeInfo TermF) (Inc var)
body FS (AnnF TypeInfo TermF) (Inc var)
body'
                                      (Maybe (FS (AnnF TypeInfo TermF) (Inc var))
Nothing, Maybe (FS (AnnF TypeInfo TermF) (Inc var))
Nothing) -> do
                                        Maybe (FS (AnnF TypeInfo TermF) (Inc var))
-> FS (AnnF TypeInfo TermF) (Inc var)
-> FS (AnnF TypeInfo TermF) (Inc var)
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     ()
forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify Maybe (FS (AnnF TypeInfo TermF) (Inc var))
forall a. Maybe a
Nothing FS (AnnF TypeInfo TermF) (Inc var)
body FS (AnnF TypeInfo TermF) (Inc var)
body'
                                      (Maybe (FS (AnnF TypeInfo TermF) (Inc var)),
 Maybe (FS (AnnF TypeInfo TermF) (Inc var)))
_ -> ReaderT
  (Context (Inc var))
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
  ()
errS
                                TermT var
_ -> TypeCheck var ()
err
                            TermT var
_ -> TypeCheck var ()
err
                        TermT var
_ -> TypeCheck var ()
err

                    LetT{} -> String -> TypeCheck var ()
forall a. String -> a
panicImpossible String
"let at the root of WHNF"
                    LetModT TypeInfo (TermT var)
_ Binder
orig TModality
app TModality
inn Maybe (TermT var)
_ TermT var
val FS (AnnF TypeInfo TermF) (Inc var)
body ->
                      case TermT var
actual' of
                        LetModT TypeInfo (TermT var)
_ Binder
_ TModality
app' TModality
inn' Maybe (TermT var)
_ TermT var
val' FS (AnnF TypeInfo TermF) (Inc var)
body'
                          | TModality
app TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
== TModality
app', TModality
inn TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
== TModality
inn' -> do
                            Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify Maybe (TermT var)
forall a. Maybe a
Nothing TermT var
val TermT var
val'
                            bty <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
val TypeCheck var (TermT var)
-> (TermT var -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                              TypeModalT TypeInfo (TermT var)
_ TModality
_ TermT var
t -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
t
                              TermT var
_ -> String -> TypeCheck var (TermT var)
forall a. String -> a
panicImpossible String
"not modal in letmod"
                            enterScope orig (comp app inn) bty $
                              unify Nothing body body'
                        TermT var
_ -> TypeCheck var ()
err

                    ReflT TypeInfo (TermT var)
ty Maybe (TermT var, Maybe (TermT var))
_x | TypeIdT TypeInfo (TermT var)
_ty TermT var
x Maybe (TermT var)
_tA TermT var
y <- TypeInfo (TermT var) -> TermT var
forall term. TypeInfo term -> term
infoType TypeInfo (TermT var)
ty ->
                      case TermT var
actual' of
                        ReflT TypeInfo (TermT var)
ty' Maybe (TermT var, Maybe (TermT var))
_x' | TypeIdT TypeInfo (TermT var)
_ty' TermT var
x' Maybe (TermT var)
_tA' TermT var
y' <- TypeInfo (TermT var) -> TermT var
forall term. TypeInfo term -> term
infoType TypeInfo (TermT var)
ty' -> do
                          -- unify Nothing tA tA' -- TODO: do we need this check?
                          Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify Maybe (TermT var)
forall a. Maybe a
Nothing TermT var
x TermT var
x'
                          Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify Maybe (TermT var)
forall a. Maybe a
Nothing TermT var
y TermT var
y'
                        TermT var
_ -> TypeCheck var ()
err
                    ReflT{} -> String -> TypeCheck var ()
forall a. String -> a
panicImpossible String
"refl with a non-identity type!"

                    IdJT TypeInfo (TermT var)
_ty TermT var
a TermT var
b TermT var
c TermT var
d TermT var
e TermT var
f ->
                      case TermT var
actual' of
                        IdJT TypeInfo (TermT var)
_ty' TermT var
a' TermT var
b' TermT var
c' TermT var
d' TermT var
e' TermT var
f' -> do
                          Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify Maybe (TermT var)
forall a. Maybe a
Nothing TermT var
a TermT var
a'
                          Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify Maybe (TermT var)
forall a. Maybe a
Nothing TermT var
b TermT var
b'
                          Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify Maybe (TermT var)
forall a. Maybe a
Nothing TermT var
c TermT var
c'
                          Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify Maybe (TermT var)
forall a. Maybe a
Nothing TermT var
d TermT var
d'
                          Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify Maybe (TermT var)
forall a. Maybe a
Nothing TermT var
e TermT var
e'
                          Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify Maybe (TermT var)
forall a. Maybe a
Nothing TermT var
f TermT var
f'
                        TermT var
_ -> TypeCheck var ()
err

                    TypeAscT{} -> String -> TypeCheck var ()
forall a. String -> a
panicImpossible String
"type ascription at the root of WHNF"

                    TypeRestrictedT TypeInfo (TermT var)
_ty TermT var
ty [(TermT var, TermT var)]
rs ->
                      case TermT var
actual' of
                        TypeRestrictedT TypeInfo (TermT var)
_ty' TermT var
ty' [(TermT var, TermT var)]
rs' -> do
                          Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify Maybe (TermT var)
mterm TermT var
ty TermT var
ty'
                          [TypeCheck var ()] -> TypeCheck var ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
                            [ TermT var -> TypeCheck var () -> TypeCheck var ()
forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope TermT var
tope (TypeCheck var () -> TypeCheck var ())
-> TypeCheck var () -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$ do
                                -- FIXME: can do less entails checks?
                                TermT var -> TypeCheck var ()
forall var. Eq var => TermT var -> TypeCheck var ()
contextEntails ((TermT var -> TermT var -> TermT var)
-> TermT var -> [TermT var] -> TermT var
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeOrT TermT var
forall var. TermT var
topeBottomT (((TermT var, TermT var) -> TermT var)
-> [(TermT var, TermT var)] -> [TermT var]
forall a b. (a -> b) -> [a] -> [b]
map (TermT var, TermT var) -> TermT var
forall a b. (a, b) -> a
fst [(TermT var, TermT var)]
rs')) -- expected is less specified than actual
                                [(TermT var, TermT var)]
-> ((TermT var, TermT var) -> TypeCheck var ()) -> TypeCheck var ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(TermT var, TermT var)]
rs' (((TermT var, TermT var) -> TypeCheck var ()) -> TypeCheck var ())
-> ((TermT var, TermT var) -> TypeCheck var ()) -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$ \(TermT var
tope', TermT var
term') -> do
                                  TermT var -> TypeCheck var () -> TypeCheck var ()
forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope TermT var
tope' (TypeCheck var () -> TypeCheck var ())
-> TypeCheck var () -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$
                                    Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify Maybe (TermT var)
forall a. Maybe a
Nothing TermT var
term TermT var
term'
                            | (TermT var
tope, TermT var
term) <- [(TermT var, TermT var)]
rs
                            ]
                        TermT var
_ -> TypeCheck var ()
err    -- FIXME: need better unification for restrictions
                    TypeModalT TypeInfo (TermT var)
_ty TModality
m TermT var
ty ->
                      case TermT var
actual' of
                        TypeModalT TypeInfo (TermT var)
_ty' TModality
m' TermT var
ty' -> do
                          Bool -> TypeCheck var () -> TypeCheck var ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TModality
m' TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
/= TModality
m) (TypeCheck var () -> TypeCheck var ())
-> TypeCheck var () -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$ TypeCheck var ()
err
                          TModality -> TypeCheck var () -> TypeCheck var ()
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
m (TypeCheck var () -> TypeCheck var ())
-> TypeCheck var () -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$ Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify Maybe (TermT var)
forall a. Maybe a
Nothing TermT var
ty TermT var
ty'
                        TermT var
_ -> TypeCheck var ()
err
                    ModAppT TypeInfo (TermT var)
_ty TModality
m TermT var
ty ->
                      case TermT var
actual' of
                        ModAppT TypeInfo (TermT var)
_ty' TModality
m' TermT var
ty' -> do
                          Bool -> TypeCheck var () -> TypeCheck var ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TModality
m' TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
/= TModality
m) (TypeCheck var () -> TypeCheck var ())
-> TypeCheck var () -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$ TypeCheck var ()
err
                          TModality -> TypeCheck var () -> TypeCheck var ()
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
m (TypeCheck var () -> TypeCheck var ())
-> TypeCheck var () -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$ Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify Maybe (TermT var)
forall a. Maybe a
Nothing TermT var
ty TermT var
ty'
                        TermT var
_ -> TypeCheck var ()
err
                    ModExtractT TypeInfo (TermT var)
_ty TModality
app TModality
inn TermT var
te ->
                      case TermT var
actual' of
                        ModExtractT TypeInfo (TermT var)
_ty' TModality
app' TModality
inn' TermT var
te' -> do
                          Bool -> TypeCheck var () -> TypeCheck var ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TModality
app' TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
/= TModality
app) (TypeCheck var () -> TypeCheck var ())
-> TypeCheck var () -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$ TypeCheck var ()
err
                          Bool -> TypeCheck var () -> TypeCheck var ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TModality
inn' TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
/= TModality
inn) (TypeCheck var () -> TypeCheck var ())
-> TypeCheck var () -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$ TypeCheck var ()
err
                          TModality -> TypeCheck var () -> TypeCheck var ()
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
app (TypeCheck var () -> TypeCheck var ())
-> TypeCheck var () -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$ Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify Maybe (TermT var)
forall a. Maybe a
Nothing TermT var
te TermT var
te'
                        TermT var
_ -> TypeCheck var ()
err
                    -- defensive: a hole nested anywhere also defers here rather
                    -- than panicking on an otherwise unexpected shape
                    TermT var
_ | Bool
holePresent -> () -> TypeCheck var ()
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    TermT var
_ -> String -> TypeCheck var ()
forall a. String -> a
panicImpossible String
"unexpected term in UNIFY"


  where
    action :: Action var
action = case Maybe (TermT var)
mterm of
               Maybe (TermT var)
Nothing   -> TermT var -> TermT var -> Action var
forall var. TermT var -> TermT var -> Action var
ActionUnifyTerms TermT var
expected TermT var
actual
               Just TermT var
term -> TermT var -> TermT var -> TermT var -> Action var
forall var. TermT var -> TermT var -> TermT var -> Action var
ActionUnify TermT var
term TermT var
expected TermT var
actual

unifyTypes :: Eq var => TermT var -> TermT var -> TermT var -> TypeCheck var ()
unifyTypes :: forall var.
Eq var =>
TermT var -> TermT var -> TermT var -> TypeCheck var ()
unifyTypes = Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify (Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ())
-> (TermT var -> Maybe (TermT var))
-> TermT var
-> TermT var
-> TermT var
-> TypeCheck var ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermT var -> Maybe (TermT var)
forall a. a -> Maybe a
Just

unifyTerms :: Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms :: forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms = Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify Maybe (TermT var)
forall a. Maybe a
Nothing

localTope :: Eq var => TermT var -> TypeCheck var a -> TypeCheck var a
localTope :: forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope TermT var
tope TypeCheck var a
tc = do
  Context{..} <- ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  (Context var)
forall r (m :: * -> *). MonadReader r m => m r
ask
  tope' <- nfTope tope
  let modalTope' = TermT var -> ModalTope var
forall var. TermT var -> ModalTope var
plainTope TermT var
tope'
  -- A small optimisation to help unify terms faster
  let refine = case TermT var
tope' of
        TopeEQT TypeInfo (TermT var)
_ TermT var
x TermT var
y | TermT var
x TermT var -> TermT var -> Bool
forall a. Eq a => a -> a -> Bool
== TermT var
y -> TypeCheck var a -> TypeCheck var a -> TypeCheck var a
forall a b. a -> b -> a
const TypeCheck var a
tc          -- no new information added!
        TermT var
_ | ModalTope var
modalTope' ModalTope var -> [ModalTope var] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ModalTope var]
localTopesNF -> TypeCheck var a -> TypeCheck var a -> TypeCheck var a
forall a b. a -> b -> a
const TypeCheck var a
tc     -- no new information added!
          | Bool
otherwise -> TypeCheck var a -> TypeCheck var a
forall a. a -> a
id
  refine $ do
    entailsBottom <- (modalTope' : localTopesNF) `entailM` topeBottomT
    local (f modalTope' entailsBottom) tc
  where
    f :: ModalTope var -> Bool -> Context var -> Context var
f ModalTope var
tope' Bool
entailsBottom Context{Bool
[[ModalTope var]]
[VarIdent]
[ModalTope var]
[ScopeInfo var]
[Action var]
Maybe Bool
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: forall var. Context var -> Maybe LocationInfo
hintLemmas :: forall var. Context var -> [VarIdent]
deferHoleMismatches :: forall var. Context var -> Bool
holesAreErrors :: forall var. Context var -> Bool
renderHideTerm :: forall var. Context var -> Bool
renderBackend :: forall var. Context var -> Maybe RenderBackend
covariance :: forall var. Context var -> Covariance
verbosity :: forall var. Context var -> Verbosity
currentCommand :: forall var. Context var -> Maybe Command
actionStack :: forall var. Context var -> [Action var]
localTopesEntailBottom :: forall var. Context var -> Maybe Bool
localTopesNFUnion :: forall var. Context var -> [[ModalTope var]]
localTopesNF :: forall var. Context var -> [ModalTope var]
localTopes :: forall var. Context var -> [ModalTope var]
localScopes :: forall var. Context var -> [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopes :: [ModalTope var]
localTopesNF :: [ModalTope var]
localTopesNFUnion :: [[ModalTope var]]
localTopesEntailBottom :: Maybe Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
renderHideTerm :: Bool
holesAreErrors :: Bool
deferHoleMismatches :: Bool
hintLemmas :: [VarIdent]
..} = Context
      { localTopes :: [ModalTope var]
localTopes = TermT var -> ModalTope var
forall var. TermT var -> ModalTope var
plainTope TermT var
tope ModalTope var -> [ModalTope var] -> [ModalTope var]
forall a. a -> [a] -> [a]
: [ModalTope var]
localTopes
      , localTopesNF :: [ModalTope var]
localTopesNF = ModalTope var
tope' ModalTope var -> [ModalTope var] -> [ModalTope var]
forall a. a -> [a] -> [a]
: [ModalTope var]
localTopesNF
      , localTopesNFUnion :: [[ModalTope var]]
localTopesNFUnion = ([ModalTope var] -> [ModalTope var])
-> [[ModalTope var]] -> [[ModalTope var]]
forall a b. (a -> b) -> [a] -> [b]
map [ModalTope var] -> [ModalTope var]
forall a. Eq a => [a] -> [a]
nubTermT
          [ [ModalTope var]
new [ModalTope var] -> [ModalTope var] -> [ModalTope var]
forall a. Semigroup a => a -> a -> a
<> [ModalTope var]
old
          | [ModalTope var]
new <- [ModalTope var] -> [[ModalTope var]]
forall var. Eq var => [ModalTope var] -> [[ModalTope var]]
simplifyLHSwithDisjunctions [ModalTope var
tope']
          , [ModalTope var]
old <- [[ModalTope var]]
localTopesNFUnion ]
      , localTopesEntailBottom :: Maybe Bool
localTopesEntailBottom = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
entailsBottom
      , Bool
[VarIdent]
[ScopeInfo var]
[Action var]
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: Maybe LocationInfo
hintLemmas :: [VarIdent]
deferHoleMismatches :: Bool
holesAreErrors :: Bool
renderHideTerm :: Bool
renderBackend :: Maybe RenderBackend
covariance :: Covariance
verbosity :: Verbosity
currentCommand :: Maybe Command
actionStack :: [Action var]
localScopes :: [ScopeInfo var]
localScopes :: [ScopeInfo var]
actionStack :: [Action var]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
renderHideTerm :: Bool
holesAreErrors :: Bool
deferHoleMismatches :: Bool
hintLemmas :: [VarIdent]
.. }

universeT :: TermT var
universeT :: forall var. TermT var
universeT = (TermT var -> TermT var) -> TermT var -> [TermT var]
forall a. (a -> a) -> a -> [a]
iterate TermT var -> TermT var
forall var. TermT var -> TermT var
f (String -> TermT var
forall a. String -> a
panicImpossible String
msg) [TermT var] -> Int -> TermT var
forall a. HasCallStack => [a] -> Int -> a
!! Int
30
  where
    msg :: String
msg = String
"going too high up the universe levels"
    f :: TermT a -> TermT a
f TermT a
t = TypeInfo (TermT a) -> TermT a
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a) -> FS (AnnF ann TermF) a
UniverseT TypeInfo
      { infoType :: TermT a
infoType = TermT a
t
      , infoNF :: Maybe (TermT a)
infoNF = TermT a -> Maybe (TermT a)
forall a. a -> Maybe a
Just TermT a
forall var. TermT var
universeT
      , infoWHNF :: Maybe (TermT a)
infoWHNF = TermT a -> Maybe (TermT a)
forall a. a -> Maybe a
Just TermT a
forall var. TermT var
universeT }

cubeT :: TermT var
cubeT :: forall var. TermT var
cubeT = TypeInfo (FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a) -> FS (AnnF ann TermF) a
UniverseCubeT TypeInfo
  { infoType :: FS (AnnF TypeInfo TermF) var
infoType = FS (AnnF TypeInfo TermF) var
forall var. TermT var
universeT
  , infoNF :: Maybe (FS (AnnF TypeInfo TermF) var)
infoNF = FS (AnnF TypeInfo TermF) var
-> Maybe (FS (AnnF TypeInfo TermF) var)
forall a. a -> Maybe a
Just FS (AnnF TypeInfo TermF) var
forall var. TermT var
cubeT
  , infoWHNF :: Maybe (FS (AnnF TypeInfo TermF) var)
infoWHNF = FS (AnnF TypeInfo TermF) var
-> Maybe (FS (AnnF TypeInfo TermF) var)
forall a. a -> Maybe a
Just FS (AnnF TypeInfo TermF) var
forall var. TermT var
cubeT }

topeT :: TermT var
topeT :: forall var. TermT var
topeT = TypeInfo (FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a) -> FS (AnnF ann TermF) a
UniverseTopeT TypeInfo
  { infoType :: FS (AnnF TypeInfo TermF) var
infoType = FS (AnnF TypeInfo TermF) var
forall var. TermT var
universeT
  , infoNF :: Maybe (FS (AnnF TypeInfo TermF) var)
infoNF = FS (AnnF TypeInfo TermF) var
-> Maybe (FS (AnnF TypeInfo TermF) var)
forall a. a -> Maybe a
Just FS (AnnF TypeInfo TermF) var
forall var. TermT var
topeT
  , infoWHNF :: Maybe (FS (AnnF TypeInfo TermF) var)
infoWHNF = FS (AnnF TypeInfo TermF) var
-> Maybe (FS (AnnF TypeInfo TermF) var)
forall a. a -> Maybe a
Just FS (AnnF TypeInfo TermF) var
forall var. TermT var
topeT }

topeEQT :: TermT var -> TermT var -> TermT var
topeEQT :: forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
l TermT var
r = TypeInfo (TermT var) -> TermT var -> TermT var -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
TopeEQT TypeInfo (TermT var)
forall {var}. TypeInfo (TermT var)
info TermT var
l TermT var
r
  where
    info :: TypeInfo (TermT var)
info = TypeInfo
      { infoType :: TermT var
infoType = TermT var
forall var. TermT var
topeT
      , infoNF :: Maybe (TermT var)
infoNF = Maybe (TermT var)
forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF = Maybe (TermT var)
forall a. Maybe a
Nothing
      }

topeLEQT :: TermT var -> TermT var -> TermT var
topeLEQT :: forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
l TermT var
r = TypeInfo (TermT var) -> TermT var -> TermT var -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
TopeLEQT TypeInfo (TermT var)
forall {var}. TypeInfo (TermT var)
info TermT var
l TermT var
r
  where
    info :: TypeInfo (TermT var)
info = TypeInfo
      { infoType :: TermT var
infoType = TermT var
forall var. TermT var
topeT
      , infoNF :: Maybe (TermT var)
infoNF = Maybe (TermT var)
forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF = Maybe (TermT var)
forall a. Maybe a
Nothing
      }

topeOrT :: TermT var -> TermT var -> TermT var
topeOrT :: forall var. TermT var -> TermT var -> TermT var
topeOrT TermT var
l TermT var
r = TypeInfo (TermT var) -> TermT var -> TermT var -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
TopeOrT TypeInfo (TermT var)
forall {var}. TypeInfo (TermT var)
info TermT var
l TermT var
r
  where
    info :: TypeInfo (TermT var)
info = TypeInfo
      { infoType :: TermT var
infoType = TermT var
forall var. TermT var
topeT
      , infoNF :: Maybe (TermT var)
infoNF = Maybe (TermT var)
forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF = Maybe (TermT var)
forall a. Maybe a
Nothing
      }

topeAndT :: TermT var -> TermT var -> TermT var
topeAndT :: forall var. TermT var -> TermT var -> TermT var
topeAndT TermT var
l TermT var
r = TypeInfo (TermT var) -> TermT var -> TermT var -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
TopeAndT TypeInfo (TermT var)
forall {var}. TypeInfo (TermT var)
info TermT var
l TermT var
r
  where
    info :: TypeInfo (TermT var)
info = TypeInfo
      { infoType :: TermT var
infoType = TermT var
forall var. TermT var
topeT
      , infoNF :: Maybe (TermT var)
infoNF = Maybe (TermT var)
forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF = Maybe (TermT var)
forall a. Maybe a
Nothing
      }

cubeProductT :: TermT var -> TermT var -> TermT var
cubeProductT :: forall var. TermT var -> TermT var -> TermT var
cubeProductT TermT var
l TermT var
r = TermT var
t
  where
    t :: TermT var
t = TypeInfo (TermT var) -> TermT var -> TermT var -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
CubeProductT TypeInfo (TermT var)
forall {var}. TypeInfo (TermT var)
info TermT var
l TermT var
r
    info :: TypeInfo (TermT var)
info = TypeInfo
      { infoType :: TermT var
infoType  = TermT var
forall var. TermT var
cubeT
      , infoNF :: Maybe (TermT var)
infoNF    = Maybe (TermT var)
forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF  = Maybe (TermT var)
forall a. Maybe a
Nothing
      }

cubeUnitT :: TermT var
cubeUnitT :: forall var. TermT var
cubeUnitT = TypeInfo (FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a) -> FS (AnnF ann TermF) a
CubeUnitT TypeInfo
  { infoType :: FS (AnnF TypeInfo TermF) var
infoType = FS (AnnF TypeInfo TermF) var
forall var. TermT var
cubeT
  , infoNF :: Maybe (FS (AnnF TypeInfo TermF) var)
infoNF = FS (AnnF TypeInfo TermF) var
-> Maybe (FS (AnnF TypeInfo TermF) var)
forall a. a -> Maybe a
Just FS (AnnF TypeInfo TermF) var
forall var. TermT var
cubeUnitT
  , infoWHNF :: Maybe (FS (AnnF TypeInfo TermF) var)
infoWHNF = FS (AnnF TypeInfo TermF) var
-> Maybe (FS (AnnF TypeInfo TermF) var)
forall a. a -> Maybe a
Just FS (AnnF TypeInfo TermF) var
forall var. TermT var
cubeUnitT }

cubeUnitStarT :: TermT var
cubeUnitStarT :: forall var. TermT var
cubeUnitStarT = TypeInfo (FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a) -> FS (AnnF ann TermF) a
CubeUnitStarT TypeInfo
  { infoType :: FS (AnnF TypeInfo TermF) var
infoType = FS (AnnF TypeInfo TermF) var
forall var. TermT var
cubeUnitT
  , infoNF :: Maybe (FS (AnnF TypeInfo TermF) var)
infoNF = FS (AnnF TypeInfo TermF) var
-> Maybe (FS (AnnF TypeInfo TermF) var)
forall a. a -> Maybe a
Just FS (AnnF TypeInfo TermF) var
forall var. TermT var
cubeUnitStarT
  , infoWHNF :: Maybe (FS (AnnF TypeInfo TermF) var)
infoWHNF = FS (AnnF TypeInfo TermF) var
-> Maybe (FS (AnnF TypeInfo TermF) var)
forall a. a -> Maybe a
Just FS (AnnF TypeInfo TermF) var
forall var. TermT var
cubeUnitStarT }

typeUnitT :: TermT var
typeUnitT :: forall var. TermT var
typeUnitT = TypeInfo (FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a) -> FS (AnnF ann TermF) a
TypeUnitT TypeInfo
  { infoType :: FS (AnnF TypeInfo TermF) var
infoType = FS (AnnF TypeInfo TermF) var
forall var. TermT var
universeT
  , infoNF :: Maybe (FS (AnnF TypeInfo TermF) var)
infoNF = FS (AnnF TypeInfo TermF) var
-> Maybe (FS (AnnF TypeInfo TermF) var)
forall a. a -> Maybe a
Just FS (AnnF TypeInfo TermF) var
forall var. TermT var
typeUnitT
  , infoWHNF :: Maybe (FS (AnnF TypeInfo TermF) var)
infoWHNF = FS (AnnF TypeInfo TermF) var
-> Maybe (FS (AnnF TypeInfo TermF) var)
forall a. a -> Maybe a
Just FS (AnnF TypeInfo TermF) var
forall var. TermT var
typeUnitT }

unitT :: TermT var
unitT :: forall var. TermT var
unitT = TypeInfo (FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a) -> FS (AnnF ann TermF) a
UnitT TypeInfo
  { infoType :: FS (AnnF TypeInfo TermF) var
infoType = FS (AnnF TypeInfo TermF) var
forall var. TermT var
typeUnitT
  , infoNF :: Maybe (FS (AnnF TypeInfo TermF) var)
infoNF = FS (AnnF TypeInfo TermF) var
-> Maybe (FS (AnnF TypeInfo TermF) var)
forall a. a -> Maybe a
Just FS (AnnF TypeInfo TermF) var
forall var. TermT var
unitT
  , infoWHNF :: Maybe (FS (AnnF TypeInfo TermF) var)
infoWHNF = FS (AnnF TypeInfo TermF) var
-> Maybe (FS (AnnF TypeInfo TermF) var)
forall a. a -> Maybe a
Just FS (AnnF TypeInfo TermF) var
forall var. TermT var
unitT }

cube2T :: TermT var
cube2T :: forall var. TermT var
cube2T = TypeInfo (FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a) -> FS (AnnF ann TermF) a
Cube2T TypeInfo
  { infoType :: FS (AnnF TypeInfo TermF) var
infoType = FS (AnnF TypeInfo TermF) var
forall var. TermT var
cubeT
  , infoNF :: Maybe (FS (AnnF TypeInfo TermF) var)
infoNF = FS (AnnF TypeInfo TermF) var
-> Maybe (FS (AnnF TypeInfo TermF) var)
forall a. a -> Maybe a
Just FS (AnnF TypeInfo TermF) var
forall var. TermT var
cube2T
  , infoWHNF :: Maybe (FS (AnnF TypeInfo TermF) var)
infoWHNF = FS (AnnF TypeInfo TermF) var
-> Maybe (FS (AnnF TypeInfo TermF) var)
forall a. a -> Maybe a
Just FS (AnnF TypeInfo TermF) var
forall var. TermT var
cube2T }

cube2_0T :: TermT var
cube2_0T :: forall var. TermT var
cube2_0T = TypeInfo (FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a) -> FS (AnnF ann TermF) a
Cube2_0T TypeInfo
  { infoType :: FS (AnnF TypeInfo TermF) var
infoType = FS (AnnF TypeInfo TermF) var
forall var. TermT var
cube2T
  , infoNF :: Maybe (FS (AnnF TypeInfo TermF) var)
infoNF = FS (AnnF TypeInfo TermF) var
-> Maybe (FS (AnnF TypeInfo TermF) var)
forall a. a -> Maybe a
Just FS (AnnF TypeInfo TermF) var
forall var. TermT var
cube2_0T
  , infoWHNF :: Maybe (FS (AnnF TypeInfo TermF) var)
infoWHNF = FS (AnnF TypeInfo TermF) var
-> Maybe (FS (AnnF TypeInfo TermF) var)
forall a. a -> Maybe a
Just FS (AnnF TypeInfo TermF) var
forall var. TermT var
cube2_0T }

cube2_1T :: TermT var
cube2_1T :: forall var. TermT var
cube2_1T = TypeInfo (FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a) -> FS (AnnF ann TermF) a
Cube2_1T TypeInfo
  { infoType :: FS (AnnF TypeInfo TermF) var
infoType = FS (AnnF TypeInfo TermF) var
forall var. TermT var
cube2T
  , infoNF :: Maybe (FS (AnnF TypeInfo TermF) var)
infoNF = FS (AnnF TypeInfo TermF) var
-> Maybe (FS (AnnF TypeInfo TermF) var)
forall a. a -> Maybe a
Just FS (AnnF TypeInfo TermF) var
forall var. TermT var
cube2_1T
  , infoWHNF :: Maybe (FS (AnnF TypeInfo TermF) var)
infoWHNF = FS (AnnF TypeInfo TermF) var
-> Maybe (FS (AnnF TypeInfo TermF) var)
forall a. a -> Maybe a
Just FS (AnnF TypeInfo TermF) var
forall var. TermT var
cube2_1T }

cubeIT :: TermT var
cubeIT :: forall var. TermT var
cubeIT = TypeInfo (FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a) -> FS (AnnF ann TermF) a
CubeIT TypeInfo
  { infoType :: FS (AnnF TypeInfo TermF) var
infoType = FS (AnnF TypeInfo TermF) var
forall var. TermT var
cubeT
  , infoNF :: Maybe (FS (AnnF TypeInfo TermF) var)
infoNF = FS (AnnF TypeInfo TermF) var
-> Maybe (FS (AnnF TypeInfo TermF) var)
forall a. a -> Maybe a
Just FS (AnnF TypeInfo TermF) var
forall var. TermT var
cubeIT
  , infoWHNF :: Maybe (FS (AnnF TypeInfo TermF) var)
infoWHNF = FS (AnnF TypeInfo TermF) var
-> Maybe (FS (AnnF TypeInfo TermF) var)
forall a. a -> Maybe a
Just FS (AnnF TypeInfo TermF) var
forall var. TermT var
cubeIT }

cubeI_0T :: TermT var
cubeI_0T :: forall var. TermT var
cubeI_0T = TypeInfo (FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a) -> FS (AnnF ann TermF) a
CubeI_0T TypeInfo
  { infoType :: FS (AnnF TypeInfo TermF) var
infoType = FS (AnnF TypeInfo TermF) var
forall var. TermT var
cubeIT
  , infoNF :: Maybe (FS (AnnF TypeInfo TermF) var)
infoNF = FS (AnnF TypeInfo TermF) var
-> Maybe (FS (AnnF TypeInfo TermF) var)
forall a. a -> Maybe a
Just FS (AnnF TypeInfo TermF) var
forall var. TermT var
cubeI_0T
  , infoWHNF :: Maybe (FS (AnnF TypeInfo TermF) var)
infoWHNF = FS (AnnF TypeInfo TermF) var
-> Maybe (FS (AnnF TypeInfo TermF) var)
forall a. a -> Maybe a
Just FS (AnnF TypeInfo TermF) var
forall var. TermT var
cubeI_0T }

cubeI_1T :: TermT var
cubeI_1T :: forall var. TermT var
cubeI_1T = TypeInfo (FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a) -> FS (AnnF ann TermF) a
CubeI_1T TypeInfo
  { infoType :: FS (AnnF TypeInfo TermF) var
infoType = FS (AnnF TypeInfo TermF) var
forall var. TermT var
cubeIT
  , infoNF :: Maybe (FS (AnnF TypeInfo TermF) var)
infoNF = FS (AnnF TypeInfo TermF) var
-> Maybe (FS (AnnF TypeInfo TermF) var)
forall a. a -> Maybe a
Just FS (AnnF TypeInfo TermF) var
forall var. TermT var
cubeI_1T
  , infoWHNF :: Maybe (FS (AnnF TypeInfo TermF) var)
infoWHNF = FS (AnnF TypeInfo TermF) var
-> Maybe (FS (AnnF TypeInfo TermF) var)
forall a. a -> Maybe a
Just FS (AnnF TypeInfo TermF) var
forall var. TermT var
cubeI_1T }

cubeFlipT :: TermT var -> TermT var -> TermT var
cubeFlipT :: forall var. TermT var -> TermT var -> TermT var
cubeFlipT TermT var
cubeTy TermT var
t = TypeInfo (TermT var) -> TermT var -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a -> FS (AnnF ann TermF) a
CubeFlipT TypeInfo (TermT var)
info TermT var
t
  where
    info :: TypeInfo (TermT var)
info = TypeInfo
      { infoType :: TermT var
infoType = TermT var -> TModality -> TermT var -> TermT var
forall var. TermT var -> TModality -> TermT var -> TermT var
typeModalT TermT var
forall var. TermT var
cubeT TModality
Op TermT var
cubeTy
      , infoNF :: Maybe (TermT var)
infoNF = Maybe (TermT var)
forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF = Maybe (TermT var)
forall a. Maybe a
Nothing
      }

cubeUnflipT :: TermT var -> TermT var -> TermT var
cubeUnflipT :: forall var. TermT var -> TermT var -> TermT var
cubeUnflipT TermT var
cubeTy TermT var
t = TypeInfo (TermT var) -> TermT var -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a -> FS (AnnF ann TermF) a
CubeUnflipT TypeInfo (TermT var)
info TermT var
t
  where
    info :: TypeInfo (TermT var)
info = TypeInfo
      { infoType :: TermT var
infoType = TermT var
cubeTy
      , infoNF :: Maybe (TermT var)
infoNF = Maybe (TermT var)
forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF = Maybe (TermT var)
forall a. Maybe a
Nothing
      }

topeInvT :: TermT var -> TermT var
topeInvT :: forall var. TermT var -> TermT var
topeInvT TermT var
t = TypeInfo (TermT var) -> TermT var -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a -> FS (AnnF ann TermF) a
TopeInvT TypeInfo (TermT var)
forall {var}. TypeInfo (TermT var)
info TermT var
t
  where
    info :: TypeInfo (TermT var)
info = TypeInfo
      { infoType :: TermT var
infoType = TermT var -> TModality -> TermT var -> TermT var
forall var. TermT var -> TModality -> TermT var -> TermT var
typeModalT TermT var
forall var. TermT var
universeT TModality
Op TermT var
forall var. TermT var
topeT
      , infoNF :: Maybe (TermT var)
infoNF = Maybe (TermT var)
forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF = Maybe (TermT var)
forall a. Maybe a
Nothing
      }

topeUninvT :: TermT var -> TermT var
topeUninvT :: forall var. TermT var -> TermT var
topeUninvT TermT var
t = TypeInfo (TermT var) -> TermT var -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a -> FS (AnnF ann TermF) a
TopeUninvT TypeInfo (TermT var)
forall {var}. TypeInfo (TermT var)
info TermT var
t
  where
    info :: TypeInfo (TermT var)
info = TypeInfo
      { infoType :: TermT var
infoType = TermT var
forall var. TermT var
topeT
      , infoNF :: Maybe (TermT var)
infoNF = Maybe (TermT var)
forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF = Maybe (TermT var)
forall a. Maybe a
Nothing
      }

topeTopT :: TermT var
topeTopT :: forall var. TermT var
topeTopT = TypeInfo (FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a) -> FS (AnnF ann TermF) a
TopeTopT TypeInfo
  { infoType :: FS (AnnF TypeInfo TermF) var
infoType = FS (AnnF TypeInfo TermF) var
forall var. TermT var
topeT
  , infoNF :: Maybe (FS (AnnF TypeInfo TermF) var)
infoNF = FS (AnnF TypeInfo TermF) var
-> Maybe (FS (AnnF TypeInfo TermF) var)
forall a. a -> Maybe a
Just FS (AnnF TypeInfo TermF) var
forall var. TermT var
topeTopT
  , infoWHNF :: Maybe (FS (AnnF TypeInfo TermF) var)
infoWHNF = FS (AnnF TypeInfo TermF) var
-> Maybe (FS (AnnF TypeInfo TermF) var)
forall a. a -> Maybe a
Just FS (AnnF TypeInfo TermF) var
forall var. TermT var
topeTopT }

topeBottomT :: TermT var
topeBottomT :: forall var. TermT var
topeBottomT = TypeInfo (FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a) -> FS (AnnF ann TermF) a
TopeBottomT TypeInfo
  { infoType :: FS (AnnF TypeInfo TermF) var
infoType = FS (AnnF TypeInfo TermF) var
forall var. TermT var
topeT
  , infoNF :: Maybe (FS (AnnF TypeInfo TermF) var)
infoNF = FS (AnnF TypeInfo TermF) var
-> Maybe (FS (AnnF TypeInfo TermF) var)
forall a. a -> Maybe a
Just FS (AnnF TypeInfo TermF) var
forall var. TermT var
topeBottomT
  , infoWHNF :: Maybe (FS (AnnF TypeInfo TermF) var)
infoWHNF = FS (AnnF TypeInfo TermF) var
-> Maybe (FS (AnnF TypeInfo TermF) var)
forall a. a -> Maybe a
Just FS (AnnF TypeInfo TermF) var
forall var. TermT var
topeBottomT }

recBottomT :: TermT var
recBottomT :: forall var. TermT var
recBottomT = TypeInfo (FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a) -> FS (AnnF ann TermF) a
RecBottomT TypeInfo
  { infoType :: FS (AnnF TypeInfo TermF) var
infoType = FS (AnnF TypeInfo TermF) var
forall var. TermT var
recBottomT
  , infoNF :: Maybe (FS (AnnF TypeInfo TermF) var)
infoNF = FS (AnnF TypeInfo TermF) var
-> Maybe (FS (AnnF TypeInfo TermF) var)
forall a. a -> Maybe a
Just FS (AnnF TypeInfo TermF) var
forall var. TermT var
recBottomT
  , infoWHNF :: Maybe (FS (AnnF TypeInfo TermF) var)
infoWHNF = FS (AnnF TypeInfo TermF) var
-> Maybe (FS (AnnF TypeInfo TermF) var)
forall a. a -> Maybe a
Just FS (AnnF TypeInfo TermF) var
forall var. TermT var
recBottomT }

typeRestrictedT :: TermT var -> [(TermT var, TermT var)] -> TermT var
typeRestrictedT :: forall var. TermT var -> [(TermT var, TermT var)] -> TermT var
typeRestrictedT TermT var
ty [(TermT var, TermT var)]
rs = TermT var
t
  where
    t :: TermT var
t = TypeInfo (TermT var)
-> TermT var -> [(TermT var, TermT var)] -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a
-> [(FS (AnnF ann TermF) a, FS (AnnF ann TermF) a)]
-> FS (AnnF ann TermF) a
TypeRestrictedT TypeInfo (TermT var)
forall {var}. TypeInfo (TermT var)
info TermT var
ty [(TermT var, TermT var)]
rs
    info :: TypeInfo (TermT var)
info = TypeInfo
      { infoType :: TermT var
infoType  = TermT var
forall var. TermT var
universeT
      , infoNF :: Maybe (TermT var)
infoNF    = Maybe (TermT var)
forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF  = Maybe (TermT var)
forall a. Maybe a
Nothing
      }

lambdaT
  :: TermT var
  -> Binder
  -> Maybe (TModality, TermT var, Maybe (Scope TermT var))
  -> Scope TermT var
  -> TermT var
lambdaT :: forall var.
TermT var
-> Binder
-> Maybe
     (TModality, TermT var,
      Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
lambdaT TermT var
ty Binder
orig Maybe
  (TModality, TermT var,
   Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
mparam Scope (FS (AnnF TypeInfo TermF)) var
body = TermT var
t
  where
    t :: TermT var
t = TypeInfo (TermT var)
-> Binder
-> Maybe
     (TModality, TermT var,
      Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> Binder
-> Maybe
     (TModality, FS (AnnF ann TermF) a,
      Maybe (Scope (FS (AnnF ann TermF)) a))
-> Scope (FS (AnnF ann TermF)) a
-> FS (AnnF ann TermF) a
LambdaT TypeInfo (TermT var)
info Binder
orig Maybe
  (TModality, TermT var,
   Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
mparam Scope (FS (AnnF TypeInfo TermF)) var
body
    info :: TypeInfo (TermT var)
info = TypeInfo
      { infoType :: TermT var
infoType  = TermT var
ty
      , infoNF :: Maybe (TermT var)
infoNF    = Maybe (TermT var)
forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF  = TermT var -> Maybe (TermT var)
forall a. a -> Maybe a
Just TermT var
t
      }


letT :: TermT var -> Binder -> Maybe (TermT var) -> TermT var -> Scope TermT var -> TermT var
letT :: forall var.
TermT var
-> Binder
-> Maybe (TermT var)
-> TermT var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
letT TermT var
ty Binder
orig Maybe (TermT var)
mparam TermT var
val Scope (FS (AnnF TypeInfo TermF)) var
body = TermT var
t
  where
    t :: TermT var
t = TypeInfo (TermT var)
-> Binder
-> Maybe (TermT var)
-> TermT var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> Binder
-> Maybe (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a
-> Scope (FS (AnnF ann TermF)) a
-> FS (AnnF ann TermF) a
LetT TypeInfo (TermT var)
info Binder
orig Maybe (TermT var)
mparam TermT var
val Scope (FS (AnnF TypeInfo TermF)) var
body
    info :: TypeInfo (TermT var)
info = TypeInfo
      { infoType :: TermT var
infoType = TermT var
ty
      , infoNF :: Maybe (TermT var)
infoNF = Maybe (TermT var)
forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF = Maybe (TermT var)
forall a. Maybe a
Nothing
      }

letModT :: TermT var -> Binder -> TModality -> TModality -> Maybe (TermT var) -> TermT var -> Scope TermT var -> TermT var
letModT :: forall var.
TermT var
-> Binder
-> TModality
-> TModality
-> Maybe (TermT var)
-> TermT var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
letModT TermT var
ty Binder
orig TModality
app TModality
inn Maybe (TermT var)
mparam TermT var
val Scope (FS (AnnF TypeInfo TermF)) var
body = TermT var
t
  where
    t :: TermT var
t = TypeInfo (TermT var)
-> Binder
-> TModality
-> TModality
-> Maybe (TermT var)
-> TermT var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> Binder
-> TModality
-> TModality
-> Maybe (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a
-> Scope (FS (AnnF ann TermF)) a
-> FS (AnnF ann TermF) a
LetModT TypeInfo (TermT var)
info Binder
orig TModality
app TModality
inn Maybe (TermT var)
mparam TermT var
val Scope (FS (AnnF TypeInfo TermF)) var
body
    info :: TypeInfo (TermT var)
info = TypeInfo
      { infoType :: TermT var
infoType = TermT var
ty
      , infoNF :: Maybe (TermT var)
infoNF = Maybe (TermT var)
forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF = Maybe (TermT var)
forall a. Maybe a
Nothing
      }

appT :: TermT var -> TermT var -> TermT var -> TermT var
appT :: forall var. TermT var -> TermT var -> TermT var -> TermT var
appT TermT var
ty TermT var
f TermT var
x = TermT var
t
  where
    t :: TermT var
t = TypeInfo (TermT var) -> TermT var -> TermT var -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
AppT TypeInfo (TermT var)
info TermT var
f TermT var
x
    info :: TypeInfo (TermT var)
info = TypeInfo
      { infoType :: TermT var
infoType  = TermT var
ty
      , infoNF :: Maybe (TermT var)
infoNF    = Maybe (TermT var)
forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF  = Maybe (TermT var)
forall a. Maybe a
Nothing
      }

pairT :: TermT var -> TermT var -> TermT var -> TermT var
pairT :: forall var. TermT var -> TermT var -> TermT var -> TermT var
pairT TermT var
ty TermT var
l TermT var
r = TermT var
t
  where
    t :: TermT var
t = TypeInfo (TermT var) -> TermT var -> TermT var -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
PairT TypeInfo (TermT var)
info TermT var
l TermT var
r
    info :: TypeInfo (TermT var)
info = TypeInfo
      { infoType :: TermT var
infoType  = TermT var
ty
      , infoNF :: Maybe (TermT var)
infoNF    = Maybe (TermT var)
forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF  = TermT var -> Maybe (TermT var)
forall a. a -> Maybe a
Just TermT var
t
      }

firstT :: TermT var -> TermT var -> TermT var
firstT :: forall var. TermT var -> TermT var -> TermT var
firstT TermT var
ty TermT var
arg = TermT var
t
  where
    t :: TermT var
t = TypeInfo (TermT var) -> TermT var -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a -> FS (AnnF ann TermF) a
FirstT TypeInfo (TermT var)
info TermT var
arg
    info :: TypeInfo (TermT var)
info = TypeInfo
      { infoType :: TermT var
infoType  = TermT var
ty
      , infoNF :: Maybe (TermT var)
infoNF    = Maybe (TermT var)
forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF  = Maybe (TermT var)
forall a. Maybe a
Nothing
      }

secondT :: TermT var -> TermT var -> TermT var
secondT :: forall var. TermT var -> TermT var -> TermT var
secondT TermT var
ty TermT var
arg = TermT var
t
  where
    t :: TermT var
t = TypeInfo (TermT var) -> TermT var -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a -> FS (AnnF ann TermF) a
SecondT TypeInfo (TermT var)
info TermT var
arg
    info :: TypeInfo (TermT var)
info = TypeInfo
      { infoType :: TermT var
infoType  = TermT var
ty
      , infoNF :: Maybe (TermT var)
infoNF    = Maybe (TermT var)
forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF  = Maybe (TermT var)
forall a. Maybe a
Nothing
      }

reflT
  :: TermT var
  -> Maybe (TermT var, Maybe (TermT var))
  -> TermT var
reflT :: forall var.
TermT var -> Maybe (TermT var, Maybe (TermT var)) -> TermT var
reflT TermT var
ty Maybe (TermT var, Maybe (TermT var))
mx = TermT var
t
  where
    t :: TermT var
t = TypeInfo (TermT var)
-> Maybe (TermT var, Maybe (TermT var)) -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> Maybe (FS (AnnF ann TermF) a, Maybe (FS (AnnF ann TermF) a))
-> FS (AnnF ann TermF) a
ReflT TypeInfo (TermT var)
info Maybe (TermT var, Maybe (TermT var))
mx
    info :: TypeInfo (TermT var)
info = TypeInfo
      { infoType :: TermT var
infoType  = TermT var
ty
      , infoNF :: Maybe (TermT var)
infoNF    = TermT var -> Maybe (TermT var)
forall a. a -> Maybe a
Just (TypeInfo (TermT var)
-> Maybe (TermT var, Maybe (TermT var)) -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> Maybe (FS (AnnF ann TermF) a, Maybe (FS (AnnF ann TermF) a))
-> FS (AnnF ann TermF) a
ReflT TypeInfo (TermT var)
info Maybe (TermT var, Maybe (TermT var))
forall a. Maybe a
Nothing)
      , infoWHNF :: Maybe (TermT var)
infoWHNF  = TermT var -> Maybe (TermT var)
forall a. a -> Maybe a
Just (TypeInfo (TermT var)
-> Maybe (TermT var, Maybe (TermT var)) -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> Maybe (FS (AnnF ann TermF) a, Maybe (FS (AnnF ann TermF) a))
-> FS (AnnF ann TermF) a
ReflT TypeInfo (TermT var)
info Maybe (TermT var, Maybe (TermT var))
forall a. Maybe a
Nothing)
      }

typeFunT
  :: Binder
  -> TModality
  -> TermT var
  -> Maybe (Scope TermT var)
  -> Scope TermT var
  -> TermT var
typeFunT :: forall var.
Binder
-> TModality
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeFunT Binder
orig TModality
md TermT var
cube Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope Scope (FS (AnnF TypeInfo TermF)) var
ret = TermT var
t
  where
    t :: TermT var
t = TypeInfo (TermT var)
-> Binder
-> TModality
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> Binder
-> TModality
-> FS (AnnF ann TermF) a
-> Maybe (Scope (FS (AnnF ann TermF)) a)
-> Scope (FS (AnnF ann TermF)) a
-> FS (AnnF ann TermF) a
TypeFunT TypeInfo (TermT var)
info Binder
orig TModality
md TermT var
cube Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope Scope (FS (AnnF TypeInfo TermF)) var
ret
    info :: TypeInfo (TermT var)
info = TypeInfo
      { infoType :: TermT var
infoType  = TermT var
forall var. TermT var
universeT
      , infoNF :: Maybe (TermT var)
infoNF    = Maybe (TermT var)
forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF  = TermT var -> Maybe (TermT var)
forall a. a -> Maybe a
Just TermT var
t
      }

typeSigmaT
  :: Binder
  -> TModality
  -> TermT var
  -> Scope TermT var
  -> TermT var
typeSigmaT :: forall var.
Binder
-> TModality
-> TermT var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeSigmaT Binder
orig TModality
md TermT var
a Scope (FS (AnnF TypeInfo TermF)) var
b = TermT var
t
  where
    t :: TermT var
t = TypeInfo (TermT var)
-> Binder
-> TModality
-> TermT var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> Binder
-> TModality
-> FS (AnnF ann TermF) a
-> Scope (FS (AnnF ann TermF)) a
-> FS (AnnF ann TermF) a
TypeSigmaT TypeInfo (TermT var)
info Binder
orig TModality
md TermT var
a Scope (FS (AnnF TypeInfo TermF)) var
b
    info :: TypeInfo (TermT var)
info = TypeInfo
      { infoType :: TermT var
infoType  = TermT var
forall var. TermT var
universeT
      , infoNF :: Maybe (TermT var)
infoNF    = Maybe (TermT var)
forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF  = TermT var -> Maybe (TermT var)
forall a. a -> Maybe a
Just TermT var
t
      }

recOrT
  :: TermT var
  -> [(TermT var, TermT var)]
  -> TermT var
recOrT :: forall var. TermT var -> [(TermT var, TermT var)] -> TermT var
recOrT TermT var
ty [(TermT var, TermT var)]
rs = TermT var
t
  where
    t :: TermT var
t = TypeInfo (TermT var) -> [(TermT var, TermT var)] -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> [(FS (AnnF ann TermF) a, FS (AnnF ann TermF) a)]
-> FS (AnnF ann TermF) a
RecOrT TypeInfo (TermT var)
info [(TermT var, TermT var)]
rs
    info :: TypeInfo (TermT var)
info = TypeInfo
      { infoType :: TermT var
infoType  = TermT var
ty
      , infoNF :: Maybe (TermT var)
infoNF    = Maybe (TermT var)
forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF  = Maybe (TermT var)
forall a. Maybe a
Nothing
      }

typeIdT :: TermT var -> Maybe (TermT var) -> TermT var -> TermT var
typeIdT :: forall var.
TermT var -> Maybe (TermT var) -> TermT var -> TermT var
typeIdT TermT var
x Maybe (TermT var)
tA TermT var
y = TermT var
t
  where
    t :: TermT var
t = TypeInfo (TermT var)
-> TermT var -> Maybe (TermT var) -> TermT var -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a
-> Maybe (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
TypeIdT TypeInfo (TermT var)
info TermT var
x Maybe (TermT var)
tA TermT var
y
    info :: TypeInfo (TermT var)
info = TypeInfo
      { infoType :: TermT var
infoType  = TermT var
forall var. TermT var
universeT
      , infoNF :: Maybe (TermT var)
infoNF    = Maybe (TermT var)
forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF  = TermT var -> Maybe (TermT var)
forall a. a -> Maybe a
Just TermT var
t
      }

idJT
  :: TermT var
  -> TermT var
  -> TermT var
  -> TermT var
  -> TermT var
  -> TermT var
  -> TermT var
  -> TermT var
idJT :: forall var.
TermT var
-> TermT var
-> TermT var
-> TermT var
-> TermT var
-> TermT var
-> TermT var
-> TermT var
idJT TermT var
ty TermT var
tA TermT var
a TermT var
tC TermT var
d TermT var
x TermT var
p = TermT var
t
  where
    t :: TermT var
t = TypeInfo (TermT var)
-> TermT var
-> TermT var
-> TermT var
-> TermT var
-> TermT var
-> TermT var
-> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
IdJT TypeInfo (TermT var)
info TermT var
tA TermT var
a TermT var
tC TermT var
d TermT var
x TermT var
p
    info :: TypeInfo (TermT var)
info = TypeInfo
      { infoType :: TermT var
infoType  = TermT var
ty
      , infoNF :: Maybe (TermT var)
infoNF    = Maybe (TermT var)
forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF  = Maybe (TermT var)
forall a. Maybe a
Nothing
      }

typeAscT :: TermT var -> TermT var -> TermT var
typeAscT :: forall var. TermT var -> TermT var -> TermT var
typeAscT TermT var
x TermT var
ty = TermT var
t
  where
    t :: TermT var
t = TypeInfo (TermT var) -> TermT var -> TermT var -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
TypeAscT TypeInfo (TermT var)
info TermT var
x TermT var
ty
    info :: TypeInfo (TermT var)
info = TypeInfo
      { infoType :: TermT var
infoType  = TermT var
ty
      , infoNF :: Maybe (TermT var)
infoNF    = Maybe (TermT var)
forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF  = Maybe (TermT var)
forall a. Maybe a
Nothing
      }

typeModalT :: TermT var -> TModality -> TermT var -> TermT var
typeModalT :: forall var. TermT var -> TModality -> TermT var -> TermT var
typeModalT TermT var
ty TModality
md TermT var
te = TermT var
t
  where
    t :: TermT var
t = TypeInfo (TermT var) -> TModality -> TermT var -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> TModality -> FS (AnnF ann TermF) a -> FS (AnnF ann TermF) a
TypeModalT TypeInfo (TermT var)
info TModality
md TermT var
te
    info :: TypeInfo (TermT var)
info = TypeInfo
      { infoType :: TermT var
infoType = TermT var
ty
      , infoNF :: Maybe (TermT var)
infoNF = Maybe (TermT var)
forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF = Maybe (TermT var)
forall a. Maybe a
Nothing
      }

modAppT :: TermT var -> TModality -> TermT var -> TermT var
modAppT :: forall var. TermT var -> TModality -> TermT var -> TermT var
modAppT TermT var
ty TModality
md TermT var
term = TermT var
t
  where
    t :: TermT var
t = TypeInfo (TermT var) -> TModality -> TermT var -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> TModality -> FS (AnnF ann TermF) a -> FS (AnnF ann TermF) a
ModAppT TypeInfo (TermT var)
info TModality
md TermT var
term
    info :: TypeInfo (TermT var)
info = TypeInfo
      { infoType :: TermT var
infoType = TermT var
ty
      , infoNF :: Maybe (TermT var)
infoNF = Maybe (TermT var)
forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF = Maybe (TermT var)
forall a. Maybe a
Nothing
      }

modExtractT :: TermT var -> TModality -> TModality -> TermT var -> TermT var
modExtractT :: forall var.
TermT var -> TModality -> TModality -> TermT var -> TermT var
modExtractT TermT var
ty TModality
app TModality
inn TermT var
term = TermT var
t
  where
    t :: TermT var
t = TypeInfo (TermT var)
-> TModality -> TModality -> TermT var -> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> TModality
-> TModality
-> FS (AnnF ann TermF) a
-> FS (AnnF ann TermF) a
ModExtractT TypeInfo (TermT var)
info TModality
app TModality
inn TermT var
term
    info :: TypeInfo (TermT var)
info = TypeInfo
      { infoType :: TermT var
infoType = TermT var
ty
      , infoNF :: Maybe (TermT var)
infoNF = Maybe (TermT var)
forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF = Maybe (TermT var)
forall a. Maybe a
Nothing
      }

-- | Check a @recOR@ in checking position against a known expected type: each
-- branch is checked against that type under its guard tope, followed by the
-- usual pairwise coherence and the coverage obligation. Passing a /restricted/
-- type pushes the boundary into every branch, so a branch hole reports the
-- faces it must meet (under its tope) instead of the bare underlying type.
--
-- Under a branch guard, the faces belonging to the other (mutually exclusive)
-- branches become disjoint from this branch's tope context, so they are pruned
-- by 'pruneVacuousFaces' before the branch is checked. Otherwise a face like
-- @i ≡ 1₂@ would be reported as vacuous while checking the @i ≡ 0₂@ branch
-- against @A [i ≡ 0₂ ↦ a, i ≡ 1₂ ↦ b]@ — which arises in particular with
-- flat-discrete cube variables, where @i ≡ 0₂ ∧ i ≡ 1₂@ is provably ⊥.
checkRecOrAgainst :: Eq var => TermT var -> [(Term var, Term var)] -> TypeCheck var (TermT var)
checkRecOrAgainst :: forall var.
Eq var =>
TermT var -> [(Term var, Term var)] -> TypeCheck var (TermT var)
checkRecOrAgainst TermT var
expected [(Term var, Term var)]
rs = do
  rs' <- [(Term var, Term var)]
-> ((Term var, Term var)
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         (TermT var, TermT var))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [(TermT var, TermT var)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Term var, Term var)]
rs (((Term var, Term var)
  -> ReaderT
       (Context var)
       (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
       (TermT var, TermT var))
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      [(TermT var, TermT var)])
-> ((Term var, Term var)
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         (TermT var, TermT var))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [(TermT var, TermT var)]
forall a b. (a -> b) -> a -> b
$ \(Term var
tope, Term var
rterm) -> do
    tope' <- Term var -> TermT var -> TypeCheck var (TermT var)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
tope TermT var
forall var. TermT var
topeT
    checkTopeAgainstContext "recOR branch guard" tope'
    localTope tope' $ do
      expected' <- pruneVacuousFaces expected
      rterm' <- typecheck rterm expected'
      return (tope', rterm')
  sequence_ [ checkCoherence l r | l:rs'' <- tails rs', r <- rs'' ]
  contextEntailsUnion (map fst rs')
  return (recOrT expected rs')

-- | Drop the restriction faces of an extension type that are vacuous in the
-- current tope context (their overlap with the context is the empty tope ⊥). A
-- face mentioning an unfilled hole cannot be decided, so it is kept. Non-extension
-- types are returned unchanged. Used when descending into a recOR branch, where
-- the sibling branches' faces are disjoint from the branch guard.
pruneVacuousFaces :: Eq var => TermT var -> TypeCheck var (TermT var)
pruneVacuousFaces :: forall var. Eq var => TermT var -> TypeCheck var (TermT var)
pruneVacuousFaces (TypeRestrictedT TypeInfo (FS (AnnF TypeInfo TermF) var)
_info FS (AnnF TypeInfo TermF) var
ty [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
rs) = do
  contextTopes <- (Context var -> [ModalTope var])
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [ModalTope var]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context var -> [ModalTope var]
forall var. Context var -> [ModalTope var]
localTopesNF
  kept <- fmap concat $ forM rs $ \face :: (FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)
face@(FS (AnnF TypeInfo TermF) var
tope, FS (AnnF TypeInfo TermF) var
_) -> do
    vacuous <- if FS (AnnF TypeInfo TermF) var -> Bool
forall var. TermT var -> Bool
containsHole FS (AnnF TypeInfo TermF) var
tope
      then Bool
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     Bool
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      else (FS (AnnF TypeInfo TermF) var -> ModalTope var
forall var. TermT var -> ModalTope var
plainTope FS (AnnF TypeInfo TermF) var
tope ModalTope var -> [ModalTope var] -> [ModalTope var]
forall a. a -> [a] -> [a]
: [ModalTope var]
contextTopes) [ModalTope var]
-> FS (AnnF TypeInfo TermF) var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     Bool
forall var.
Eq var =>
[ModalTope var] -> TermT var -> TypeCheck var Bool
`entailM` FS (AnnF TypeInfo TermF) var
forall var. TermT var
topeBottomT
    return [ face | not vacuous ]
  return $ case kept of
    [] -> FS (AnnF TypeInfo TermF) var
ty
    [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
_  -> FS (AnnF TypeInfo TermF) var
-> [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
-> FS (AnnF TypeInfo TermF) var
forall var. TermT var -> [(TermT var, TermT var)] -> TermT var
typeRestrictedT FS (AnnF TypeInfo TermF) var
ty [(FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)]
kept
pruneVacuousFaces FS (AnnF TypeInfo TermF) var
ty = FS (AnnF TypeInfo TermF) var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (FS (AnnF TypeInfo TermF) var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return FS (AnnF TypeInfo TermF) var
ty

typecheck :: Eq var => Term var -> TermT var -> TypeCheck var (TermT var)
typecheck :: forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
term TermT var
ty = Action var
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall var a.
Eq var =>
Action var -> TypeCheck var a -> TypeCheck var a
performing (Term var -> TermT var -> Action var
forall var. Term var -> TermT var -> Action var
ActionTypeCheck Term var
term TermT var
ty) (TypeCheck var (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ case Term var
term of
  -- A hole is checked against a known type (this is checking position): in
  -- strict mode it is reported as an unsolved hole; in lenient mode its goal
  -- and context are recorded and it is treated as inhabiting the expected type.
  Hole Maybe VarIdent
mname -> do
    reject <- (Context var -> Bool)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context var -> Bool
forall var. Context var -> Bool
holesAreErrors
    if reject
      then issueTypeError (TypeErrorUnsolvedHole mname ty)
      else do
        recordHole mname ty
        return (HoleT TypeInfo{ infoType = ty, infoWHNF = Nothing, infoNF = Nothing } mname)

  Term var
_ -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
ty TypeCheck var (TermT var)
-> (TermT var -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case

    RecBottomT{} -> do
      -- Even under an absurd tope context (where the expected type collapses to
      -- recBOT), the term must still be well-formed in its own right, so that
      -- ill-typed bodies are not silently admitted under a false hypothesis. We
      -- synthesise its type, discard the result, and keep the recBOT elaboration.
      _ <- Term var -> TypeCheck var (TermT var)
forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
term
      return recBottomT

    tr :: TermT var
tr@(TypeRestrictedT TypeInfo (TermT var)
_ty TermT var
ty' [(TermT var, TermT var)]
rs) -> case Term var
term of
      -- A recOR against a restricted type: push the restriction into each branch
      -- instead of stripping it first, so a branch hole reports the boundary
      -- faces it must satisfy under its guard tope, rather than the bare
      -- underlying type. Concrete branches still meet the faces, which are
      -- checked on each branch's overlap with them (see the general case below).
      RecOr [(Term var, Term var)]
branches -> TermT var -> [(Term var, Term var)] -> TypeCheck var (TermT var)
forall var.
Eq var =>
TermT var -> [(Term var, Term var)] -> TypeCheck var (TermT var)
checkRecOrAgainst TermT var
tr [(Term var, Term var)]
branches
      Term var
_ -> do
        term' <- Term var -> TermT var -> TypeCheck var (TermT var)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
term TermT var
ty'
        -- NOTE: restriction faces need not be contained in the local tope context.
        -- Each face is checked only on its overlap with the context below, so an
        -- overhanging face is harmless (we only hint); a face disjoint from the context
        -- is vacuous, however, and is reported as an error by checkTopeAgainstContext.
        forM_ rs $ \(TermT var
tope, TermT var
rterm) -> do
          String -> TermT var -> TypeCheck var ()
forall var. Eq var => String -> TermT var -> TypeCheck var ()
checkTopeAgainstContext String
"restriction face" TermT var
tope
          TermT var -> TypeCheck var () -> TypeCheck var ()
forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope TermT var
tope (TypeCheck var () -> TypeCheck var ())
-> TypeCheck var () -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$
            TermT var -> TermT var -> TypeCheck var ()
forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms TermT var
rterm TermT var
term'
        return term'    -- FIXME: correct?

    TermT var
ty' -> case Term var
term of
      Lambda Binder
orig Maybe (TModality, Term var, Maybe (Scope (FS TermF) var))
mparam Scope (FS TermF) var
body ->
        case TermT var
ty' of
          TypeFunT TypeInfo (TermT var)
_ty Binder
_orig' TModality
md' TermT var
param' Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope' Scope (FS (AnnF TypeInfo TermF)) var
ret -> do
            case Maybe (TModality, Term var, Maybe (Scope (FS TermF) var))
mparam of
              Maybe (TModality, Term var, Maybe (Scope (FS TermF) var))
Nothing -> () -> TypeCheck var ()
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              Just (TModality
md, Term var
param, Maybe (Scope (FS TermF) var)
Nothing) -> do
                Bool -> TypeCheck var () -> TypeCheck var ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TModality
md TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
/= TModality
md') (TypeCheck var () -> TypeCheck var ())
-> TypeCheck var () -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$
                  TypeError var -> TypeCheck var ()
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TModality -> TModality -> Term var -> TypeError var
forall var. TModality -> TModality -> Term var -> TypeError var
TypeErrorModalityMismatch TModality
md' TModality
md Term var
term)
                (paramType, mtope) <- do
                  paramType <- TModality -> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
md (TypeCheck var (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ Term var -> TypeCheck var (TermT var)
forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
param
                  typeOf paramType >>= \case
                    -- an argument can be a shape
                    TypeFunT TypeInfo (TermT var)
_ty Binder
_orig TModality
_md TermT var
cube Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
_mtope UniverseTopeT{} -> do
                      (VarIdent -> TypeCheck var ()) -> [VarIdent] -> TypeCheck var ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ VarIdent -> TypeCheck var ()
forall var. VarIdent -> TypeCheck var ()
checkNameShadowing (Binder -> [VarIdent]
binderLeaves Binder
orig)
                      Binder
-> TModality
-> TermT var
-> TypeCheck
     (Inc var) (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
forall var b.
Binder
-> TModality
-> TermT var
-> TypeCheck (Inc var) b
-> TypeCheck var b
enterScope Binder
orig TModality
md TermT var
cube (TypeCheck
   (Inc var) (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var)))
-> TypeCheck
     (Inc var) (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
forall a b. (a -> b) -> a -> b
$ do
                        let tope' :: Scope (FS (AnnF TypeInfo TermF)) var
tope' = Scope (FS (AnnF TypeInfo TermF)) var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> Scope (FS (AnnF TypeInfo TermF)) var
forall var. TermT var -> TermT var -> TermT var -> TermT var
appT Scope (FS (AnnF TypeInfo TermF)) var
forall var. TermT var
topeT (var -> Inc var
forall var. var -> Inc var
S (var -> Inc var)
-> TermT var -> Scope (FS (AnnF TypeInfo TermF)) var
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
paramType) (Inc var -> Scope (FS (AnnF TypeInfo TermF)) var
forall (t :: * -> * -> *) a. a -> FS t a
Pure Inc var
forall var. Inc var
Z)  -- eta expand ty'
                        (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> TypeCheck
     (Inc var) (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
forall a.
a
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return (TermT var
cube, Scope (FS (AnnF TypeInfo TermF)) var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
forall a. a -> Maybe a
Just Scope (FS (AnnF TypeInfo TermF)) var
tope')
                    TermT var
_kind -> (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return (TermT var
paramType, Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
forall a. Maybe a
Nothing)
                unifyTerms param' paramType
                mapM_ checkNameShadowing (binderLeaves orig)
                enterScope orig md param' $ do
                  mapM_ (unifyTerms (fromMaybe topeTopT mtope')) mtope
              Just (TModality
md, Term var
param, Maybe (Scope (FS TermF) var)
mtope) -> do
                Bool -> TypeCheck var () -> TypeCheck var ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TModality
md TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
/= TModality
md') (TypeCheck var () -> TypeCheck var ())
-> TypeCheck var () -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$
                  TypeError var -> TypeCheck var ()
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TModality -> TModality -> Term var -> TypeError var
forall var. TModality -> TModality -> Term var -> TypeError var
TypeErrorModalityMismatch TModality
md' TModality
md Term var
term)
                param'' <- TModality -> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
md (TypeCheck var (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ Term var -> TermT var -> TypeCheck var (TermT var)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
param (TermT var -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
param'
                unifyTerms param' param''
                mapM_ checkNameShadowing (binderLeaves orig)
                enterScope orig md param' $ do
                  mtope'' <- typecheck (fromMaybe TopeTop mtope) topeT
                  unifyTerms (fromMaybe topeTopT mtope') mtope''

            (VarIdent -> TypeCheck var ()) -> [VarIdent] -> TypeCheck var ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ VarIdent -> TypeCheck var ()
forall var. VarIdent -> TypeCheck var ()
checkNameShadowing (Binder -> [VarIdent]
binderLeaves Binder
orig)
            Binder
-> TModality
-> TermT var
-> TypeCheck (Inc var) (TermT var)
-> TypeCheck var (TermT var)
forall var b.
Binder
-> TModality
-> TermT var
-> TypeCheck (Inc var) b
-> TypeCheck var b
enterScope Binder
orig TModality
md' TermT var
param' (TypeCheck (Inc var) (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck (Inc var) (TermT var) -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ do
              (TypeCheck (Inc var) (TermT var)
 -> TypeCheck (Inc var) (TermT var))
-> (Scope (FS (AnnF TypeInfo TermF)) var
    -> TypeCheck (Inc var) (TermT var)
    -> TypeCheck (Inc var) (TermT var))
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> TypeCheck (Inc var) (TermT var)
-> TypeCheck (Inc var) (TermT var)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TypeCheck (Inc var) (TermT var) -> TypeCheck (Inc var) (TermT var)
forall a. a -> a
id Scope (FS (AnnF TypeInfo TermF)) var
-> TypeCheck (Inc var) (TermT var)
-> TypeCheck (Inc var) (TermT var)
forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope' (TypeCheck (Inc var) (TermT var)
 -> TypeCheck (Inc var) (TermT var))
-> TypeCheck (Inc var) (TermT var)
-> TypeCheck (Inc var) (TermT var)
forall a b. (a -> b) -> a -> b
$ do
                body' <- Scope (FS TermF) var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TypeCheck (Inc var) (Scope (FS (AnnF TypeInfo TermF)) var)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Scope (FS TermF) var
body Scope (FS (AnnF TypeInfo TermF)) var
ret
                return (lambdaT ty' orig (Just (md', param', mtope')) body')

          TermT var
_ -> TypeError var -> TypeCheck var (TermT var)
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var -> TypeCheck var (TermT var))
-> TypeError var -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ Term var -> TermT var -> TypeError var
forall var. Term var -> TermT var -> TypeError var
TypeErrorUnexpectedLambda Term var
term TermT var
ty
      Let Binder
orig Maybe (Term var)
annot Term var
val Scope (FS TermF) var
body -> do
        val' <- Action var
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall var a.
Eq var =>
Action var -> TypeCheck var a -> TypeCheck var a
performing (Maybe VarIdent -> Action var
forall var. Maybe VarIdent -> Action var
ActionCheckLetValue (Binder -> Maybe VarIdent
binderName Binder
orig)) (TypeCheck var (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ case Maybe (Term var)
annot of
          Maybe (Term var)
Nothing -> Term var -> TypeCheck var (TermT var)
forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
val
          Just Term var
bindType -> do
            bindType' <- Term var -> TermT var -> TypeCheck var (TermT var)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
bindType TermT var
forall var. TermT var
universeT
            typecheck val bindType'
        bindTy <- typeOf val'
        body' <- enterScopeWithBind orig Id bindTy val' $ do
          typecheck body (S <$> ty')
        return (letT ty' orig (Just bindTy) val' body')
      LetMod Binder
orig TModality
app TModality
inn Maybe (Term var)
annot Term var
val Scope (FS TermF) var
body  -> do
        val' <- Action var
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall var a.
Eq var =>
Action var -> TypeCheck var a -> TypeCheck var a
performing (Maybe VarIdent -> Action var
forall var. Maybe VarIdent -> Action var
ActionCheckLetValue (Binder -> Maybe VarIdent
binderName Binder
orig)) (TypeCheck var (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ case Maybe (Term var)
annot of
          Maybe (Term var)
Nothing -> TModality -> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
app (TypeCheck var (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ Term var -> TypeCheck var (TermT var)
forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
val
          Just Term var
bindType -> do
            bindType' <- Term var -> TypeCheck var (TermT var)
forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
bindType
            bindUniv <- typeOf bindType'
            enterModality app $ typecheck val (typeModalT bindUniv inn bindType')
        bindTy <- typeOf val' >>= \case
          o :: TermT var
o@(TypeModalT TypeInfo (TermT var)
_ty TModality
md TermT var
t) ->
            if TModality
md TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
== TModality
inn then
              TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return TermT var
t
            else
              TypeError var -> TypeCheck var (TermT var)
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var -> TypeCheck var (TermT var))
-> TypeError var -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ Term var -> TModality -> TermT var -> TypeError var
forall var. Term var -> TModality -> TermT var -> TypeError var
TypeErrorNotModal (TermT var -> Term var
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT var
o) TModality
inn TermT var
val'
          TermT var
o -> TypeError var -> TypeCheck var (TermT var)
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var -> TypeCheck var (TermT var))
-> TypeError var -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ Term var -> TModality -> TermT var -> TypeError var
forall var. Term var -> TModality -> TermT var -> TypeError var
TypeErrorNotModal (TermT var -> Term var
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT var
o) TModality
inn TermT var
val'
        bindVal <- whnfT val' >>= \case
          ModAppT TypeInfo (TermT var)
_ty TModality
_m TermT var
t -> Maybe (TermT var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe (TermT var))
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT var -> Maybe (TermT var)
forall a. a -> Maybe a
Just TermT var
t)
          TermT var
o | TModality -> Bool
forall m. ModeTheory m => m -> Bool
isRA TModality
inn -> Maybe (TermT var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe (TermT var))
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT var -> Maybe (TermT var)
forall a. a -> Maybe a
Just (TermT var -> TModality -> TModality -> TermT var -> TermT var
forall var.
TermT var -> TModality -> TModality -> TermT var -> TermT var
modExtractT TermT var
bindTy TModality
app TModality
inn TermT var
o))
          TermT var
_ -> Maybe (TermT var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe (TermT var))
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TermT var)
forall a. Maybe a
Nothing
        body' <- enterScopeMaybe orig (comp app inn) bindTy bindVal $ do
          typecheck body (S <$> ty')
        return (letModT ty' orig app inn (Just bindTy) val' body')
      Pair Term var
l Term var
r ->
        case TermT var
ty' of
          CubeProductT TypeInfo (TermT var)
_ty TermT var
a TermT var
b -> do
            l' <- Term var -> TermT var -> TypeCheck var (TermT var)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
l TermT var
a
            r' <- typecheck r b
            return (pairT ty' l' r')
          TypeSigmaT TypeInfo (TermT var)
_ty Binder
_orig TModality
md TermT var
a Scope (FS (AnnF TypeInfo TermF)) var
b -> do
            l' <- TModality -> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
md (TypeCheck var (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ Term var -> TermT var -> TypeCheck var (TermT var)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
l TermT var
a
            r' <- typecheck r (substituteT l' b)
            return (pairT ty' l' r')
          TermT var
_ -> TypeError var -> TypeCheck var (TermT var)
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var -> TypeCheck var (TermT var))
-> TypeError var -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ Term var -> TermT var -> TypeError var
forall var. Term var -> TermT var -> TypeError var
TypeErrorUnexpectedPair Term var
term TermT var
ty

      Refl Maybe (Term var, Maybe (Term var))
mx ->
        case TermT var
ty' of
          TypeIdT TypeInfo (TermT var)
_ty TermT var
y Maybe (TermT var)
_tA TermT var
z -> do
            tA <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
y
            forM_ mx $ \(Term var
x, Maybe (Term var)
mxty) -> do
              Maybe (Term var)
-> (Term var -> TypeCheck var ()) -> TypeCheck var ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (Term var)
mxty ((Term var -> TypeCheck var ()) -> TypeCheck var ())
-> (Term var -> TypeCheck var ()) -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$ \Term var
xty -> do
                xty' <- Term var -> TermT var -> TypeCheck var (TermT var)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
xty TermT var
forall var. TermT var
universeT
                unifyTerms tA xty'
              x' <- Term var -> TermT var -> TypeCheck var (TermT var)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
x TermT var
tA
              unifyTerms x' y >> unifyTerms y x'
              unifyTerms x' z >> unifyTerms z x'
            when (isNothing mx) $
              unifyTerms y z >> unifyTerms z y
            return (reflT ty' (Just (y, Just tA)))
          TermT var
_ -> TypeError var -> TypeCheck var (TermT var)
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var -> TypeCheck var (TermT var))
-> TypeError var -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ Term var -> TermT var -> TypeError var
forall var. Term var -> TermT var -> TypeError var
TypeErrorUnexpectedRefl Term var
term TermT var
ty
      ModExtract{} -> String -> TypeCheck var (TermT var)
forall a. String -> a
panicImpossible String
"extract is an internal term and cannot be typechecked"
      ModApp TModality
md Term var
body -> case TermT var
ty' of
        TypeModalT TypeInfo (TermT var)
_ty TModality
md' TermT var
tpe -> do
            Bool -> TypeCheck var () -> TypeCheck var ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TModality
md TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
/= TModality
md') (TypeCheck var () -> TypeCheck var ())
-> TypeCheck var () -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$ TypeError var -> TypeCheck var ()
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var -> TypeCheck var ())
-> TypeError var -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$
              TModality -> TModality -> Term var -> TypeError var
forall var. TModality -> TModality -> Term var -> TypeError var
TypeErrorModalityMismatch TModality
md' TModality
md Term var
term
            body' <- TModality -> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
md (TypeCheck var (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ Term var -> TermT var -> TypeCheck var (TermT var)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
body TermT var
tpe
            return $ modAppT ty' md body'
        TermT var
_ -> TypeError var -> TypeCheck var (TermT var)
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var -> TypeCheck var (TermT var))
-> TypeError var -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ Term var -> TModality -> TermT var -> TypeError var
forall var. Term var -> TModality -> TermT var -> TypeError var
TypeErrorNotModal Term var
term TModality
md TermT var
ty'

      -- In checking position the common type is already known, so we push it
      -- into every branch instead of inferring each one and unifying. This is
      -- what lets a bare hole branch (recOR(φ ↦ ?, …)) be checked against the
      -- expected type and recorded, rather than hitting TypeErrorCannotInferHole
      -- via the inference rule. The branch-guard, coherence, and coverage
      -- obligations mirror the inference rule (see the RecOr case of 'infer').
      -- A recOR is a term-level eliminator, not a tope; rejecting it when it is
      -- checked against the tope universe (e.g. in another recOR's branch guard)
      -- keeps it out of the tope layer, where it would otherwise hit a panic.
      RecOr [(Term var, Term var)]
rs -> case TermT var
ty' of
        UniverseTopeT{} -> TypeError var -> TypeCheck var (TermT var)
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var -> TypeCheck var (TermT var))
-> TypeError var -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$
          String -> TypeError var
forall var. String -> TypeError var
TypeErrorOther String
"a recOR cannot be used as a tope"
        TermT var
_ -> TermT var -> [(Term var, Term var)] -> TypeCheck var (TermT var)
forall var.
Eq var =>
TermT var -> [(Term var, Term var)] -> TypeCheck var (TermT var)
checkRecOrAgainst TermT var
ty' [(Term var, Term var)]
rs
      -- A neutral term is inferred, then its type unified with the expected
      -- one. In lenient (hole-checking) mode a term that still carries an
      -- unfilled hole is a work in progress, so a failure of that final
      -- unification is tolerated: the holes recorded while inferring the term
      -- stand (they were committed before this point), and we accept the term
      -- rather than rejecting the whole sketch. The mismatch is typically
      -- incidental to the missing pieces — e.g. an extension-type boundary face
      -- that only fails to line up because an argument hole sits in the wrong
      -- place (`f t` vs `x`), where neither side is itself a hole, so the
      -- per-term deferral in 'unifyInCurrentContext' cannot see it. Strict mode
      -- (the default, and CI) still rejects the mismatch.
      Term var
_ -> do
        term' <- Term var -> TypeCheck var (TermT var)
forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
term
        inferredType <- typeOf term'
        lenient <- not <$> asks holesAreErrors
        if lenient && containsHole term'
          then unifyTypes term' ty' inferredType `catchError` \TypeErrorInScopedContext var
_ -> () -> TypeCheck var ()
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          else unifyTypes term' ty' inferredType
        return term'

inferAs :: Eq var => TermT var -> Term var -> TypeCheck var (TermT var)
inferAs :: forall var.
Eq var =>
TermT var -> Term var -> TypeCheck var (TermT var)
inferAs TermT var
expectedKind Term var
term = do
  term' <- Term var -> TypeCheck var (TermT var)
forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
term
  ty <- typeOf term'
  kind <- typeOf ty
  unifyTypes ty expectedKind kind
  return term'

infer :: Eq var => Term var -> TypeCheck var (TermT var)
infer :: forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
tt = Action var
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall var a.
Eq var =>
Action var -> TypeCheck var a -> TypeCheck var a
performing (Term var -> Action var
forall var. Term var -> Action var
ActionInfer Term var
tt) (TypeCheck var (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ case Term var
tt of
  Hole Maybe VarIdent
_mname -> TypeError var -> TypeCheck var (TermT var)
forall var a. TypeError var -> TypeCheck var a
issueTypeError (Term var -> TypeError var
forall var. Term var -> TypeError var
TypeErrorCannotInferHole Term var
tt)
  Pure var
x -> do
    topLevel <- var -> TypeCheck var Bool
forall var. Eq var => var -> TypeCheck var Bool
isTopLevelVar var
x
    unless topLevel $ do
      varMod <- modalityOfVar x
      locks <- locksOfVar x
      when (not (coe varMod locks)) $ issueTypeError $ TypeErrorUnaccessibleVar x varMod locks
    pure (Pure x)

  Term var
Universe     -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
forall var. TermT var
universeT
  Term var
UniverseCube -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
forall var. TermT var
cubeT
  Term var
UniverseTope -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
forall var. TermT var
topeT

  Term var
CubeUnit      -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
forall var. TermT var
cubeUnitT
  Term var
CubeUnitStar  -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
forall var. TermT var
cubeUnitStarT

  Term var
Cube2 -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
forall var. TermT var
cube2T
  Term var
Cube2_0 -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
forall var. TermT var
cube2_0T
  Term var
Cube2_1 -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
forall var. TermT var
cube2_1T

  Term var
CubeI -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
forall var. TermT var
cubeIT
  Term var
CubeI_0 -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
forall var. TermT var
cubeI_0T
  Term var
CubeI_1 -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
forall var. TermT var
cubeI_1T
  CubeProduct Term var
l Term var
r -> do
    l' <- Term var -> TermT var -> TypeCheck var (TermT var)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
l TermT var
forall var. TermT var
cubeT
    r' <- typecheck r cubeT
    return (cubeProductT l' r')

  CubeFlip Term var
t -> do
    t' <- Term var -> TypeCheck var (TermT var)
forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
t
    typeOf t' >>= \case
      CubeIT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT var -> TypeCheck var (TermT var))
-> TermT var -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
cubeFlipT TermT var
forall var. TermT var
cubeIT TermT var
t'
      Cube2T{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT var -> TypeCheck var (TermT var))
-> TermT var -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
cubeFlipT TermT var
forall var. TermT var
cube2T TermT var
t'
      TermT var
ty -> do
        tyStr <- TermT var -> TypeCheck var String
forall var. Eq var => TermT var -> TypeCheck var String
ppTermInContext TermT var
ty
        issueTypeError $ TypeErrorOther $
          "flip expects an interval cube (2 or 𝕀); got " <> tyStr
  CubeUnflip Term var
t -> do
    t' <- Term var -> TypeCheck var (TermT var)
forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
t
    typeOf t' >>= \case
      TypeModalT TypeInfo (TermT var)
_ TModality
Op (CubeIT{}) -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT var -> TypeCheck var (TermT var))
-> TermT var -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
cubeUnflipT TermT var
forall var. TermT var
cubeIT TermT var
t'
      TypeModalT TypeInfo (TermT var)
_ TModality
Op (Cube2T{}) -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT var -> TypeCheck var (TermT var))
-> TermT var -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
cubeUnflipT TermT var
forall var. TermT var
cube2T TermT var
t'
      TermT var
ty -> do
        tyStr <- TermT var -> TypeCheck var String
forall var. Eq var => TermT var -> TypeCheck var String
ppTermInContext TermT var
ty
        issueTypeError $ TypeErrorOther $
          "unflip expects an interval cube (2 or 𝕀) under _op; got " <> tyStr
  Pair Term var
l Term var
r -> do
    l' <- Term var -> TypeCheck var (TermT var)
forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
l
    r' <- infer r
    lt <- typeOf l'
    rt <- typeOf r'
    typeOf lt >>= \case
      --    Γ ⊢ l ⇒ (I : CUBE)
      --    Γ ⊢ r ⇒ (J : CUBE)
      -- ———————————————————————————
      -- Γ ⊢ (l, r) ⇒ (I × J : CUBE)
      UniverseCubeT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return (TermT var -> TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var -> TermT var
pairT (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
cubeProductT TermT var
lt TermT var
rt) TermT var
l' TermT var
r')
      --    Γ ⊢ l ⇒ (A : U)
      --    Γ ⊢ r ⇒ (B : U)
      -- ———————————————————————————
      -- Γ ⊢ (l, r) ⇒ (A × B : U)             where A × B = Σ (_ : A), B
      TermT var
_ -> do
        -- NOTE: infer as a non-dependent pair!
        TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return (TermT var -> TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var -> TermT var
pairT (Binder
-> TModality
-> TermT var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall var.
Binder
-> TModality
-> TermT var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeSigmaT (Maybe VarIdent -> Binder
BinderVar Maybe VarIdent
forall a. Maybe a
Nothing) TModality
Id TermT var
lt (var -> Inc var
forall var. var -> Inc var
S (var -> Inc var)
-> TermT var -> Scope (FS (AnnF TypeInfo TermF)) var
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
rt)) TermT var
l' TermT var
r')

  First Term var
t -> do
    t' <- Term var -> TypeCheck var (TermT var)
forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
t
    fmap stripTypeRestrictions (typeOf t') >>= \case
      RecBottomT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
forall var. TermT var
recBottomT -- FIXME: is this ok?
      TypeSigmaT TypeInfo (TermT var)
_ty Binder
_orig TModality
_md TermT var
lt Scope (FS (AnnF TypeInfo TermF)) var
_rt ->
        TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
firstT TermT var
lt TermT var
t')
      CubeProductT TypeInfo (TermT var)
_ty TermT var
l TermT var
_r ->
        TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
firstT TermT var
l TermT var
t')
      TermT var
ty -> TypeError var -> TypeCheck var (TermT var)
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var -> TypeCheck var (TermT var))
-> TypeError var -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ TermT var -> TermT var -> TypeError var
forall var. TermT var -> TermT var -> TypeError var
TypeErrorNotPair TermT var
t' TermT var
ty

  Second Term var
t -> do
    t' <- Term var -> TypeCheck var (TermT var)
forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
t
    fmap stripTypeRestrictions (typeOf t') >>= \case
      RecBottomT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
forall var. TermT var
recBottomT -- FIXME: is this ok?
      TypeSigmaT TypeInfo (TermT var)
_ty Binder
_orig TModality
_md TermT var
lt Scope (FS (AnnF TypeInfo TermF)) var
rt ->
        TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
secondT (TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
forall var.
TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
substituteT (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
firstT TermT var
lt TermT var
t') Scope (FS (AnnF TypeInfo TermF)) var
rt) TermT var
t')
      CubeProductT TypeInfo (TermT var)
_ty TermT var
_l TermT var
r ->
        TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
secondT TermT var
r TermT var
t')
      TermT var
ty -> TypeError var -> TypeCheck var (TermT var)
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var -> TypeCheck var (TermT var))
-> TypeError var -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ TermT var -> TermT var -> TypeError var
forall var. TermT var -> TermT var -> TypeError var
TypeErrorNotPair TermT var
t' TermT var
ty

  Term var
TypeUnit -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
forall var. TermT var
typeUnitT
  Term var
Unit -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
forall var. TermT var
unitT

  Term var
TopeTop -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
forall var. TermT var
topeTopT
  Term var
TopeBottom -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
forall var. TermT var
topeBottomT

  TopeEQ Term var
l Term var
r -> do
    l' <- TermT var -> Term var -> TypeCheck var (TermT var)
forall var.
Eq var =>
TermT var -> Term var -> TypeCheck var (TermT var)
inferAs TermT var
forall var. TermT var
cubeT Term var
l
    lt <- typeOf l'
    r' <- typecheck r lt
    return (topeEQT l' r')

  TopeLEQ Term var
l Term var
r -> do
    l' <- TermT var -> Term var -> TypeCheck var (TermT var)
forall var.
Eq var =>
TermT var -> Term var -> TypeCheck var (TermT var)
inferAs TermT var
forall var. TermT var
cubeT Term var
l
    r' <- inferAs cubeT r
    lTy <- typeOf l'
    rTy <- typeOf r'
    case (lTy, rTy) of
      (Cube2T{}, Cube2T{}) -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
l' TermT var
r')
      (CubeIT{}, CubeIT{}) -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
l' TermT var
r')
      (CubeIT{}, Cube2T{}) -> do
        r'' <- Term var -> TermT var -> TypeCheck var (TermT var)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
r TermT var
forall var. TermT var
cubeIT
        return (topeLEQT l' r'')
      (Cube2T{}, CubeIT{}) -> do
        l'' <- Term var -> TermT var -> TypeCheck var (TermT var)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
l TermT var
forall var. TermT var
cubeIT
        return (topeLEQT l'' r')
      (TermT var, TermT var)
_ -> do
        lStr <- TermT var -> TypeCheck var String
forall var. Eq var => TermT var -> TypeCheck var String
ppTermInContext TermT var
lTy
        rStr <- ppTermInContext rTy
        issueTypeError $ TypeErrorOther $
          "the (t ≤ s) tope expects points in interval cubes (2 or 𝕀); got "
            <> lStr <> " and " <> rStr

  TopeAnd Term var
l Term var
r -> do
    l' <- Term var -> TermT var -> TypeCheck var (TermT var)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
l TermT var
forall var. TermT var
topeT
    r' <- typecheck r topeT
    return (topeAndT l' r')

  TopeOr Term var
l Term var
r -> do
    l' <- Term var -> TermT var -> TypeCheck var (TermT var)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
l TermT var
forall var. TermT var
topeT
    r' <- typecheck r topeT
    return (topeOrT l' r')

  TopeInv Term var
t -> do
    t' <- Term var -> TermT var -> TypeCheck var (TermT var)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
t TermT var
forall var. TermT var
topeT
    return (topeInvT t')

  TopeUninv Term var
t -> do
    t' <- Term var -> TermT var -> TypeCheck var (TermT var)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
t (TermT var -> TModality -> TermT var -> TermT var
forall var. TermT var -> TModality -> TermT var -> TermT var
typeModalT TermT var
forall var. TermT var
universeT TModality
Op TermT var
forall var. TermT var
topeT )
    return (topeUninvT t')

  Term var
RecBottom -> do
    TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     ()
forall var. Eq var => TermT var -> TypeCheck var ()
contextEntails TermT var
forall var. TermT var
topeBottomT
    TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return TermT var
forall var. TermT var
recBottomT

  -- Γ ⊢ t ⇒ (T : K)
  -- Γ ⊢ K ≡ U
  -- —————————————
  -- Γ ⊢ t ⇒ T ⇐ U

  RecOr [(Term var, Term var)]
rs -> do
    ttts <- [(Term var, Term var)]
-> ((Term var, Term var)
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         (TermT var, (TermT var, TermT var)))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [(TermT var, (TermT var, TermT var))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Term var, Term var)]
rs (((Term var, Term var)
  -> ReaderT
       (Context var)
       (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
       (TermT var, (TermT var, TermT var)))
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      [(TermT var, (TermT var, TermT var))])
-> ((Term var, Term var)
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         (TermT var, (TermT var, TermT var)))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [(TermT var, (TermT var, TermT var))]
forall a b. (a -> b) -> a -> b
$ \(Term var
tope, Term var
term) -> do
      tope' <- Term var -> TermT var -> TypeCheck var (TermT var)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
tope TermT var
forall var. TermT var
topeT
      -- NOTE: branch guards need not be contained in the context. recOR requires
      -- only coverage (context |- OR(guards)), enforced by contextEntailsUnion below;
      -- a guard may overhang the context (e.g. when splitting with a named shape).
      -- checkTopeAgainstContext warns on overhang and errors only if the guard is
      -- disjoint from the context (a vacuous branch).
      checkTopeAgainstContext "recOR branch guard" tope'
      localTope tope' $ do
        term' <- inferAs universeT term
        ty <- typeOf term'
        return (tope', (term', ty))
    let rs' = ((TermT var, (TermT var, TermT var)) -> (TermT var, TermT var))
-> [(TermT var, (TermT var, TermT var))]
-> [(TermT var, TermT var)]
forall a b. (a -> b) -> [a] -> [b]
map (((TermT var, TermT var) -> TermT var)
-> (TermT var, (TermT var, TermT var)) -> (TermT var, TermT var)
forall a b. (a -> b) -> (TermT var, a) -> (TermT var, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TermT var, TermT var) -> TermT var
forall a b. (a, b) -> a
fst) [(TermT var, (TermT var, TermT var))]
ttts
        ts  = ((TermT var, (TermT var, TermT var)) -> (TermT var, TermT var))
-> [(TermT var, (TermT var, TermT var))]
-> [(TermT var, TermT var)]
forall a b. (a -> b) -> [a] -> [b]
map (((TermT var, TermT var) -> TermT var)
-> (TermT var, (TermT var, TermT var)) -> (TermT var, TermT var)
forall a b. (a -> b) -> (TermT var, a) -> (TermT var, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TermT var, TermT var) -> TermT var
forall a b. (a, b) -> b
snd) [(TermT var, (TermT var, TermT var))]
ttts
    sequence_ [ checkCoherence l r | l:rs'' <- tails rs', r <- rs'' ]
    contextEntailsUnion (map fst ttts)
    return (recOrT (recOrT universeT ts) rs')

  TypeFun Binder
orig TModality
md Term var
a Maybe (Scope (FS TermF) var)
Nothing Scope (FS TermF) var
b -> do
    a' <- TModality -> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
md (TypeCheck var (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ Term var -> TypeCheck var (TermT var)
forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
a
    typeOf a' >>= \case
      -- an argument can be a type
      UniverseT{} ->
        case TermT var
a' of
          -- except if its a TOPE universe
          UniverseTopeT{} ->
            TypeError var -> TypeCheck var (TermT var)
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var -> TypeCheck var (TermT var))
-> TypeError var -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ String -> TypeError var
forall var. String -> TypeError var
TypeErrorOther String
"tope params are illegal"
          TermT var
_ -> do
            (VarIdent
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      ())
-> [VarIdent]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ VarIdent
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     ()
forall var. VarIdent -> TypeCheck var ()
checkNameShadowing (Binder -> [VarIdent]
binderLeaves Binder
orig)
            b' <- Binder
-> TModality
-> TermT var
-> TypeCheck (Inc var) (Scope (FS (AnnF TypeInfo TermF)) var)
-> TypeCheck var (Scope (FS (AnnF TypeInfo TermF)) var)
forall var b.
Binder
-> TModality
-> TermT var
-> TypeCheck (Inc var) b
-> TypeCheck var b
enterScope Binder
orig TModality
md TermT var
a' (TypeCheck (Inc var) (Scope (FS (AnnF TypeInfo TermF)) var)
 -> TypeCheck var (Scope (FS (AnnF TypeInfo TermF)) var))
-> TypeCheck (Inc var) (Scope (FS (AnnF TypeInfo TermF)) var)
-> TypeCheck var (Scope (FS (AnnF TypeInfo TermF)) var)
forall a b. (a -> b) -> a -> b
$ Scope (FS TermF) var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TypeCheck (Inc var) (Scope (FS (AnnF TypeInfo TermF)) var)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Scope (FS TermF) var
b Scope (FS (AnnF TypeInfo TermF)) var
forall var. TermT var
universeT
            return (typeFunT orig md a' Nothing b')
      -- an argument can be a cube
      UniverseCubeT{} -> do
        (VarIdent
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      ())
-> [VarIdent]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ VarIdent
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     ()
forall var. VarIdent -> TypeCheck var ()
checkNameShadowing (Binder -> [VarIdent]
binderLeaves Binder
orig)
        b' <- Binder
-> TModality
-> TermT var
-> TypeCheck (Inc var) (Scope (FS (AnnF TypeInfo TermF)) var)
-> TypeCheck var (Scope (FS (AnnF TypeInfo TermF)) var)
forall var b.
Binder
-> TModality
-> TermT var
-> TypeCheck (Inc var) b
-> TypeCheck var b
enterScope Binder
orig TModality
md TermT var
a' (TypeCheck (Inc var) (Scope (FS (AnnF TypeInfo TermF)) var)
 -> TypeCheck var (Scope (FS (AnnF TypeInfo TermF)) var))
-> TypeCheck (Inc var) (Scope (FS (AnnF TypeInfo TermF)) var)
-> TypeCheck var (Scope (FS (AnnF TypeInfo TermF)) var)
forall a b. (a -> b) -> a -> b
$ Scope (FS TermF) var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TypeCheck (Inc var) (Scope (FS (AnnF TypeInfo TermF)) var)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Scope (FS TermF) var
b Scope (FS (AnnF TypeInfo TermF)) var
forall var. TermT var
universeT
        return (typeFunT orig md a' Nothing b')
      -- an argument can be a shape
      TypeFunT TypeInfo (TermT var)
_ty Binder
_orig TModality
_md TermT var
cube Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope UniverseTopeT{} -> do
        (VarIdent
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      ())
-> [VarIdent]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ VarIdent
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     ()
forall var. VarIdent -> TypeCheck var ()
checkNameShadowing (Binder -> [VarIdent]
binderLeaves Binder
orig)
        Binder
-> TModality
-> TermT var
-> TypeCheck (Inc var) (TermT var)
-> TypeCheck var (TermT var)
forall var b.
Binder
-> TModality
-> TermT var
-> TypeCheck (Inc var) b
-> TypeCheck var b
enterScope Binder
orig TModality
md TermT var
cube (TypeCheck (Inc var) (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck (Inc var) (TermT var) -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ do
          let tope' :: Scope (FS (AnnF TypeInfo TermF)) var
tope' = Scope (FS (AnnF TypeInfo TermF)) var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> Scope (FS (AnnF TypeInfo TermF)) var
forall var. TermT var -> TermT var -> TermT var -> TermT var
appT Scope (FS (AnnF TypeInfo TermF)) var
forall var. TermT var
topeT (var -> Inc var
forall var. var -> Inc var
S (var -> Inc var)
-> TermT var -> Scope (FS (AnnF TypeInfo TermF)) var
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
a') (Inc var -> Scope (FS (AnnF TypeInfo TermF)) var
forall (t :: * -> * -> *) a. a -> FS t a
Pure Inc var
forall var. Inc var
Z)  -- eta expand a'
          Scope (FS (AnnF TypeInfo TermF)) var
-> TypeCheck (Inc var) (TermT var)
-> TypeCheck (Inc var) (TermT var)
forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope Scope (FS (AnnF TypeInfo TermF)) var
tope' (TypeCheck (Inc var) (TermT var)
 -> TypeCheck (Inc var) (TermT var))
-> TypeCheck (Inc var) (TermT var)
-> TypeCheck (Inc var) (TermT var)
forall a b. (a -> b) -> a -> b
$ do
            b' <- Scope (FS TermF) var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TypeCheck (Inc var) (Scope (FS (AnnF TypeInfo TermF)) var)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Scope (FS TermF) var
b Scope (FS (AnnF TypeInfo TermF)) var
forall var. TermT var
universeT
            case mtope of
              Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
Nothing -> TermT var -> TypeCheck (Inc var) (TermT var)
forall a.
a
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return (Binder
-> TModality
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall var.
Binder
-> TModality
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeFunT Binder
orig TModality
md TermT var
cube (Scope (FS (AnnF TypeInfo TermF)) var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
forall a. a -> Maybe a
Just Scope (FS (AnnF TypeInfo TermF)) var
tope') Scope (FS (AnnF TypeInfo TermF)) var
b')
              Just Scope (FS (AnnF TypeInfo TermF)) var
tope'' -> TermT var -> TypeCheck (Inc var) (TermT var)
forall a.
a
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return (Binder
-> TModality
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall var.
Binder
-> TModality
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeFunT Binder
orig TModality
md TermT var
cube (Scope (FS (AnnF TypeInfo TermF)) var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
forall a. a -> Maybe a
Just (Scope (FS (AnnF TypeInfo TermF)) var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> Scope (FS (AnnF TypeInfo TermF)) var
forall var. TermT var -> TermT var -> TermT var
topeAndT Scope (FS (AnnF TypeInfo TermF)) var
tope'' Scope (FS (AnnF TypeInfo TermF)) var
tope')) Scope (FS (AnnF TypeInfo TermF)) var
b')
      TermT var
ty -> TypeError var -> TypeCheck var (TermT var)
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var -> TypeCheck var (TermT var))
-> TypeError var -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ Term var -> TermT var -> TypeError var
forall var. Term var -> TermT var -> TypeError var
TypeErrorInvalidArgumentType Term var
a TermT var
ty

  TypeFun Binder
orig TModality
md Term var
cube (Just Scope (FS TermF) var
tope) Scope (FS TermF) var
ret -> do
    cube' <- TModality -> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
md (TypeCheck var (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ Term var -> TermT var -> TypeCheck var (TermT var)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
cube TermT var
forall var. TermT var
cubeT
    mapM_ checkNameShadowing (binderLeaves orig)
    enterScope orig md cube' $ do
      tope' <- typecheck tope topeT
      localTope tope' $ do
        ret' <- typecheck ret universeT
        return (typeFunT orig md cube' (Just tope') ret')

  TypeSigma Binder
orig TModality
md Term var
a Scope (FS TermF) var
b -> do
    a' <- TModality -> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
md (TypeCheck var (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ Term var -> TermT var -> TypeCheck var (TermT var)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
a TermT var
forall var. TermT var
universeT
    mapM_ checkNameShadowing (binderLeaves orig)
    b' <- enterScope orig md a' $ typecheck b universeT
    return (typeSigmaT orig md a' b')

  TypeId Term var
x (Just Term var
tA) Term var
y -> do
    tA' <- Term var -> TermT var -> TypeCheck var (TermT var)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
tA TermT var
forall var. TermT var
universeT
    x' <- typecheck x tA'
    y' <- typecheck y tA'
    return (typeIdT x' (Just tA') y')

  TypeId Term var
x Maybe (Term var)
Nothing Term var
y -> do
    x' <- TermT var -> Term var -> TypeCheck var (TermT var)
forall var.
Eq var =>
TermT var -> Term var -> TypeCheck var (TermT var)
inferAs TermT var
forall var. TermT var
universeT Term var
x
    tA <- typeOf x'
    y' <- typecheck y tA
    return (typeIdT x' (Just tA) y')

  App Term var
f Term var
x -> do
    f' <- TermT var -> Term var -> TypeCheck var (TermT var)
forall var.
Eq var =>
TermT var -> Term var -> TypeCheck var (TermT var)
inferAs TermT var
forall var. TermT var
universeT Term var
f
    fmap stripTypeRestrictions (typeOf f') >>= \case
      TypeFunT TypeInfo (TermT var)
_ty Binder
orig TModality
md TermT var
a Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope Scope (FS (AnnF TypeInfo TermF)) var
b -> do
        -- A hole argument to a shape-restricted function carries the shape as
        -- its goal: record (binder : a | tope) rather than just the cube a.
        x' <- TModality -> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
md (TypeCheck var (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ case (Term var
x, Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope) of
          (Hole Maybe VarIdent
mname, Just Scope (FS (AnnF TypeInfo TermF)) var
tope) -> Maybe VarIdent
-> Binder
-> TermT var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TypeCheck var (TermT var)
forall var.
Eq var =>
Maybe VarIdent
-> Binder
-> TermT var
-> TermT (Inc var)
-> TypeCheck var (TermT var)
checkHoleAgainstShape Maybe VarIdent
mname Binder
orig TermT var
a Scope (FS (AnnF TypeInfo TermF)) var
tope
          (Term var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
_                       -> Term var -> TermT var -> TypeCheck var (TermT var)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
x TermT var
a
        let result = TermT var -> TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var -> TermT var
appT (TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
forall var.
TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
substituteT TermT var
x' Scope (FS (AnnF TypeInfo TermF)) var
b) TermT var
f' TermT var
x'
        case b of
          UniverseTopeT{} -> do
            case Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope of
              Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
Nothing -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return TermT var
result
              Just Scope (FS (AnnF TypeInfo TermF)) var
tope -> do
                TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeAndT (TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
forall var.
TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
substituteT TermT var
x' Scope (FS (AnnF TypeInfo TermF)) var
tope) TermT var
result)
          Scope (FS (AnnF TypeInfo TermF)) var
_               -> do
            (Scope (FS (AnnF TypeInfo TermF)) var
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      ())
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     ()
forall var. Eq var => TermT var -> TypeCheck var ()
contextEntails (TermT var
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      ())
-> (Scope (FS (AnnF TypeInfo TermF)) var -> TermT var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
forall var.
TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
substituteT TermT var
x') Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope   -- FIXME: need to check?
            TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return TermT var
result
      TermT var
ty -> TypeError var -> TypeCheck var (TermT var)
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var -> TypeCheck var (TermT var))
-> TypeError var -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ TermT var -> TermT var -> TypeError var
forall var. TermT var -> TermT var -> TypeError var
TypeErrorNotFunction TermT var
f' TermT var
ty

  Lambda Binder
_orig Maybe (TModality, Term var, Maybe (Scope (FS TermF) var))
Nothing Scope (FS TermF) var
_body -> do
    TypeError var -> TypeCheck var (TermT var)
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var -> TypeCheck var (TermT var))
-> TypeError var -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ Term var -> TypeError var
forall var. Term var -> TypeError var
TypeErrorCannotInferBareLambda Term var
tt
  Lambda Binder
orig (Just (TModality
md, Term var
ty, Maybe (Scope (FS TermF) var)
Nothing)) Scope (FS TermF) var
body -> do
    ty' <- TModality -> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
md (TypeCheck var (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ Term var -> TypeCheck var (TermT var)
forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
ty
    mtope <- typeOf ty' >>= \case
      -- an argument can be a type
      UniverseT{} ->
        case TermT var
ty' of
          -- except if its a TOPE universe
          UniverseTopeT{} ->
            TypeError var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      (Maybe (Scope (FS (AnnF TypeInfo TermF)) var)))
-> TypeError var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
forall a b. (a -> b) -> a -> b
$ String -> TypeError var
forall var. String -> TypeError var
TypeErrorOther String
"tope params are illegal"
          TermT var
_ -> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
forall a. Maybe a
Nothing
      -- an argument can be a cube
      UniverseCubeT{} -> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
forall a. Maybe a
Nothing
      -- an argument can be a shape
      TypeFunT TypeInfo (TermT var)
_ty Binder
_orig TModality
_md TermT var
cube Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
_mtope UniverseTopeT{} -> do
        (VarIdent
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      ())
-> [VarIdent]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ VarIdent
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     ()
forall var. VarIdent -> TypeCheck var ()
checkNameShadowing (Binder -> [VarIdent]
binderLeaves Binder
orig)
        Binder
-> TModality
-> TermT var
-> TypeCheck
     (Inc var) (Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
forall var b.
Binder
-> TModality
-> TermT var
-> TypeCheck (Inc var) b
-> TypeCheck var b
enterScope Binder
orig TModality
md TermT var
cube (TypeCheck (Inc var) (Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      (Maybe (Scope (FS (AnnF TypeInfo TermF)) var)))
-> TypeCheck
     (Inc var) (Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
forall a b. (a -> b) -> a -> b
$ do
          let tope' :: Scope (FS (AnnF TypeInfo TermF)) var
tope' = Scope (FS (AnnF TypeInfo TermF)) var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> Scope (FS (AnnF TypeInfo TermF)) var
forall var. TermT var -> TermT var -> TermT var -> TermT var
appT Scope (FS (AnnF TypeInfo TermF)) var
forall var. TermT var
topeT (var -> Inc var
forall var. var -> Inc var
S (var -> Inc var)
-> TermT var -> Scope (FS (AnnF TypeInfo TermF)) var
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
ty') (Inc var -> Scope (FS (AnnF TypeInfo TermF)) var
forall (t :: * -> * -> *) a. a -> FS t a
Pure Inc var
forall var. Inc var
Z)  -- eta expand ty'
          Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> TypeCheck
     (Inc var) (Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
forall a.
a
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return (Scope (FS (AnnF TypeInfo TermF)) var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
forall a. a -> Maybe a
Just Scope (FS (AnnF TypeInfo TermF)) var
tope')
      TermT var
kind -> TypeError var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      (Maybe (Scope (FS (AnnF TypeInfo TermF)) var)))
-> TypeError var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
forall a b. (a -> b) -> a -> b
$ Term var -> TermT var -> TypeError var
forall var. Term var -> TermT var -> TypeError var
TypeErrorInvalidArgumentType Term var
ty TermT var
kind
    mapM_ checkNameShadowing (binderLeaves orig)
    enterScope orig md ty' $ do
      maybe id localTope mtope $ do
        body' <- infer body
        ret <- typeOf body'
        return (lambdaT (typeFunT orig md ty' mtope ret) orig (Just (md, ty', mtope)) body')
  Lambda Binder
orig (Just (TModality
md, Term var
cube, Just Scope (FS TermF) var
tope)) Scope (FS TermF) var
body -> do
    cube' <- TModality -> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
md (TypeCheck var (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ Term var -> TermT var -> TypeCheck var (TermT var)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
cube TermT var
forall var. TermT var
cubeT
    mapM_ checkNameShadowing (binderLeaves orig)
    enterScope orig md cube' $ do
      tope' <- infer tope
      body' <- localTope tope' $ infer body
      ret <- typeOf body'
      return (lambdaT (typeFunT orig md cube' (Just tope') ret) orig (Just (md, cube', Just tope')) body')
  Let Binder
orig Maybe (Term var)
annot Term var
val Scope (FS TermF) var
body -> do
    val' <- Action var
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall var a.
Eq var =>
Action var -> TypeCheck var a -> TypeCheck var a
performing (Maybe VarIdent -> Action var
forall var. Maybe VarIdent -> Action var
ActionCheckLetValue (Binder -> Maybe VarIdent
binderName Binder
orig)) (TypeCheck var (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ case Maybe (Term var)
annot of
      Maybe (Term var)
Nothing -> Term var -> TypeCheck var (TermT var)
forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
val
      Just Term var
ty -> do
        bindTy <- Term var -> TermT var -> TypeCheck var (TermT var)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
ty TermT var
forall var. TermT var
universeT
        typecheck val bindTy
    bindTy <- typeOf val'
    enterScopeWithBind orig Id bindTy val' $ do
      body' <- infer body
      ret <- typeOf body'
      return (letT (substituteT val' ret) orig (Just bindTy) val' body')
  LetMod Binder
orig TModality
app TModality
inn Maybe (Term var)
annot Term var
val Scope (FS TermF) var
body -> do
    val' <- Action var
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall var a.
Eq var =>
Action var -> TypeCheck var a -> TypeCheck var a
performing (Maybe VarIdent -> Action var
forall var. Maybe VarIdent -> Action var
ActionCheckLetValue (Binder -> Maybe VarIdent
binderName Binder
orig)) (TypeCheck var (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ case Maybe (Term var)
annot of
      Maybe (Term var)
Nothing -> TModality -> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
app (TypeCheck var (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ Term var -> TypeCheck var (TermT var)
forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
val
      Just Term var
bindType -> do
        bindType' <- Term var -> TypeCheck var (TermT var)
forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
bindType
        bindUniv <- typeOf bindType'
        enterModality app $ typecheck val (typeModalT bindUniv inn bindType')
    bindTy <- typeOf val' >>= \case
      o :: TermT var
o@(TypeModalT TypeInfo (TermT var)
_ty TModality
md TermT var
t) ->
        if TModality
md TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
== TModality
inn then
          TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return TermT var
t
        else
          TypeError var -> TypeCheck var (TermT var)
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var -> TypeCheck var (TermT var))
-> TypeError var -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ Term var -> TModality -> TermT var -> TypeError var
forall var. Term var -> TModality -> TermT var -> TypeError var
TypeErrorNotModal (TermT var -> Term var
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT var
o) TModality
inn TermT var
val'
      TermT var
o -> TypeError var -> TypeCheck var (TermT var)
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var -> TypeCheck var (TermT var))
-> TypeError var -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ Term var -> TModality -> TermT var -> TypeError var
forall var. Term var -> TModality -> TermT var -> TypeError var
TypeErrorNotModal (TermT var -> Term var
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT var
o) TModality
inn TermT var
val'
    bindVal <- whnfT val' >>= \case
      ModAppT TypeInfo (TermT var)
_ty TModality
_m TermT var
t -> Maybe (TermT var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe (TermT var))
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT var -> Maybe (TermT var)
forall a. a -> Maybe a
Just TermT var
t)
      TermT var
o | TModality -> Bool
forall m. ModeTheory m => m -> Bool
isRA TModality
inn -> Maybe (TermT var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe (TermT var))
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT var -> Maybe (TermT var)
forall a. a -> Maybe a
Just (TermT var -> TModality -> TModality -> TermT var -> TermT var
forall var.
TermT var -> TModality -> TModality -> TermT var -> TermT var
modExtractT TermT var
bindTy TModality
app TModality
inn TermT var
o))
      TermT var
_ -> Maybe (TermT var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe (TermT var))
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TermT var)
forall a. Maybe a
Nothing
    enterScopeMaybe orig (comp app inn) bindTy bindVal $ do
      body' <- infer body
      ret <- typeOf body'
      return (letModT (substituteT val' ret) orig app inn (Just bindTy) val' body')
  Refl Maybe (Term var, Maybe (Term var))
Nothing -> TypeError var -> TypeCheck var (TermT var)
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var -> TypeCheck var (TermT var))
-> TypeError var -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ Term var -> TypeError var
forall var. Term var -> TypeError var
TypeErrorCannotInferBareRefl Term var
tt
  Refl (Just (Term var
x, Maybe (Term var)
Nothing)) -> do
    x' <- TermT var -> Term var -> TypeCheck var (TermT var)
forall var.
Eq var =>
TermT var -> Term var -> TypeCheck var (TermT var)
inferAs TermT var
forall var. TermT var
universeT Term var
x
    ty <- typeOf x'
    return (reflT (typeIdT x' (Just ty) x') (Just (x', Just ty)))
  Refl (Just (Term var
x, Just Term var
ty)) -> do
    ty' <- Term var -> TermT var -> TypeCheck var (TermT var)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
ty TermT var
forall var. TermT var
universeT
    x' <- typecheck x ty'
    return (reflT (typeIdT x' (Just ty') x') (Just (x', Just ty')))

  IdJ Term var
tA Term var
a Term var
tC Term var
d Term var
x Term var
p -> do
    tA' <- Term var -> TermT var -> TypeCheck var (TermT var)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
tA TermT var
forall var. TermT var
universeT
    a' <- typecheck a tA'
    let typeOf_C =
          Binder
-> TModality
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall var.
Binder
-> TModality
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeFunT (Maybe VarIdent -> Binder
BinderVar Maybe VarIdent
forall a. Maybe a
Nothing) TModality
Id TermT var
tA' Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
forall a. Maybe a
Nothing (Scope (FS (AnnF TypeInfo TermF)) var -> TermT var)
-> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
forall a b. (a -> b) -> a -> b
$
            Binder
-> TModality
-> Scope (FS (AnnF TypeInfo TermF)) var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) (Inc var))
-> Scope (FS (AnnF TypeInfo TermF)) (Inc var)
-> Scope (FS (AnnF TypeInfo TermF)) var
forall var.
Binder
-> TModality
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeFunT (Maybe VarIdent -> Binder
BinderVar Maybe VarIdent
forall a. Maybe a
Nothing) TModality
Id (Scope (FS (AnnF TypeInfo TermF)) var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> Scope (FS (AnnF TypeInfo TermF)) var
forall var.
TermT var -> Maybe (TermT var) -> TermT var -> TermT var
typeIdT (var -> Inc var
forall var. var -> Inc var
S (var -> Inc var)
-> TermT var -> Scope (FS (AnnF TypeInfo TermF)) var
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
a') (Scope (FS (AnnF TypeInfo TermF)) var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
forall a. a -> Maybe a
Just (var -> Inc var
forall var. var -> Inc var
S (var -> Inc var)
-> TermT var -> Scope (FS (AnnF TypeInfo TermF)) var
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
tA')) (Inc var -> Scope (FS (AnnF TypeInfo TermF)) var
forall (t :: * -> * -> *) a. a -> FS t a
Pure Inc var
forall var. Inc var
Z)) Maybe (Scope (FS (AnnF TypeInfo TermF)) (Inc var))
forall a. Maybe a
Nothing (Scope (FS (AnnF TypeInfo TermF)) (Inc var)
 -> Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) (Inc var)
-> Scope (FS (AnnF TypeInfo TermF)) var
forall a b. (a -> b) -> a -> b
$
              Scope (FS (AnnF TypeInfo TermF)) (Inc var)
forall var. TermT var
universeT
    tC' <- typecheck tC typeOf_C
    let typeOf_d =
          TermT var -> TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var -> TermT var
appT TermT var
forall var. TermT var
universeT
            (TermT var -> TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var -> TermT var
appT (Binder
-> TModality
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall var.
Binder
-> TModality
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeFunT (Maybe VarIdent -> Binder
BinderVar Maybe VarIdent
forall a. Maybe a
Nothing) TModality
Id (TermT var -> Maybe (TermT var) -> TermT var -> TermT var
forall var.
TermT var -> Maybe (TermT var) -> TermT var -> TermT var
typeIdT TermT var
a' (TermT var -> Maybe (TermT var)
forall a. a -> Maybe a
Just TermT var
tA') TermT var
a') Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
forall a. Maybe a
Nothing Scope (FS (AnnF TypeInfo TermF)) var
forall var. TermT var
universeT)
              TermT var
tC' TermT var
a')
            (TermT var -> Maybe (TermT var, Maybe (TermT var)) -> TermT var
forall var.
TermT var -> Maybe (TermT var, Maybe (TermT var)) -> TermT var
reflT (TermT var -> Maybe (TermT var) -> TermT var -> TermT var
forall var.
TermT var -> Maybe (TermT var) -> TermT var -> TermT var
typeIdT TermT var
a' (TermT var -> Maybe (TermT var)
forall a. a -> Maybe a
Just TermT var
tA') TermT var
a') Maybe (TermT var, Maybe (TermT var))
forall a. Maybe a
Nothing)
    d' <- typecheck d typeOf_d
    x' <- typecheck x tA'
    p' <- typecheck p (typeIdT a' (Just tA') x')
    let ret =
          TermT var -> TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var -> TermT var
appT TermT var
forall var. TermT var
universeT
            (TermT var -> TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var -> TermT var
appT (Binder
-> TModality
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall var.
Binder
-> TModality
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeFunT (Maybe VarIdent -> Binder
BinderVar Maybe VarIdent
forall a. Maybe a
Nothing) TModality
Id (TermT var -> Maybe (TermT var) -> TermT var -> TermT var
forall var.
TermT var -> Maybe (TermT var) -> TermT var -> TermT var
typeIdT TermT var
a' (TermT var -> Maybe (TermT var)
forall a. a -> Maybe a
Just TermT var
tA') TermT var
x') Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
forall a. Maybe a
Nothing Scope (FS (AnnF TypeInfo TermF)) var
forall var. TermT var
universeT)
              TermT var
tC' TermT var
x')
            TermT var
p'
    return (idJT ret tA' a' tC' d' x' p')

  TypeAsc Term var
term Term var
ty -> do
    ty' <- TermT var -> Term var -> TypeCheck var (TermT var)
forall var.
Eq var =>
TermT var -> Term var -> TypeCheck var (TermT var)
inferAs TermT var
forall var. TermT var
universeT Term var
ty -- this works on types AND cubes
    term' <- typecheck term ty'
    return (typeAscT term' ty')

  TypeRestricted Term var
ty [(Term var, Term var)]
rs -> do
    ty' <- Term var -> TermT var -> TypeCheck var (TermT var)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
ty TermT var
forall var. TermT var
universeT
    rs' <- forM rs $ \(Term var
tope, Term var
term) -> do
      tope' <- Term var -> TermT var -> TypeCheck var (TermT var)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
tope TermT var
forall var. TermT var
topeT
      term' <- localTope tope' $ typecheck term ty'
      return (tope', term')
    sequence_ [ checkCoherence l r | l:rs'' <- tails rs', r <- rs'' ]
    return (typeRestrictedT ty' rs')
  TypeModal TModality
md Term var
ty -> do
    ty' <- TModality -> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
md (TypeCheck var (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ Term var -> TypeCheck var (TermT var)
forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
ty
    universeTy <- typeOf ty'
    _ <- case universeTy of
      UniverseT {}     -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
universeTy
      UniverseCubeT {} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
universeTy
      UniverseTopeT {} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
universeTy
      TermT var
_                -> TypeError var -> TypeCheck var (TermT var)
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var -> TypeCheck var (TermT var))
-> TypeError var -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ TermT var -> TypeError var
forall var. TermT var -> TypeError var
TypeErrorNotTypeInModal TermT var
universeTy
    return (typeModalT universeTy md ty')
  ModApp TModality
md Term var
term -> do
    term' <- TModality -> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall var b. TModality -> TypeCheck var b -> TypeCheck var b
enterModality TModality
md (TypeCheck var (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ Term var -> TypeCheck var (TermT var)
forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
term
    ty <- typeOf term'
    tyUniv <- typeOf ty
    return $ modAppT (typeModalT tyUniv md ty) md term'
  ModExtract TModality
_ TModality
_ Term var
_ -> String -> TypeCheck var (TermT var)
forall a. HasCallStack => String -> a
error String
"untypable $extract$"

checkCoherence
  :: Eq var
  => (TermT var, TermT var)
  -> (TermT var, TermT var)
  -> TypeCheck var ()
checkCoherence :: forall var.
Eq var =>
(TermT var, TermT var)
-> (TermT var, TermT var) -> TypeCheck var ()
checkCoherence (TermT var
ltope, TermT var
lterm) (TermT var
rtope, TermT var
rterm) =
  Action var -> TypeCheck var () -> TypeCheck var ()
forall var a.
Eq var =>
Action var -> TypeCheck var a -> TypeCheck var a
performing ((TermT var, TermT var) -> (TermT var, TermT var) -> Action var
forall var.
(TermT var, TermT var) -> (TermT var, TermT var) -> Action var
ActionCheckCoherence (TermT var
ltope, TermT var
lterm) (TermT var
rtope, TermT var
rterm)) (TypeCheck var () -> TypeCheck var ())
-> TypeCheck var () -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$ do
    TermT var -> TypeCheck var () -> TypeCheck var ()
forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeAndT TermT var
ltope TermT var
rtope) (TypeCheck var () -> TypeCheck var ())
-> TypeCheck var () -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$ do
      ltype <- TermT var -> TermT var
forall var. TermT var -> TermT var
stripTypeRestrictions (TermT var -> TermT var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
lterm   -- FIXME: why strip?
      rtype <- stripTypeRestrictions <$> typeOf rterm   -- FIXME: why strip?
      -- FIXME: do we need to unify types here or is it included in unification of terms?
      unifyTerms ltype rtype
      unifyTerms lterm rterm

inferStandalone :: Eq var => Term var -> Either (TypeErrorInScopedContext var) (TermT var)
inferStandalone :: forall var.
Eq var =>
Term var -> Either (TypeErrorInScopedContext var) (TermT var)
inferStandalone Term var
term = TypeCheck var (TermT var)
-> Either (TypeErrorInScopedContext var) (TermT var)
forall var a.
TypeCheck var a -> Either (TypeErrorInScopedContext var) a
defaultTypeCheck (Term var -> TypeCheck var (TermT var)
forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
term)

unsafeInferStandalone' :: Term' -> TermT'
unsafeInferStandalone' :: Term VarIdent -> TermT VarIdent
unsafeInferStandalone' Term VarIdent
term = TypeCheck VarIdent (TermT VarIdent) -> TermT VarIdent
forall a. TypeCheck VarIdent a -> a
unsafeTypeCheck' (Term VarIdent -> TypeCheck VarIdent (TermT VarIdent)
forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term VarIdent
term)

unsafeTypeCheck' :: TypeCheck VarIdent a -> a
unsafeTypeCheck' :: forall a. TypeCheck VarIdent a -> a
unsafeTypeCheck' TypeCheck VarIdent a
tc =
  case TypeCheck VarIdent a
-> Either (TypeErrorInScopedContext VarIdent) a
forall var a.
TypeCheck var a -> Either (TypeErrorInScopedContext var) a
defaultTypeCheck TypeCheck VarIdent a
tc of
    Left TypeErrorInScopedContext VarIdent
err     -> String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ OutputDirection -> TypeErrorInScopedContext VarIdent -> String
ppTypeErrorInScopedContext' OutputDirection
BottomUp TypeErrorInScopedContext VarIdent
err
    Right a
result -> a
result

type PointId = String
type ShapeId = [PointId]

cube2powerT :: Int -> TermT var
cube2powerT :: forall var. Int -> TermT var
cube2powerT Int
1   = TermT var
forall var. TermT var
cube2T
cube2powerT Int
dim = TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
cubeProductT (Int -> TermT var
forall var. Int -> TermT var
cube2powerT (Int
dim Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) TermT var
forall var. TermT var
cube2T

splits :: [a] -> [([a], [a])]
splits :: forall a. [a] -> [([a], [a])]
splits [] = [([], [])]
splits (a
x:[a]
xs) = ([], a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs) ([a], [a]) -> [([a], [a])] -> [([a], [a])]
forall a. a -> [a] -> [a]
: [ (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
before, [a]
after) | ([a]
before, [a]
after) <- [a] -> [([a], [a])]
forall a. [a] -> [([a], [a])]
splits [a]
xs ]

verticesFrom :: [TermT var] -> [(ShapeId, TermT var)]
verticesFrom :: forall var. [TermT var] -> [([String], TermT var)]
verticesFrom [TermT var]
ts = [(String, TermT var)] -> ([String], TermT var)
forall {a} {var}. [([a], TermT var)] -> ([[a]], TermT var)
combine ([(String, TermT var)] -> ([String], TermT var))
-> [[(String, TermT var)]] -> [([String], TermT var)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TermT var -> [(String, TermT var)])
-> [TermT var] -> [[(String, TermT var)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TermT var -> [(String, TermT var)]
forall {a} {var}. IsString a => TermT var -> [(a, TermT var)]
mk [TermT var]
ts
  where
    mk :: TermT var -> [(a, TermT var)]
mk TermT var
t = [(a
"0", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t TermT var
forall var. TermT var
cube2_0T), (a
"1", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t TermT var
forall var. TermT var
cube2_1T)]
    combine :: [([a], TermT var)] -> ([[a]], TermT var)
combine [([a], TermT var)]
xs = ([[[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((([a], TermT var) -> [a]) -> [([a], TermT var)] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map ([a], TermT var) -> [a]
forall a b. (a, b) -> a
fst [([a], TermT var)]
xs)], (TermT var -> TermT var -> TermT var) -> [TermT var] -> TermT var
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeAndT ((([a], TermT var) -> TermT var)
-> [([a], TermT var)] -> [TermT var]
forall a b. (a -> b) -> [a] -> [b]
map ([a], TermT var) -> TermT var
forall a b. (a, b) -> b
snd [([a], TermT var)]
xs))

subTopes2 :: Int -> TermT var -> [(ShapeId, TermT var)]
-- 1-dim
subTopes2 :: forall var. Int -> TermT var -> [([String], TermT var)]
subTopes2 Int
1 TermT var
t =
  [ (String -> [String]
words String
"0", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t TermT var
forall var. TermT var
cube2_0T)
  , (String -> [String]
words String
"1", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t TermT var
forall var. TermT var
cube2_1T)
  , (String -> [String]
words String
"0 1", TermT var
forall var. TermT var
topeTopT) ]
-- 2-dim
subTopes2 Int
2 TermT var
ts =
  -- vertices
  [ (String -> [String]
words String
"00", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t TermT var
forall var. TermT var
cube2_0T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
s TermT var
forall var. TermT var
cube2_0T)
  , (String -> [String]
words String
"01", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t TermT var
forall var. TermT var
cube2_0T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
s TermT var
forall var. TermT var
cube2_1T)
  , (String -> [String]
words String
"10", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t TermT var
forall var. TermT var
cube2_1T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
s TermT var
forall var. TermT var
cube2_0T)
  , (String -> [String]
words String
"11", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t TermT var
forall var. TermT var
cube2_1T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
s TermT var
forall var. TermT var
cube2_1T)
  -- edges and the diagonal
  , (String -> [String]
words String
"00 01", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t TermT var
forall var. TermT var
cube2_0T)
  , (String -> [String]
words String
"10 11", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t TermT var
forall var. TermT var
cube2_1T)
  , (String -> [String]
words String
"00 10", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
s TermT var
forall var. TermT var
cube2_0T)
  , (String -> [String]
words String
"01 11", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
s TermT var
forall var. TermT var
cube2_1T)
  , (String -> [String]
words String
"00 11", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
s TermT var
t)
  -- triangles
  , (String -> [String]
words String
"00 01 11", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t TermT var
s)
  , (String -> [String]
words String
"00 10 11", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
s TermT var
t)
  ]
  where
    t :: TermT var
t = TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
firstT TermT var
forall var. TermT var
cube2T TermT var
ts
    s :: TermT var
s = TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
secondT TermT var
forall var. TermT var
cube2T TermT var
ts
-- 3-dim
subTopes2 Int
3 TermT var
t =
  -- vertices
  [ (String -> [String]
words String
"000", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
forall var. TermT var
cube2_0T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 TermT var
forall var. TermT var
cube2_0T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 TermT var
forall var. TermT var
cube2_0T)
  , (String -> [String]
words String
"001", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
forall var. TermT var
cube2_0T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 TermT var
forall var. TermT var
cube2_0T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 TermT var
forall var. TermT var
cube2_1T)
  , (String -> [String]
words String
"010", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
forall var. TermT var
cube2_0T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 TermT var
forall var. TermT var
cube2_1T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 TermT var
forall var. TermT var
cube2_0T)
  , (String -> [String]
words String
"011", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
forall var. TermT var
cube2_0T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 TermT var
forall var. TermT var
cube2_1T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 TermT var
forall var. TermT var
cube2_1T)
  , (String -> [String]
words String
"100", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
forall var. TermT var
cube2_1T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 TermT var
forall var. TermT var
cube2_0T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 TermT var
forall var. TermT var
cube2_0T)
  , (String -> [String]
words String
"101", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
forall var. TermT var
cube2_1T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 TermT var
forall var. TermT var
cube2_0T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 TermT var
forall var. TermT var
cube2_1T)
  , (String -> [String]
words String
"110", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
forall var. TermT var
cube2_1T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 TermT var
forall var. TermT var
cube2_1T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 TermT var
forall var. TermT var
cube2_0T)
  , (String -> [String]
words String
"111", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
forall var. TermT var
cube2_1T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 TermT var
forall var. TermT var
cube2_1T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 TermT var
forall var. TermT var
cube2_1T)
  -- edges
  , (String -> [String]
words String
"000 001", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
forall var. TermT var
cube2_0T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 TermT var
forall var. TermT var
cube2_0T)
  , (String -> [String]
words String
"010 011", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
forall var. TermT var
cube2_0T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 TermT var
forall var. TermT var
cube2_1T)
  , (String -> [String]
words String
"000 010", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
forall var. TermT var
cube2_0T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 TermT var
forall var. TermT var
cube2_0T)
  , (String -> [String]
words String
"001 011", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
forall var. TermT var
cube2_0T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 TermT var
forall var. TermT var
cube2_1T)
  , (String -> [String]
words String
"100 101", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
forall var. TermT var
cube2_1T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 TermT var
forall var. TermT var
cube2_0T)
  , (String -> [String]
words String
"110 111", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
forall var. TermT var
cube2_1T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 TermT var
forall var. TermT var
cube2_1T)
  , (String -> [String]
words String
"100 110", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
forall var. TermT var
cube2_1T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 TermT var
forall var. TermT var
cube2_0T)
  , (String -> [String]
words String
"101 111", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
forall var. TermT var
cube2_1T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 TermT var
forall var. TermT var
cube2_1T)
  , (String -> [String]
words String
"000 100", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 TermT var
forall var. TermT var
cube2_0T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 TermT var
forall var. TermT var
cube2_0T)
  , (String -> [String]
words String
"001 101", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 TermT var
forall var. TermT var
cube2_0T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 TermT var
forall var. TermT var
cube2_1T)
  , (String -> [String]
words String
"010 110", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 TermT var
forall var. TermT var
cube2_1T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 TermT var
forall var. TermT var
cube2_0T)
  , (String -> [String]
words String
"011 111", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 TermT var
forall var. TermT var
cube2_1T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 TermT var
forall var. TermT var
cube2_1T)
  -- face diagonals
  , (String -> [String]
words String
"000 011", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
forall var. TermT var
cube2_0T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 TermT var
t3)
  , (String -> [String]
words String
"100 111", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
forall var. TermT var
cube2_1T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 TermT var
t3)
  , (String -> [String]
words String
"000 101", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 TermT var
forall var. TermT var
cube2_0T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
t3)
  , (String -> [String]
words String
"010 111", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 TermT var
forall var. TermT var
cube2_1T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
t3)
  , (String -> [String]
words String
"000 110", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 TermT var
forall var. TermT var
cube2_0T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
t2)
  , (String -> [String]
words String
"001 111", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 TermT var
forall var. TermT var
cube2_1T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
t2)
  -- the long diagonal
  , (String -> [String]
words String
"000 111", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 TermT var
t2 TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 TermT var
t1)
  -- face triangles
  , (String -> [String]
words String
"000 001 011", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
forall var. TermT var
cube2_0T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t2 TermT var
t3)
  , (String -> [String]
words String
"000 010 011", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
forall var. TermT var
cube2_0T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t3 TermT var
t2)
  , (String -> [String]
words String
"100 101 111", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
forall var. TermT var
cube2_1T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t2 TermT var
t3)
  , (String -> [String]
words String
"100 110 111", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
forall var. TermT var
cube2_1T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t3 TermT var
t2)
  , (String -> [String]
words String
"000 001 101", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 TermT var
forall var. TermT var
cube2_0T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t1 TermT var
t3)
  , (String -> [String]
words String
"000 100 101", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 TermT var
forall var. TermT var
cube2_0T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t3 TermT var
t1)
  , (String -> [String]
words String
"010 011 111", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 TermT var
forall var. TermT var
cube2_1T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t1 TermT var
t3)
  , (String -> [String]
words String
"010 110 111", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 TermT var
forall var. TermT var
cube2_1T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t3 TermT var
t1)
  , (String -> [String]
words String
"000 010 110", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 TermT var
forall var. TermT var
cube2_0T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t1 TermT var
t2)
  , (String -> [String]
words String
"000 100 110", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 TermT var
forall var. TermT var
cube2_0T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t2 TermT var
t1)
  , (String -> [String]
words String
"001 011 111", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 TermT var
forall var. TermT var
cube2_1T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t1 TermT var
t2)
  , (String -> [String]
words String
"001 101 111", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 TermT var
forall var. TermT var
cube2_1T TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t2 TermT var
t1)
  -- diagonal triangles
  , (String -> [String]
words String
"000 001 111", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
t2 TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t2 TermT var
t3)
  , (String -> [String]
words String
"000 010 111", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
t3 TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t1 TermT var
t2)
  , (String -> [String]
words String
"000 100 111", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 TermT var
t3 TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t2 TermT var
t1)
  , (String -> [String]
words String
"000 011 111", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t1 TermT var
t2 TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 TermT var
t3)
  , (String -> [String]
words String
"000 101 111", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t2 TermT var
t1 TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
t3)
  , (String -> [String]
words String
"000 110 111", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t3 TermT var
t1 TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
t2)
  -- tetrahedra
  , (String -> [String]
words String
"000 001 011 111", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t1 TermT var
t2 TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t2 TermT var
t3)
  , (String -> [String]
words String
"000 010 011 111", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t1 TermT var
t3 TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t3 TermT var
t2)
  , (String -> [String]
words String
"000 001 101 111", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t2 TermT var
t1 TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t1 TermT var
t3)
  , (String -> [String]
words String
"000 100 101 111", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t2 TermT var
t3 TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t3 TermT var
t1)
  , (String -> [String]
words String
"000 010 110 111", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t3 TermT var
t1 TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t1 TermT var
t2)
  , (String -> [String]
words String
"000 100 110 111", TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t3 TermT var
t2 TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
`topeAndT` TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t2 TermT var
t1)
  ]
  where
    t1 :: TermT var
t1 = TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
firstT  TermT var
forall var. TermT var
cube2T (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
firstT (Int -> TermT var
forall var. Int -> TermT var
cube2powerT Int
2) TermT var
t)
    t2 :: TermT var
t2 = TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
secondT TermT var
forall var. TermT var
cube2T (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
firstT (Int -> TermT var
forall var. Int -> TermT var
cube2powerT Int
2) TermT var
t)
    t3 :: TermT var
t3 = TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
secondT TermT var
forall var. TermT var
cube2T TermT var
t
subTopes2 Int
dim TermT var
_ = String -> [([String], TermT var)]
forall a. HasCallStack => String -> a
error (Int -> String
forall a. Show a => a -> String
show Int
dim String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" dimensions are not supported")

cubeSubTopes :: [(ShapeId, TermT (Inc var))]
cubeSubTopes :: forall var. [([String], TermT (Inc var))]
cubeSubTopes = Int -> TermT (Inc var) -> [([String], TermT (Inc var))]
forall var. Int -> TermT var -> [([String], TermT var)]
subTopes2 Int
3 (Inc var -> TermT (Inc var)
forall (t :: * -> * -> *) a. a -> FS t a
Pure Inc var
forall var. Inc var
Z)

limitLength :: Int -> String -> String
limitLength :: Int -> String -> String
limitLength Int
n String
s
  | String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n = Int -> String -> String
forall a. Int -> [a] -> [a]
take (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"…"
  | Bool
otherwise    = String
s

-- | Apply the 'renderHideTerm' policy to a cell's render data: drop the
-- @\<title\>@ (the full term) from every cell, and blank the visible label of a
-- proof-coloured (interior) cell. Boundary cells (coloured otherwise) keep
-- their given labels. A no-op when not hiding.
hideTermData :: Bool -> String -> RenderObjectData -> RenderObjectData
hideTermData :: Bool -> String -> RenderObjectData -> RenderObjectData
hideTermData Bool
False String
_ RenderObjectData
d = RenderObjectData
d
hideTermData Bool
True  String
mainColor RenderObjectData
d
  | RenderObjectData -> String
renderObjectDataColor RenderObjectData
d String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
mainColor =
      RenderObjectData
d { renderObjectDataLabel = "", renderObjectDataFullLabel = "" }
  | Bool
otherwise = RenderObjectData
d { renderObjectDataFullLabel = "" }

renderObjectsFor
  :: Eq var
  => String
  -> Int
  -> TermT var
  -> TermT var
  -> TypeCheck var [(ShapeId, RenderObjectData)]
renderObjectsFor :: forall var.
Eq var =>
String
-> Int
-> TermT var
-> TermT var
-> TypeCheck var [([String], RenderObjectData)]
renderObjectsFor String
mainColor Int
dim TermT var
t TermT var
term = ([Maybe ([String], RenderObjectData)]
 -> [([String], RenderObjectData)])
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [Maybe ([String], RenderObjectData)]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [([String], RenderObjectData)]
forall a b.
(a -> b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe ([String], RenderObjectData)]
-> [([String], RenderObjectData)]
forall a. [Maybe a] -> [a]
catMaybes (ReaderT
   (Context var)
   (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
   [Maybe ([String], RenderObjectData)]
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      [([String], RenderObjectData)])
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [Maybe ([String], RenderObjectData)]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [([String], RenderObjectData)]
forall a b. (a -> b) -> a -> b
$ do
  [([String], TermT var)]
-> (([String], TermT var)
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         (Maybe ([String], RenderObjectData)))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [Maybe ([String], RenderObjectData)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Int -> TermT var -> [([String], TermT var)]
forall var. Int -> TermT var -> [([String], TermT var)]
subTopes2 Int
dim TermT var
t) ((([String], TermT var)
  -> ReaderT
       (Context var)
       (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
       (Maybe ([String], RenderObjectData)))
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      [Maybe ([String], RenderObjectData)])
-> (([String], TermT var)
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         (Maybe ([String], RenderObjectData)))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [Maybe ([String], RenderObjectData)]
forall a b. (a -> b) -> a -> b
$ \([String]
shapeId, TermT var
tope) -> do
    TermT var -> TypeCheck var Bool
forall var. Eq var => TermT var -> TypeCheck var Bool
checkTopeEntails TermT var
tope TypeCheck var Bool
-> (Bool
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         (Maybe ([String], RenderObjectData)))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe ([String], RenderObjectData))
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
False -> Maybe ([String], RenderObjectData)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe ([String], RenderObjectData))
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ([String], RenderObjectData)
forall a. Maybe a
Nothing
      Bool
True -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
term TypeCheck var (TermT var)
-> (TermT var
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         (Maybe ([String], RenderObjectData)))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe ([String], RenderObjectData))
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        UniverseTopeT{} -> TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe ([String], RenderObjectData))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe ([String], RenderObjectData))
forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope TermT var
term (ReaderT
   (Context var)
   (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
   (Maybe ([String], RenderObjectData))
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      (Maybe ([String], RenderObjectData)))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe ([String], RenderObjectData))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe ([String], RenderObjectData))
forall a b. (a -> b) -> a -> b
$ TermT var -> TypeCheck var Bool
forall var. Eq var => TermT var -> TypeCheck var Bool
checkTopeEntails TermT var
tope TypeCheck var Bool
-> (Bool
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         (Maybe ([String], RenderObjectData)))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe ([String], RenderObjectData))
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Bool
False -> Maybe ([String], RenderObjectData)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe ([String], RenderObjectData))
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ([String], RenderObjectData)
forall a. Maybe a
Nothing
          Bool
True -> Maybe ([String], RenderObjectData)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe ([String], RenderObjectData))
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ([String], RenderObjectData)
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      (Maybe ([String], RenderObjectData)))
-> Maybe ([String], RenderObjectData)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe ([String], RenderObjectData))
forall a b. (a -> b) -> a -> b
$ ([String], RenderObjectData) -> Maybe ([String], RenderObjectData)
forall a. a -> Maybe a
Just ([String]
shapeId, RenderObjectData
            { renderObjectDataLabel :: String
renderObjectDataLabel = String
""
            , renderObjectDataFullLabel :: String
renderObjectDataFullLabel = String
""
            , renderObjectDataColor :: String
renderObjectDataColor = String
"orange"  -- FIXME: orange for topes?
            })
        TermT var
_ -> do
          origs <- (Context var -> [(var, Maybe VarIdent)])
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [(var, Maybe VarIdent)]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context var -> [(var, Maybe VarIdent)]
forall var. Context var -> [(var, Maybe VarIdent)]
varOrigs
          term' <- localTope tope $ whnfT term
          label <-
            case term' of
              AppT TypeInfo (TermT var)
_ (Pure var
z) TermT var
arg
                | Just (Just VarIdent
"_") <- var -> [(var, Maybe VarIdent)] -> Maybe (Maybe VarIdent)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup var
z [(var, Maybe VarIdent)]
origs -> String
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     String
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
                | [var] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([var] -> [var]
forall a. Eq a => [a] -> [a]
nub (Term var -> [var]
forall a. Term a -> [a]
freeVars (TermT var -> Term var
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT var
arg)) [var] -> [var] -> [var]
forall a. Eq a => [a] -> [a] -> [a]
\\ [var] -> [var]
forall a. Eq a => [a] -> [a]
nub (Term var -> [var]
forall a. Term a -> [a]
freeVars (TermT var -> Term var
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT var
t))) ->
                    TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     String
forall var. Eq var => TermT var -> TypeCheck var String
ppTermInContext (var -> TermT var
forall (t :: * -> * -> *) a. a -> FS t a
Pure var
z)
              TermT var
_ -> TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     String
forall var. Eq var => TermT var -> TypeCheck var String
ppTermInContext TermT var
term'
          hide <- asks renderHideTerm
          return $ Just (shapeId, hideTermData hide mainColor RenderObjectData
            { renderObjectDataLabel = label
            , renderObjectDataFullLabel = label
            , renderObjectDataColor =
                case term' of
                  Pure{} -> String
"purple"
                  AppT TypeInfo (TermT var)
_ (Pure var
x) TermT var
arg
                    | Just (Just VarIdent
"_") <- var -> [(var, Maybe VarIdent)] -> Maybe (Maybe VarIdent)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup var
x [(var, Maybe VarIdent)]
origs -> String
mainColor
                    | [var] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([var] -> [var]
forall a. Eq a => [a] -> [a]
nub (Term var -> [var]
forall a. Term a -> [a]
freeVars (TermT var -> Term var
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT var
arg)) [var] -> [var] -> [var]
forall a. Eq a => [a] -> [a] -> [a]
\\ [var] -> [var]
forall a. Eq a => [a] -> [a]
nub (Term var -> [var]
forall a. Term a -> [a]
freeVars (TermT var -> Term var
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT var
t)))  -> String
"purple"
                  TermT var
_ -> String
mainColor
            })

componentWiseEQT :: Int -> TermT var -> TermT var -> TermT var
componentWiseEQT :: forall var. Int -> TermT var -> TermT var -> TermT var
componentWiseEQT Int
1 TermT var
t TermT var
s = TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t TermT var
s
componentWiseEQT Int
2 TermT var
t TermT var
s = TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeAndT
  (Int -> TermT var -> TermT var -> TermT var
forall var. Int -> TermT var -> TermT var -> TermT var
componentWiseEQT Int
1 (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
firstT  TermT var
forall var. TermT var
cube2T TermT var
t) (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
firstT  TermT var
forall var. TermT var
cube2T TermT var
s))
  (Int -> TermT var -> TermT var -> TermT var
forall var. Int -> TermT var -> TermT var -> TermT var
componentWiseEQT Int
1 (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
secondT TermT var
forall var. TermT var
cube2T TermT var
t) (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
secondT TermT var
forall var. TermT var
cube2T TermT var
s))
componentWiseEQT Int
3 TermT var
t TermT var
s = TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeAndT
  (Int -> TermT var -> TermT var -> TermT var
forall var. Int -> TermT var -> TermT var -> TermT var
componentWiseEQT Int
2 (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
firstT  (Int -> TermT var
forall var. Int -> TermT var
cube2powerT Int
2) TermT var
t) (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
firstT (Int -> TermT var
forall var. Int -> TermT var
cube2powerT Int
2) TermT var
s))
  (Int -> TermT var -> TermT var -> TermT var
forall var. Int -> TermT var -> TermT var -> TermT var
componentWiseEQT Int
1 (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
secondT TermT var
forall var. TermT var
cube2T TermT var
t) (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
secondT TermT var
forall var. TermT var
cube2T TermT var
s))
componentWiseEQT Int
dim TermT var
_ TermT var
_ = String -> TermT var
forall a. HasCallStack => String -> a
error (String
"cannot work with " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
dim String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" dimensions")

renderObjectsInSubShapeFor
  :: Eq var
  => String
  -> Int
  -> [var]
  -> var
  -> TermT var
  -> TermT var
  -> TermT var
  -> TypeCheck var [(ShapeId, RenderObjectData)]
renderObjectsInSubShapeFor :: forall var.
Eq var =>
String
-> Int
-> [var]
-> var
-> TermT var
-> TermT var
-> TermT var
-> TypeCheck var [([String], RenderObjectData)]
renderObjectsInSubShapeFor String
mainColor Int
dim [var]
sub var
super TermT var
retType TermT var
f TermT var
x = ([Maybe ([String], RenderObjectData)]
 -> [([String], RenderObjectData)])
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [Maybe ([String], RenderObjectData)]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [([String], RenderObjectData)]
forall a b.
(a -> b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe ([String], RenderObjectData)]
-> [([String], RenderObjectData)]
forall a. [Maybe a] -> [a]
catMaybes (ReaderT
   (Context var)
   (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
   [Maybe ([String], RenderObjectData)]
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      [([String], RenderObjectData)])
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [Maybe ([String], RenderObjectData)]
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [([String], RenderObjectData)]
forall a b. (a -> b) -> a -> b
$ do
  let reduceContext :: [ModalTope var] -> TermT var
reduceContext
        = (TermT var -> TermT var -> TermT var)
-> TermT var -> [TermT var] -> TermT var
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeOrT TermT var
forall var. TermT var
topeBottomT
        ([TermT var] -> TermT var)
-> ([ModalTope var] -> [TermT var]) -> [ModalTope var] -> TermT var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([TermT var] -> TermT var) -> [[TermT var]] -> [TermT var]
forall a b. (a -> b) -> [a] -> [b]
map ((TermT var -> TermT var -> TermT var)
-> TermT var -> [TermT var] -> TermT var
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeAndT TermT var
forall var. TermT var
topeTopT)
        ([[TermT var]] -> [TermT var])
-> ([ModalTope var] -> [[TermT var]])
-> [ModalTope var]
-> [TermT var]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([TermT var] -> [TermT var]) -> [[TermT var]] -> [[TermT var]]
forall a b. (a -> b) -> [a] -> [b]
map ((TermT var -> Bool) -> [TermT var] -> [TermT var]
forall a. (a -> Bool) -> [a] -> [a]
filter (\TermT var
tope -> (var -> Bool) -> [var] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (var -> TermT var -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` TermT var
tope) [var]
sub))
        ([[TermT var]] -> [[TermT var]])
-> ([ModalTope var] -> [[TermT var]])
-> [ModalTope var]
-> [[TermT var]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([ModalTope var] -> [TermT var])
-> [[ModalTope var]] -> [[TermT var]]
forall a b. (a -> b) -> [a] -> [b]
map ((ModalTope var -> TermT var) -> [ModalTope var] -> [TermT var]
forall a b. (a -> b) -> [a] -> [b]
map ModalTope var -> TermT var
forall var. ModalTope var -> TermT var
tTope)
        ([[ModalTope var]] -> [[TermT var]])
-> ([ModalTope var] -> [[ModalTope var]])
-> [ModalTope var]
-> [[TermT var]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([ModalTope var] -> [ModalTope var])
-> [[ModalTope var]] -> [[ModalTope var]]
forall a b. (a -> b) -> [a] -> [b]
map ([TermT var] -> [ModalTope var] -> [ModalTope var]
forall var.
Eq var =>
[TermT var] -> [ModalTope var] -> [ModalTope var]
saturateTopes [])
        ([[ModalTope var]] -> [[ModalTope var]])
-> ([ModalTope var] -> [[ModalTope var]])
-> [ModalTope var]
-> [[ModalTope var]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ModalTope var] -> [[ModalTope var]]
forall var. Eq var => [ModalTope var] -> [[ModalTope var]]
simplifyLHSwithDisjunctions
  contextTopes  <- (Context var -> TermT var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (TermT var)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ([ModalTope var] -> TermT var
reduceContext ([ModalTope var] -> TermT var)
-> (Context var -> [ModalTope var]) -> Context var -> TermT var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context var -> [ModalTope var]
forall var. Context var -> [ModalTope var]
localTopesNF)
  contextTopes' <- localTope (componentWiseEQT dim (Pure super) x) $ asks (reduceContext . localTopesNF)
  forM (subTopes2 dim (Pure super)) $ \([String]
shapeId, TermT var
tope) -> do
    TermT var -> TermT var -> TypeCheck var Bool
forall var. Eq var => TermT var -> TermT var -> TypeCheck var Bool
checkEntails TermT var
tope TermT var
contextTopes TypeCheck var Bool
-> (Bool
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         (Maybe ([String], RenderObjectData)))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe ([String], RenderObjectData))
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
False -> Maybe ([String], RenderObjectData)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe ([String], RenderObjectData))
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ([String], RenderObjectData)
forall a. Maybe a
Nothing
      Bool
True -> do
        origs <- (Context var -> [(var, Maybe VarIdent)])
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     [(var, Maybe VarIdent)]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context var -> [(var, Maybe VarIdent)]
forall var. Context var -> [(var, Maybe VarIdent)]
varOrigs
        term <- localTope tope (whnfT (appT retType f (Pure super)))
        label <- typeOf term >>= \case
          UniverseTopeT{} -> String
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     String
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
          TermT var
_ -> do
            case TermT var
term of
              AppT TypeInfo (TermT var)
_ (Pure var
z) TermT var
arg
                | Just (Just VarIdent
"_") <- var -> [(var, Maybe VarIdent)] -> Maybe (Maybe VarIdent)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup var
z [(var, Maybe VarIdent)]
origs -> String
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     String
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
                | [var] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([var] -> [var]
forall a. Eq a => [a] -> [a]
nub (Term var -> [var]
forall a. Term a -> [a]
freeVars (TermT var -> Term var
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT var
arg)) [var] -> [var] -> [var]
forall a. Eq a => [a] -> [a] -> [a]
\\ [var
super]) -> TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     String
forall var. Eq var => TermT var -> TypeCheck var String
ppTermInContext (var -> TermT var
forall (t :: * -> * -> *) a. a -> FS t a
Pure var
z)
              TermT var
_ -> TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     String
forall var. Eq var => TermT var -> TypeCheck var String
ppTermInContext TermT var
term
        color <- checkEntails tope contextTopes' >>= \case
          Bool
True -> do
            case TermT var
term of
              Pure{} -> String
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     String
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return String
"purple"
              AppT TypeInfo (TermT var)
_ (Pure var
z) TermT var
arg
                | Just (Just VarIdent
"_") <- var -> [(var, Maybe VarIdent)] -> Maybe (Maybe VarIdent)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup var
z [(var, Maybe VarIdent)]
origs -> String
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     String
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return String
mainColor
                | [var] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([var] -> [var]
forall a. Eq a => [a] -> [a]
nub (Term var -> [var]
forall a. Term a -> [a]
freeVars (TermT var -> Term var
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT var
arg)) [var] -> [var] -> [var]
forall a. Eq a => [a] -> [a] -> [a]
\\ [var
super]) -> String
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     String
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return String
"purple"
              TermT var
_ -> String
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     String
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return String
mainColor
          Bool
False -> String
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     String
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return String
"gray"
        hide <- asks renderHideTerm
        return $ Just (shapeId, hideTermData hide mainColor RenderObjectData
          { renderObjectDataLabel = label
          , renderObjectDataFullLabel = label
          , renderObjectDataColor = color
          })

renderForSubShapeSVG
  :: Eq var
  => String
  -> Int
  -> [var]
  -> var
  -> TermT var
  -> TermT var
  -> TermT var
  -> TypeCheck var String
renderForSubShapeSVG :: forall var.
Eq var =>
String
-> Int
-> [var]
-> var
-> TermT var
-> TermT var
-> TermT var
-> TypeCheck var String
renderForSubShapeSVG String
mainColor Int
dim [var]
sub var
super TermT var
retType TermT var
f TermT var
x = do
  objects <- String
-> Int
-> [var]
-> var
-> TermT var
-> TermT var
-> TermT var
-> TypeCheck var [([String], RenderObjectData)]
forall var.
Eq var =>
String
-> Int
-> [var]
-> var
-> TermT var
-> TermT var
-> TermT var
-> TypeCheck var [([String], RenderObjectData)]
renderObjectsInSubShapeFor String
mainColor Int
dim [var]
sub var
super TermT var
retType TermT var
f TermT var
x
  let objects' = (([String], RenderObjectData) -> (String, RenderObjectData))
-> [([String], RenderObjectData)] -> [(String, RenderObjectData)]
forall a b. (a -> b) -> [a] -> [b]
map ([String], RenderObjectData) -> (String, RenderObjectData)
forall {b}. ([String], b) -> (String, b)
mk [([String], RenderObjectData)]
objects
  return $ renderCube defaultCamera (if dim > 2 then (pi/7) else 0) $ \String
obj ->
    String -> [(String, RenderObjectData)] -> Maybe RenderObjectData
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
obj [(String, RenderObjectData)]
objects'
  where
    mk :: ([String], b) -> (String, b)
mk ([String]
shapeId, b
renderData) = (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"-" ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
fill [String]
shapeId), b
renderData)
    fill :: String -> String
fill String
xs = String
xs String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
xs) Char
'1'

renderForSVG :: Eq var => String -> Int -> TermT var -> TermT var -> TypeCheck var String
renderForSVG :: forall var.
Eq var =>
String -> Int -> TermT var -> TermT var -> TypeCheck var String
renderForSVG String
mainColor Int
dim TermT var
t TermT var
term = do
  objects <- String
-> Int
-> TermT var
-> TermT var
-> TypeCheck var [([String], RenderObjectData)]
forall var.
Eq var =>
String
-> Int
-> TermT var
-> TermT var
-> TypeCheck var [([String], RenderObjectData)]
renderObjectsFor String
mainColor Int
dim TermT var
t TermT var
term
  let objects' = (([String], RenderObjectData) -> (String, RenderObjectData))
-> [([String], RenderObjectData)] -> [(String, RenderObjectData)]
forall a b. (a -> b) -> [a] -> [b]
map ([String], RenderObjectData) -> (String, RenderObjectData)
forall {b}. ([String], b) -> (String, b)
mk [([String], RenderObjectData)]
objects
  return $ renderCube defaultCamera (if dim > 2 then (pi/7) else 0) $ \String
obj ->
    String -> [(String, RenderObjectData)] -> Maybe RenderObjectData
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
obj [(String, RenderObjectData)]
objects'
  where
    mk :: ([String], b) -> (String, b)
mk ([String]
shapeId, b
renderData) = (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"-" ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
fill [String]
shapeId), b
renderData)
    fill :: String -> String
fill String
xs = String
xs String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
xs) Char
'1'

renderTermSVGFor
  :: Eq var
  => String -- ^ Main color.
  -> Int    -- ^ Accumulated dimensions so far (from 0 to 3).
  -> (Maybe (TermT var, TermT var), [var])  -- ^ Accumulated point term (and its time).
  -> TermT var  -- ^ Term to render.
  -> TypeCheck var (Maybe String)
renderTermSVGFor :: forall var.
Eq var =>
String
-> Int
-> (Maybe (TermT var, TermT var), [var])
-> TermT var
-> TypeCheck var (Maybe String)
renderTermSVGFor String
mainColor Int
accDim (Maybe (TermT var, TermT var)
mp, [var]
xs) TermT var
t = do
  t' <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
t
  ty <- typeOf t'
  case t of -- check unevaluated term
    AppT TypeInfo (TermT var)
_info TermT var
f TermT var
x -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
f TypeCheck var (TermT var)
-> (TermT var
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         (Maybe String))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe String)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      TypeFunT TypeInfo (TermT var)
_ Binder
fOrig TModality
md TermT var
fArg Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtopeArg Scope (FS (AnnF TypeInfo TermF)) var
ret | Just Int
dim <- TermT var -> Maybe Int
forall {ann :: * -> *} {a}. FS (AnnF ann TermF) a -> Maybe Int
dimOf TermT var
fArg, Int
dim Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxDim -> do
        Binder
-> TModality
-> TermT var
-> TypeCheck (Inc var) (Maybe String)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe String)
forall var b.
Binder
-> TModality
-> TermT var
-> TypeCheck (Inc var) b
-> TypeCheck var b
enterScope Binder
fOrig TModality
md TermT var
fArg (TypeCheck (Inc var) (Maybe String)
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      (Maybe String))
-> TypeCheck (Inc var) (Maybe String)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
          (TypeCheck (Inc var) (Maybe String)
 -> TypeCheck (Inc var) (Maybe String))
-> (Scope (FS (AnnF TypeInfo TermF)) var
    -> TypeCheck (Inc var) (Maybe String)
    -> TypeCheck (Inc var) (Maybe String))
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> TypeCheck (Inc var) (Maybe String)
-> TypeCheck (Inc var) (Maybe String)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TypeCheck (Inc var) (Maybe String)
-> TypeCheck (Inc var) (Maybe String)
forall a. a -> a
id Scope (FS (AnnF TypeInfo TermF)) var
-> TypeCheck (Inc var) (Maybe String)
-> TypeCheck (Inc var) (Maybe String)
forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtopeArg (TypeCheck (Inc var) (Maybe String)
 -> TypeCheck (Inc var) (Maybe String))
-> TypeCheck (Inc var) (Maybe String)
-> TypeCheck (Inc var) (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
            String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     String
-> TypeCheck (Inc var) (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> Int
-> [Inc var]
-> Inc var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     String
forall var.
Eq var =>
String
-> Int
-> [var]
-> var
-> TermT var
-> TermT var
-> TermT var
-> TypeCheck var String
renderForSubShapeSVG String
mainColor Int
dim ((var -> Inc var) -> [var] -> [Inc var]
forall a b. (a -> b) -> [a] -> [b]
map var -> Inc var
forall var. var -> Inc var
S [var]
xs) Inc var
forall var. Inc var
Z Scope (FS (AnnF TypeInfo TermF)) var
ret (var -> Inc var
forall var. var -> Inc var
S (var -> Inc var)
-> TermT var -> Scope (FS (AnnF TypeInfo TermF)) var
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
f) (var -> Inc var
forall var. var -> Inc var
S (var -> Inc var)
-> TermT var -> Scope (FS (AnnF TypeInfo TermF)) var
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
x)  -- FIXME: breaks for 2 * (2 * 2), but works for 2 * 2 * 2 = (2 * 2) * 2
      TermT var
_ -> ((TermT var, TermT var)
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      String)
-> Maybe (TermT var, TermT var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe String)
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) -> Maybe a -> f (Maybe b)
traverse (\(TermT var
p', TermT var
_) -> String
-> Int
-> TermT var
-> TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     String
forall var.
Eq var =>
String -> Int -> TermT var -> TermT var -> TypeCheck var String
renderForSVG String
mainColor Int
accDim TermT var
p' TermT var
t') Maybe (TermT var, TermT var)
mp
    TypeFunT TypeInfo (TermT var)
_ Binder
_orig' TModality
md' TermT var
_ Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
_ Scope (FS (AnnF TypeInfo TermF)) var
_ | [var] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [var]
xs -> Binder
-> TModality
-> TermT var
-> TypeCheck (Inc var) (Maybe String)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe String)
forall var b.
Binder
-> TModality
-> TermT var
-> TypeCheck (Inc var) b
-> TypeCheck var b
enterScope (Maybe VarIdent -> Binder
BinderVar (VarIdent -> Maybe VarIdent
forall a. a -> Maybe a
Just VarIdent
"_")) TModality
md' TermT var
t' (TypeCheck (Inc var) (Maybe String)
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      (Maybe String))
-> TypeCheck (Inc var) (Maybe String)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
      String
-> Int
-> (Maybe
      (Scope (FS (AnnF TypeInfo TermF)) var,
       Scope (FS (AnnF TypeInfo TermF)) var),
    [Inc var])
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TypeCheck (Inc var) (Maybe String)
forall var.
Eq var =>
String
-> Int
-> (Maybe (TermT var, TermT var), [var])
-> TermT var
-> TypeCheck var (Maybe String)
renderTermSVGFor String
"blue" Int
0 (Maybe
  (Scope (FS (AnnF TypeInfo TermF)) var,
   Scope (FS (AnnF TypeInfo TermF)) var)
forall a. Maybe a
Nothing, []) (Inc var -> Scope (FS (AnnF TypeInfo TermF)) var
forall (t :: * -> * -> *) a. a -> FS t a
Pure Inc var
forall var. Inc var
Z)  -- use blue for types

    TermT var
_ -> case TermT var
t' of -- check evaluated term
      AppT TypeInfo (TermT var)
_info TermT var
f TermT var
x -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
f TypeCheck var (TermT var)
-> (TermT var
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         (Maybe String))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe String)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        TypeFunT TypeInfo (TermT var)
_ Binder
fOrig TModality
md TermT var
fArg Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtopeArg Scope (FS (AnnF TypeInfo TermF)) var
ret | Just Int
dim <- TermT var -> Maybe Int
forall {ann :: * -> *} {a}. FS (AnnF ann TermF) a -> Maybe Int
dimOf TermT var
fArg, Int
dim Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxDim -> do
          Binder
-> TModality
-> TermT var
-> TypeCheck (Inc var) (Maybe String)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe String)
forall var b.
Binder
-> TModality
-> TermT var
-> TypeCheck (Inc var) b
-> TypeCheck var b
enterScope Binder
fOrig TModality
md TermT var
fArg (TypeCheck (Inc var) (Maybe String)
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      (Maybe String))
-> TypeCheck (Inc var) (Maybe String)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
            (TypeCheck (Inc var) (Maybe String)
 -> TypeCheck (Inc var) (Maybe String))
-> (Scope (FS (AnnF TypeInfo TermF)) var
    -> TypeCheck (Inc var) (Maybe String)
    -> TypeCheck (Inc var) (Maybe String))
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> TypeCheck (Inc var) (Maybe String)
-> TypeCheck (Inc var) (Maybe String)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TypeCheck (Inc var) (Maybe String)
-> TypeCheck (Inc var) (Maybe String)
forall a. a -> a
id Scope (FS (AnnF TypeInfo TermF)) var
-> TypeCheck (Inc var) (Maybe String)
-> TypeCheck (Inc var) (Maybe String)
forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtopeArg (TypeCheck (Inc var) (Maybe String)
 -> TypeCheck (Inc var) (Maybe String))
-> TypeCheck (Inc var) (Maybe String)
-> TypeCheck (Inc var) (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
              String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     String
-> TypeCheck (Inc var) (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> Int
-> [Inc var]
-> Inc var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     String
forall var.
Eq var =>
String
-> Int
-> [var]
-> var
-> TermT var
-> TermT var
-> TermT var
-> TypeCheck var String
renderForSubShapeSVG String
mainColor Int
dim ((var -> Inc var) -> [var] -> [Inc var]
forall a b. (a -> b) -> [a] -> [b]
map var -> Inc var
forall var. var -> Inc var
S [var]
xs) Inc var
forall var. Inc var
Z Scope (FS (AnnF TypeInfo TermF)) var
ret (var -> Inc var
forall var. var -> Inc var
S (var -> Inc var)
-> TermT var -> Scope (FS (AnnF TypeInfo TermF)) var
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
f) (var -> Inc var
forall var. var -> Inc var
S (var -> Inc var)
-> TermT var -> Scope (FS (AnnF TypeInfo TermF)) var
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
x)  -- FIXME: breaks for 2 * (2 * 2), but works for 2 * 2 * 2 = (2 * 2) * 2
        TermT var
_ -> ((TermT var, TermT var)
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      String)
-> Maybe (TermT var, TermT var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe String)
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) -> Maybe a -> f (Maybe b)
traverse (\(TermT var
p', TermT var
_) -> String
-> Int
-> TermT var
-> TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     String
forall var.
Eq var =>
String -> Int -> TermT var -> TermT var -> TypeCheck var String
renderForSVG String
mainColor Int
accDim TermT var
p' TermT var
t') Maybe (TermT var, TermT var)
mp
      TypeFunT TypeInfo (TermT var)
_ Binder
_orig' TModality
md' TermT var
_ Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
_ Scope (FS (AnnF TypeInfo TermF)) var
_ | [var] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [var]
xs -> Binder
-> TModality
-> TermT var
-> TypeCheck (Inc var) (Maybe String)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe String)
forall var b.
Binder
-> TModality
-> TermT var
-> TypeCheck (Inc var) b
-> TypeCheck var b
enterScope (Maybe VarIdent -> Binder
BinderVar (VarIdent -> Maybe VarIdent
forall a. a -> Maybe a
Just VarIdent
"_")) TModality
md' TermT var
t' (TypeCheck (Inc var) (Maybe String)
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      (Maybe String))
-> TypeCheck (Inc var) (Maybe String)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
        String
-> Int
-> (Maybe
      (Scope (FS (AnnF TypeInfo TermF)) var,
       Scope (FS (AnnF TypeInfo TermF)) var),
    [Inc var])
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TypeCheck (Inc var) (Maybe String)
forall var.
Eq var =>
String
-> Int
-> (Maybe (TermT var, TermT var), [var])
-> TermT var
-> TypeCheck var (Maybe String)
renderTermSVGFor String
"blue" Int
0 (Maybe
  (Scope (FS (AnnF TypeInfo TermF)) var,
   Scope (FS (AnnF TypeInfo TermF)) var)
forall a. Maybe a
Nothing, []) (Inc var -> Scope (FS (AnnF TypeInfo TermF)) var
forall (t :: * -> * -> *) a. a -> FS t a
Pure Inc var
forall var. Inc var
Z)  -- use blue for types

      TermT var
_ -> case TermT var
ty of -- check type of the term
        TypeFunT TypeInfo (TermT var)
_ Binder
orig TModality
md TermT var
arg Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope Scope (FS (AnnF TypeInfo TermF)) var
ret
          | Just Int
dim <- TermT var -> Maybe Int
forall {ann :: * -> *} {a}. FS (AnnF ann TermF) a -> Maybe Int
dimOf TermT var
arg, Int
accDim Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
dim Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxDim -> Binder
-> TModality
-> TermT var
-> TypeCheck (Inc var) (Maybe String)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe String)
forall var b.
Binder
-> TModality
-> TermT var
-> TypeCheck (Inc var) b
-> TypeCheck var b
enterScope Binder
orig TModality
md TermT var
arg (TypeCheck (Inc var) (Maybe String)
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      (Maybe String))
-> TypeCheck (Inc var) (Maybe String)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
              (TypeCheck (Inc var) (Maybe String)
 -> TypeCheck (Inc var) (Maybe String))
-> (Scope (FS (AnnF TypeInfo TermF)) var
    -> TypeCheck (Inc var) (Maybe String)
    -> TypeCheck (Inc var) (Maybe String))
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> TypeCheck (Inc var) (Maybe String)
-> TypeCheck (Inc var) (Maybe String)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TypeCheck (Inc var) (Maybe String)
-> TypeCheck (Inc var) (Maybe String)
forall a. a -> a
id Scope (FS (AnnF TypeInfo TermF)) var
-> TypeCheck (Inc var) (Maybe String)
-> TypeCheck (Inc var) (Maybe String)
forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope (TypeCheck (Inc var) (Maybe String)
 -> TypeCheck (Inc var) (Maybe String))
-> TypeCheck (Inc var) (Maybe String)
-> TypeCheck (Inc var) (Maybe String)
forall a b. (a -> b) -> a -> b
$
                String
-> Int
-> (Maybe
      (Scope (FS (AnnF TypeInfo TermF)) var,
       Scope (FS (AnnF TypeInfo TermF)) var),
    [Inc var])
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TypeCheck (Inc var) (Maybe String)
forall var.
Eq var =>
String
-> Int
-> (Maybe (TermT var, TermT var), [var])
-> TermT var
-> TypeCheck var (Maybe String)
renderTermSVGFor String
mainColor (Int
accDim Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
dim)
                  (Maybe
  (Scope (FS (AnnF TypeInfo TermF)) var,
   Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> Maybe
     (Scope (FS (AnnF TypeInfo TermF)) var,
      Scope (FS (AnnF TypeInfo TermF)) var)
forall {var}.
Maybe (FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var
-> Maybe
     (FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)
join' ((TermT var -> Scope (FS (AnnF TypeInfo TermF)) var)
-> (TermT var, TermT var)
-> (Scope (FS (AnnF TypeInfo TermF)) var,
    Scope (FS (AnnF TypeInfo TermF)) var)
forall {t} {b}. (t -> b) -> (t, t) -> (b, b)
both ((var -> Inc var)
-> TermT var -> Scope (FS (AnnF TypeInfo TermF)) var
forall a b.
(a -> b)
-> FS (AnnF TypeInfo TermF) a -> FS (AnnF TypeInfo TermF) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap var -> Inc var
forall var. var -> Inc var
S) ((TermT var, TermT var)
 -> (Scope (FS (AnnF TypeInfo TermF)) var,
     Scope (FS (AnnF TypeInfo TermF)) var))
-> Maybe (TermT var, TermT var)
-> Maybe
     (Scope (FS (AnnF TypeInfo TermF)) var,
      Scope (FS (AnnF TypeInfo TermF)) var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (TermT var, TermT var)
mp) (var -> Inc var
forall var. var -> Inc var
S (var -> Inc var)
-> TermT var -> Scope (FS (AnnF TypeInfo TermF)) var
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
arg) (Inc var -> Scope (FS (AnnF TypeInfo TermF)) var
forall (t :: * -> * -> *) a. a -> FS t a
Pure Inc var
forall var. Inc var
Z), Inc var
forall var. Inc var
Z Inc var -> [Inc var] -> [Inc var]
forall a. a -> [a] -> [a]
: (var -> Inc var) -> [var] -> [Inc var]
forall a b. (a -> b) -> [a] -> [b]
map var -> Inc var
forall var. var -> Inc var
S [var]
xs) (Scope (FS (AnnF TypeInfo TermF)) var
 -> TypeCheck (Inc var) (Maybe String))
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TypeCheck (Inc var) (Maybe String)
forall a b. (a -> b) -> a -> b
$
                    case TermT var
t' of
                      LambdaT TypeInfo (TermT var)
_ Binder
_orig Maybe
  (TModality, TermT var,
   Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
_marg Scope (FS (AnnF TypeInfo TermF)) var
body -> Scope (FS (AnnF TypeInfo TermF)) var
body
                      TermT var
_                          -> Scope (FS (AnnF TypeInfo TermF)) var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> Scope (FS (AnnF TypeInfo TermF)) var
forall var. TermT var -> TermT var -> TermT var -> TermT var
appT Scope (FS (AnnF TypeInfo TermF)) var
ret (var -> Inc var
forall var. var -> Inc var
S (var -> Inc var)
-> TermT var -> Scope (FS (AnnF TypeInfo TermF)) var
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
t') (Inc var -> Scope (FS (AnnF TypeInfo TermF)) var
forall (t :: * -> * -> *) a. a -> FS t a
Pure Inc var
forall var. Inc var
Z)
          | [var] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [var]
xs -> Binder
-> TModality
-> TermT var
-> TypeCheck (Inc var) (Maybe String)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe String)
forall var b.
Binder
-> TModality
-> TermT var
-> TypeCheck (Inc var) b
-> TypeCheck var b
enterScope Binder
orig TModality
md TermT var
arg (TypeCheck (Inc var) (Maybe String)
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      (Maybe String))
-> TypeCheck (Inc var) (Maybe String)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
              (TypeCheck (Inc var) (Maybe String)
 -> TypeCheck (Inc var) (Maybe String))
-> (Scope (FS (AnnF TypeInfo TermF)) var
    -> TypeCheck (Inc var) (Maybe String)
    -> TypeCheck (Inc var) (Maybe String))
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> TypeCheck (Inc var) (Maybe String)
-> TypeCheck (Inc var) (Maybe String)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TypeCheck (Inc var) (Maybe String)
-> TypeCheck (Inc var) (Maybe String)
forall a. a -> a
id Scope (FS (AnnF TypeInfo TermF)) var
-> TypeCheck (Inc var) (Maybe String)
-> TypeCheck (Inc var) (Maybe String)
forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope (TypeCheck (Inc var) (Maybe String)
 -> TypeCheck (Inc var) (Maybe String))
-> TypeCheck (Inc var) (Maybe String)
-> TypeCheck (Inc var) (Maybe String)
forall a b. (a -> b) -> a -> b
$
                String
-> Int
-> (Maybe
      (Scope (FS (AnnF TypeInfo TermF)) var,
       Scope (FS (AnnF TypeInfo TermF)) var),
    [Inc var])
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TypeCheck (Inc var) (Maybe String)
forall var.
Eq var =>
String
-> Int
-> (Maybe (TermT var, TermT var), [var])
-> TermT var
-> TypeCheck var (Maybe String)
renderTermSVGFor String
mainColor Int
accDim
                  ((TermT var -> Scope (FS (AnnF TypeInfo TermF)) var)
-> (TermT var, TermT var)
-> (Scope (FS (AnnF TypeInfo TermF)) var,
    Scope (FS (AnnF TypeInfo TermF)) var)
forall {t} {b}. (t -> b) -> (t, t) -> (b, b)
both ((var -> Inc var)
-> TermT var -> Scope (FS (AnnF TypeInfo TermF)) var
forall a b.
(a -> b)
-> FS (AnnF TypeInfo TermF) a -> FS (AnnF TypeInfo TermF) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap var -> Inc var
forall var. var -> Inc var
S) ((TermT var, TermT var)
 -> (Scope (FS (AnnF TypeInfo TermF)) var,
     Scope (FS (AnnF TypeInfo TermF)) var))
-> Maybe (TermT var, TermT var)
-> Maybe
     (Scope (FS (AnnF TypeInfo TermF)) var,
      Scope (FS (AnnF TypeInfo TermF)) var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (TermT var, TermT var)
mp, (var -> Inc var) -> [var] -> [Inc var]
forall a b. (a -> b) -> [a] -> [b]
map var -> Inc var
forall var. var -> Inc var
S [var]
xs) (Scope (FS (AnnF TypeInfo TermF)) var
 -> TypeCheck (Inc var) (Maybe String))
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TypeCheck (Inc var) (Maybe String)
forall a b. (a -> b) -> a -> b
$
                    case TermT var
t' of
                      LambdaT TypeInfo (TermT var)
_ Binder
_orig Maybe
  (TModality, TermT var,
   Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
_marg Scope (FS (AnnF TypeInfo TermF)) var
body -> Scope (FS (AnnF TypeInfo TermF)) var
body
                      TermT var
_                          -> Scope (FS (AnnF TypeInfo TermF)) var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> Scope (FS (AnnF TypeInfo TermF)) var
forall var. TermT var -> TermT var -> TermT var -> TermT var
appT Scope (FS (AnnF TypeInfo TermF)) var
ret (var -> Inc var
forall var. var -> Inc var
S (var -> Inc var)
-> TermT var -> Scope (FS (AnnF TypeInfo TermF)) var
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
t') (Inc var -> Scope (FS (AnnF TypeInfo TermF)) var
forall (t :: * -> * -> *) a. a -> FS t a
Pure Inc var
forall var. Inc var
Z)
        TermT var
_ -> ((TermT var, TermT var)
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      String)
-> Maybe (TermT var, TermT var)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe String)
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) -> Maybe a -> f (Maybe b)
traverse (\(TermT var
p', TermT var
_) -> String
-> Int
-> TermT var
-> TermT var
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     String
forall var.
Eq var =>
String -> Int -> TermT var -> TermT var -> TypeCheck var String
renderForSVG String
mainColor Int
accDim TermT var
p' TermT var
t') Maybe (TermT var, TermT var)
mp
  where
    maxDim :: Int
maxDim = Int
3

    both :: (t -> b) -> (t, t) -> (b, b)
both t -> b
f (t
x, t
y) = (t -> b
f t
x, t -> b
f t
y)

    join' :: Maybe (FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var
-> Maybe
     (FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)
join' Maybe (FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)
Nothing Cube2T{} FS (AnnF TypeInfo TermF) var
x = (FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)
-> Maybe
     (FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)
forall a. a -> Maybe a
Just (FS (AnnF TypeInfo TermF) var
x, FS (AnnF TypeInfo TermF) var
forall var. TermT var
cube2T)
    join' (Just (FS (AnnF TypeInfo TermF) var
p, FS (AnnF TypeInfo TermF) var
pt)) Cube2T{} FS (AnnF TypeInfo TermF) var
x = (FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)
-> Maybe
     (FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)
forall a. a -> Maybe a
Just (FS (AnnF TypeInfo TermF) var
p', FS (AnnF TypeInfo TermF) var
pt')
      where
        pt' :: FS (AnnF TypeInfo TermF) var
pt' = FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var -> FS (AnnF TypeInfo TermF) var
forall var. TermT var -> TermT var -> TermT var
cubeProductT FS (AnnF TypeInfo TermF) var
pt FS (AnnF TypeInfo TermF) var
forall var. TermT var
cube2T
        p' :: FS (AnnF TypeInfo TermF) var
p' = FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var
forall var. TermT var -> TermT var -> TermT var -> TermT var
pairT FS (AnnF TypeInfo TermF) var
pt' FS (AnnF TypeInfo TermF) var
p FS (AnnF TypeInfo TermF) var
x
    join' Maybe (FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)
p (CubeProductT TypeInfo (FS (AnnF TypeInfo TermF) var)
_ FS (AnnF TypeInfo TermF) var
l FS (AnnF TypeInfo TermF) var
r) FS (AnnF TypeInfo TermF) var
x =
      Maybe (FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var
-> Maybe
     (FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)
join' (Maybe (FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)
-> FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var
-> Maybe
     (FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)
join' Maybe (FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)
p FS (AnnF TypeInfo TermF) var
l (FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var -> FS (AnnF TypeInfo TermF) var
forall var. TermT var -> TermT var -> TermT var
firstT FS (AnnF TypeInfo TermF) var
l FS (AnnF TypeInfo TermF) var
x)) FS (AnnF TypeInfo TermF) var
r (FS (AnnF TypeInfo TermF) var
-> FS (AnnF TypeInfo TermF) var -> FS (AnnF TypeInfo TermF) var
forall var. TermT var -> TermT var -> TermT var
secondT FS (AnnF TypeInfo TermF) var
r FS (AnnF TypeInfo TermF) var
x)
    join' Maybe (FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)
_ FS (AnnF TypeInfo TermF) var
_ FS (AnnF TypeInfo TermF) var
_ = Maybe (FS (AnnF TypeInfo TermF) var, FS (AnnF TypeInfo TermF) var)
forall a. Maybe a
Nothing -- FIXME: error?

    dimOf :: FS (AnnF ann TermF) a -> Maybe Int
dimOf = \case
      Cube2T{}           -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
      CubeProductT ann (FS (AnnF ann TermF) a)
_ FS (AnnF ann TermF) a
l FS (AnnF ann TermF) a
r -> Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) (Int -> Int -> Int) -> Maybe Int -> Maybe (Int -> Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FS (AnnF ann TermF) a -> Maybe Int
dimOf FS (AnnF ann TermF) a
l Maybe (Int -> Int) -> Maybe Int -> Maybe Int
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FS (AnnF ann TermF) a -> Maybe Int
dimOf FS (AnnF ann TermF) a
r
      FS (AnnF ann TermF) a
_                  -> Maybe Int
forall a. Maybe a
Nothing

renderTermSVG :: Eq var => TermT var -> TypeCheck var (Maybe String)
renderTermSVG :: forall var. Eq var => TermT var -> TypeCheck var (Maybe String)
renderTermSVG = String
-> Int
-> (Maybe (TermT var, TermT var), [var])
-> TermT var
-> TypeCheck var (Maybe String)
forall var.
Eq var =>
String
-> Int
-> (Maybe (TermT var, TermT var), [var])
-> TermT var
-> TypeCheck var (Maybe String)
renderTermSVGFor String
"red" Int
0 (Maybe (TermT var, TermT var)
forall a. Maybe a
Nothing, [])  -- use red for terms by default

-- | Render the goal /cell/ for a (shape) type: introduce an abstract inhabitant
-- and render it with the proof term hidden. Under a boundary tope an abstract
-- inhabitant of an extension type reduces to the prescribed face value, so the
-- cell shows its given edges with a blank interior — the shape to inhabit, not
-- an answer. 'Nothing' for a non-shape type (a 0-cell or a non-cube goal).
renderGoalCellSVG :: Eq var => TermT var -> TypeCheck var (Maybe String)
renderGoalCellSVG :: forall var. Eq var => TermT var -> TypeCheck var (Maybe String)
renderGoalCellSVG TermT var
ty =
  TypeCheck var (Maybe String) -> TypeCheck var (Maybe String)
forall var a. TypeCheck var a -> TypeCheck var a
hidingTerm (TypeCheck var (Maybe String) -> TypeCheck var (Maybe String))
-> TypeCheck var (Maybe String) -> TypeCheck var (Maybe String)
forall a b. (a -> b) -> a -> b
$ Binder
-> TModality
-> TermT var
-> TypeCheck (Inc var) (Maybe String)
-> TypeCheck var (Maybe String)
forall var b.
Binder
-> TModality
-> TermT var
-> TypeCheck (Inc var) b
-> TypeCheck var b
enterScope (Maybe VarIdent -> Binder
BinderVar (VarIdent -> Maybe VarIdent
forall a. a -> Maybe a
Just VarIdent
"_")) TModality
Id TermT var
ty (TypeCheck (Inc var) (Maybe String)
 -> TypeCheck var (Maybe String))
-> TypeCheck (Inc var) (Maybe String)
-> TypeCheck var (Maybe String)
forall a b. (a -> b) -> a -> b
$ TermT (Inc var) -> TypeCheck (Inc var) (Maybe String)
forall var. Eq var => TermT var -> TypeCheck var (Maybe String)
renderTermSVG' (Inc var -> TermT (Inc var)
forall (t :: * -> * -> *) a. a -> FS t a
Pure Inc var
forall var. Inc var
Z)

renderTermSVG' :: Eq var => TermT var -> TypeCheck var (Maybe String)
renderTermSVG' :: forall var. Eq var => TermT var -> TypeCheck var (Maybe String)
renderTermSVG' TermT var
t = TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
t TypeCheck var (TermT var)
-> (TermT var
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         (Maybe String))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe String)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TermT var
t' -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
t TypeCheck var (TermT var)
-> (TermT var
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         (Maybe String))
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe String)
forall a b.
ReaderT
  (Context var)
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
  a
-> (a
    -> ReaderT
         (Context var)
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
         b)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  TypeFunT TypeInfo (TermT var)
_ Binder
orig TModality
md TermT var
arg Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope Scope (FS (AnnF TypeInfo TermF)) var
ret -> Binder
-> TModality
-> TermT var
-> TypeCheck (Inc var) (Maybe String)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe String)
forall var b.
Binder
-> TModality
-> TermT var
-> TypeCheck (Inc var) b
-> TypeCheck var b
enterScope Binder
orig TModality
md TermT var
arg (TypeCheck (Inc var) (Maybe String)
 -> ReaderT
      (Context var)
      (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
      (Maybe String))
-> TypeCheck (Inc var) (Maybe String)
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
    (TypeCheck (Inc var) (Maybe String)
 -> TypeCheck (Inc var) (Maybe String))
-> (Scope (FS (AnnF TypeInfo TermF)) var
    -> TypeCheck (Inc var) (Maybe String)
    -> TypeCheck (Inc var) (Maybe String))
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> TypeCheck (Inc var) (Maybe String)
-> TypeCheck (Inc var) (Maybe String)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TypeCheck (Inc var) (Maybe String)
-> TypeCheck (Inc var) (Maybe String)
forall a. a -> a
id Scope (FS (AnnF TypeInfo TermF)) var
-> TypeCheck (Inc var) (Maybe String)
-> TypeCheck (Inc var) (Maybe String)
forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope (TypeCheck (Inc var) (Maybe String)
 -> TypeCheck (Inc var) (Maybe String))
-> TypeCheck (Inc var) (Maybe String)
-> TypeCheck (Inc var) (Maybe String)
forall a b. (a -> b) -> a -> b
$ case TermT var
t' of
      LambdaT TypeInfo (TermT var)
_ Binder
_orig Maybe
  (TModality, TermT var,
   Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
_marg (AppT TypeInfo (Scope (FS (AnnF TypeInfo TermF)) var)
_info Scope (FS (AnnF TypeInfo TermF)) var
f Scope (FS (AnnF TypeInfo TermF)) var
x) ->
        Scope (FS (AnnF TypeInfo TermF)) var
-> TypeCheck (Inc var) (Scope (FS (AnnF TypeInfo TermF)) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf Scope (FS (AnnF TypeInfo TermF)) var
f TypeCheck (Inc var) (Scope (FS (AnnF TypeInfo TermF)) var)
-> (Scope (FS (AnnF TypeInfo TermF)) var
    -> TypeCheck (Inc var) (Maybe String))
-> TypeCheck (Inc var) (Maybe String)
forall a b.
ReaderT
  (Context (Inc var))
  (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
  a
-> (a
    -> ReaderT
         (Context (Inc var))
         (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
         b)
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          TypeFunT TypeInfo (Scope (FS (AnnF TypeInfo TermF)) var)
_ Binder
fOrig TModality
md2 Scope (FS (AnnF TypeInfo TermF)) var
fArg Maybe (Scope (FS (AnnF TypeInfo TermF)) (Inc var))
mtope2 Scope (FS (AnnF TypeInfo TermF)) (Inc var)
_ret | Just Int
dim <- Scope (FS (AnnF TypeInfo TermF)) var -> Maybe Int
forall {ann :: * -> *} {a}. FS (AnnF ann TermF) a -> Maybe Int
dimOf Scope (FS (AnnF TypeInfo TermF)) var
fArg -> do
            Binder
-> TModality
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TypeCheck (Inc (Inc var)) (Maybe String)
-> TypeCheck (Inc var) (Maybe String)
forall var b.
Binder
-> TModality
-> TermT var
-> TypeCheck (Inc var) b
-> TypeCheck var b
enterScope Binder
fOrig TModality
md2 Scope (FS (AnnF TypeInfo TermF)) var
fArg (TypeCheck (Inc (Inc var)) (Maybe String)
 -> TypeCheck (Inc var) (Maybe String))
-> TypeCheck (Inc (Inc var)) (Maybe String)
-> TypeCheck (Inc var) (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
              (TypeCheck (Inc (Inc var)) (Maybe String)
 -> TypeCheck (Inc (Inc var)) (Maybe String))
-> (Scope (FS (AnnF TypeInfo TermF)) (Inc var)
    -> TypeCheck (Inc (Inc var)) (Maybe String)
    -> TypeCheck (Inc (Inc var)) (Maybe String))
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) (Inc var))
-> TypeCheck (Inc (Inc var)) (Maybe String)
-> TypeCheck (Inc (Inc var)) (Maybe String)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TypeCheck (Inc (Inc var)) (Maybe String)
-> TypeCheck (Inc (Inc var)) (Maybe String)
forall a. a -> a
id Scope (FS (AnnF TypeInfo TermF)) (Inc var)
-> TypeCheck (Inc (Inc var)) (Maybe String)
-> TypeCheck (Inc (Inc var)) (Maybe String)
forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope Maybe (Scope (FS (AnnF TypeInfo TermF)) (Inc var))
mtope2 (TypeCheck (Inc (Inc var)) (Maybe String)
 -> TypeCheck (Inc (Inc var)) (Maybe String))
-> TypeCheck (Inc (Inc var)) (Maybe String)
-> TypeCheck (Inc (Inc var)) (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
                String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> ReaderT
     (Context (Inc (Inc var)))
     (WriterT
        [HoleInfo] (Except (TypeErrorInScopedContext (Inc (Inc var)))))
     String
-> TypeCheck (Inc (Inc var)) (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> Int
-> [Inc (Inc var)]
-> Inc (Inc var)
-> Scope (FS (AnnF TypeInfo TermF)) (Inc var)
-> Scope (FS (AnnF TypeInfo TermF)) (Inc var)
-> Scope (FS (AnnF TypeInfo TermF)) (Inc var)
-> ReaderT
     (Context (Inc (Inc var)))
     (WriterT
        [HoleInfo] (Except (TypeErrorInScopedContext (Inc (Inc var)))))
     String
forall var.
Eq var =>
String
-> Int
-> [var]
-> var
-> TermT var
-> TermT var
-> TermT var
-> TypeCheck var String
renderForSubShapeSVG String
"red" Int
dim [Inc var -> Inc (Inc var)
forall var. var -> Inc var
S Inc var
forall var. Inc var
Z] Inc (Inc var)
forall var. Inc var
Z (Inc var -> Inc (Inc var)
forall var. var -> Inc var
S (Inc var -> Inc (Inc var))
-> Scope (FS (AnnF TypeInfo TermF)) var
-> Scope (FS (AnnF TypeInfo TermF)) (Inc var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scope (FS (AnnF TypeInfo TermF)) var
ret) (Inc var -> Inc (Inc var)
forall var. var -> Inc var
S (Inc var -> Inc (Inc var))
-> Scope (FS (AnnF TypeInfo TermF)) var
-> Scope (FS (AnnF TypeInfo TermF)) (Inc var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scope (FS (AnnF TypeInfo TermF)) var
f) (Inc var -> Inc (Inc var)
forall var. var -> Inc var
S (Inc var -> Inc (Inc var))
-> Scope (FS (AnnF TypeInfo TermF)) var
-> Scope (FS (AnnF TypeInfo TermF)) (Inc var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scope (FS (AnnF TypeInfo TermF)) var
x)
          Scope (FS (AnnF TypeInfo TermF)) var
_ -> TermT var
-> TermT var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TypeCheck (Inc var) (Maybe String)
forall {var} {ann :: * -> *} {a}.
Eq var =>
FS (AnnF TypeInfo TermF) var
-> FS (AnnF ann TermF) a
-> TermT (Inc var)
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     (Maybe String)
defaultRenderTermSVG TermT var
t' TermT var
arg Scope (FS (AnnF TypeInfo TermF)) var
ret
      TermT var
_ -> TermT var
-> TermT var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TypeCheck (Inc var) (Maybe String)
forall {var} {ann :: * -> *} {a}.
Eq var =>
FS (AnnF TypeInfo TermF) var
-> FS (AnnF ann TermF) a
-> TermT (Inc var)
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     (Maybe String)
defaultRenderTermSVG TermT var
t' TermT var
arg Scope (FS (AnnF TypeInfo TermF)) var
ret
  TermT var
_t' -> Maybe String
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     (Maybe String)
forall a.
a
-> ReaderT
     (Context var)
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var)))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
  where
    dimOf :: FS (AnnF ann TermF) a -> Maybe Int
dimOf = \case
      Cube2T{}           -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
      CubeProductT ann (FS (AnnF ann TermF) a)
_ FS (AnnF ann TermF) a
l FS (AnnF ann TermF) a
r -> Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) (Int -> Int -> Int) -> Maybe Int -> Maybe (Int -> Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FS (AnnF ann TermF) a -> Maybe Int
dimOf FS (AnnF ann TermF) a
l Maybe (Int -> Int) -> Maybe Int -> Maybe Int
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FS (AnnF ann TermF) a -> Maybe Int
dimOf FS (AnnF ann TermF) a
r -- WARNING: breaks for 2 * (2 * 2)
      FS (AnnF ann TermF) a
_                  -> Maybe Int
forall a. Maybe a
Nothing

    defaultRenderTermSVG :: FS (AnnF TypeInfo TermF) var
-> FS (AnnF ann TermF) a
-> TermT (Inc var)
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     (Maybe String)
defaultRenderTermSVG FS (AnnF TypeInfo TermF) var
t' FS (AnnF ann TermF) a
arg TermT (Inc var)
ret =
      case FS (AnnF ann TermF) a -> Maybe Int
forall {ann :: * -> *} {a}. FS (AnnF ann TermF) a -> Maybe Int
dimOf FS (AnnF ann TermF) a
arg of
        Just Int
dim | Int
dim Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
3 ->
          String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     String
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> Int
-> TermT (Inc var)
-> TermT (Inc var)
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     String
forall var.
Eq var =>
String -> Int -> TermT var -> TermT var -> TypeCheck var String
renderForSVG String
"red" Int
dim (Inc var -> TermT (Inc var)
forall (t :: * -> * -> *) a. a -> FS t a
Pure Inc var
forall var. Inc var
Z) (TermT (Inc var)
-> TermT (Inc var) -> TermT (Inc var) -> TermT (Inc var)
forall var. TermT var -> TermT var -> TermT var -> TermT var
appT TermT (Inc var)
ret (var -> Inc var
forall var. var -> Inc var
S (var -> Inc var) -> FS (AnnF TypeInfo TermF) var -> TermT (Inc var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FS (AnnF TypeInfo TermF) var
t') (Inc var -> TermT (Inc var)
forall (t :: * -> * -> *) a. a -> FS t a
Pure Inc var
forall var. Inc var
Z))
        Maybe Int
_ -> TermT (Inc var)
-> ReaderT
     (Context (Inc var))
     (WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))))
     (Maybe String)
forall var. Eq var => TermT var -> TypeCheck var (Maybe String)
renderTermSVG' (TermT (Inc var)
-> TermT (Inc var) -> TermT (Inc var) -> TermT (Inc var)
forall var. TermT var -> TermT var -> TermT var -> TermT var
appT TermT (Inc var)
ret (var -> Inc var
forall var. var -> Inc var
S (var -> Inc var) -> FS (AnnF TypeInfo TermF) var -> TermT (Inc var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FS (AnnF TypeInfo TermF) var
t') (Inc var -> TermT (Inc var)
forall (t :: * -> * -> *) a. a -> FS t a
Pure Inc var
forall var. Inc var
Z))


type Point2D a = (a, a)
type Point3D a = (a, a, a)
type Edge3D a = (Point3D a, Point3D a)
type Face3D a = (Point3D a, Point3D a, Point3D a)
type Volume3D a = (Point3D a, Point3D a, Point3D a, Point3D a)

data CubeCoords2D a b = CubeCoords2D
  { forall a b. CubeCoords2D a b -> [(Point3D a, Point2D b)]
vertices :: [(Point3D a, Point2D b)]
  , forall a b.
CubeCoords2D a b -> [(Edge3D a, (Point2D b, Point2D b))]
edges    :: [(Edge3D a, (Point2D b, Point2D b))]
  , forall a b.
CubeCoords2D a b -> [(Face3D a, (Point2D b, Point2D b, Point2D b))]
faces    :: [(Face3D a, (Point2D b, Point2D b, Point2D b))]
  , forall a b.
CubeCoords2D a b
-> [(Volume3D a, (Point2D b, Point2D b, Point2D b, Point2D b))]
volumes  :: [(Volume3D a, (Point2D b, Point2D b, Point2D b, Point2D b))]
  }

data Matrix3D a = Matrix3D
  a a a
  a a a
  a a a

data Matrix4D a = Matrix4D
  a a a a
  a a a a
  a a a a
  a a a a

data Vector3D a = Vector3D a a a

data Vector4D a = Vector4D a a a a

rotateX :: Floating a => a -> Matrix3D a
rotateX :: forall a. Floating a => a -> Matrix3D a
rotateX a
theta = a -> a -> a -> a -> a -> a -> a -> a -> a -> Matrix3D a
forall a. a -> a -> a -> a -> a -> a -> a -> a -> a -> Matrix3D a
Matrix3D
  a
1 a
0 a
0
  a
0 (a -> a
forall a. Floating a => a -> a
cos a
theta) (- a -> a
forall a. Floating a => a -> a
sin a
theta)
  a
0 (a -> a
forall a. Floating a => a -> a
sin a
theta) (a -> a
forall a. Floating a => a -> a
cos a
theta)

rotateY :: Floating a => a -> Matrix3D a
rotateY :: forall a. Floating a => a -> Matrix3D a
rotateY a
theta = a -> a -> a -> a -> a -> a -> a -> a -> a -> Matrix3D a
forall a. a -> a -> a -> a -> a -> a -> a -> a -> a -> Matrix3D a
Matrix3D
  (a -> a
forall a. Floating a => a -> a
cos a
theta) a
0 (a -> a
forall a. Floating a => a -> a
sin a
theta)
  a
0 a
1 a
0
  (- a -> a
forall a. Floating a => a -> a
sin a
theta) a
0 (a -> a
forall a. Floating a => a -> a
cos a
theta)

rotateZ :: Floating a => a -> Matrix3D a
rotateZ :: forall a. Floating a => a -> Matrix3D a
rotateZ a
theta = a -> a -> a -> a -> a -> a -> a -> a -> a -> Matrix3D a
forall a. a -> a -> a -> a -> a -> a -> a -> a -> a -> Matrix3D a
Matrix3D
  (a -> a
forall a. Floating a => a -> a
cos a
theta) (- a -> a
forall a. Floating a => a -> a
sin a
theta) a
0
  (a -> a
forall a. Floating a => a -> a
sin a
theta) (a -> a
forall a. Floating a => a -> a
cos a
theta) a
0
  a
0 a
0 a
1

data Camera a = Camera
  { forall a. Camera a -> Point3D a
cameraPos         :: Point3D a
  , forall a. Camera a -> a
cameraFoV         :: a
  , forall a. Camera a -> a
cameraAspectRatio :: a
  , forall a. Camera a -> a
cameraAngleY      :: a
  , forall a. Camera a -> a
cameraAngleX      :: a
  }

viewRotateX :: Floating a => Camera a -> Matrix4D a
viewRotateX :: forall a. Floating a => Camera a -> Matrix4D a
viewRotateX Camera{a
Point3D a
cameraPos :: forall a. Camera a -> Point3D a
cameraFoV :: forall a. Camera a -> a
cameraAspectRatio :: forall a. Camera a -> a
cameraAngleY :: forall a. Camera a -> a
cameraAngleX :: forall a. Camera a -> a
cameraPos :: Point3D a
cameraFoV :: a
cameraAspectRatio :: a
cameraAngleY :: a
cameraAngleX :: a
..} = Matrix3D a -> Matrix4D a
forall a. Num a => Matrix3D a -> Matrix4D a
matrix3Dto4D (a -> Matrix3D a
forall a. Floating a => a -> Matrix3D a
rotateX a
cameraAngleX)

viewRotateY :: Floating a => Camera a -> Matrix4D a
viewRotateY :: forall a. Floating a => Camera a -> Matrix4D a
viewRotateY Camera{a
Point3D a
cameraPos :: forall a. Camera a -> Point3D a
cameraFoV :: forall a. Camera a -> a
cameraAspectRatio :: forall a. Camera a -> a
cameraAngleY :: forall a. Camera a -> a
cameraAngleX :: forall a. Camera a -> a
cameraPos :: Point3D a
cameraFoV :: a
cameraAspectRatio :: a
cameraAngleY :: a
cameraAngleX :: a
..} = Matrix3D a -> Matrix4D a
forall a. Num a => Matrix3D a -> Matrix4D a
matrix3Dto4D (a -> Matrix3D a
forall a. Floating a => a -> Matrix3D a
rotateY a
cameraAngleY)

viewTranslate :: Num a => Camera a -> Matrix4D a
viewTranslate :: forall a. Num a => Camera a -> Matrix4D a
viewTranslate Camera{a
Point3D a
cameraPos :: forall a. Camera a -> Point3D a
cameraFoV :: forall a. Camera a -> a
cameraAspectRatio :: forall a. Camera a -> a
cameraAngleY :: forall a. Camera a -> a
cameraAngleX :: forall a. Camera a -> a
cameraPos :: Point3D a
cameraFoV :: a
cameraAspectRatio :: a
cameraAngleY :: a
cameraAngleX :: a
..} = a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> Matrix4D a
forall a.
a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> Matrix4D a
Matrix4D
  a
1 a
0 a
0 a
0
  a
0 a
1 a
0 a
0
  a
0 a
0 a
1 a
0
  (-a
x) (-a
y) (-a
z) a
1
  where
    (a
x, a
y, a
z) = Point3D a
cameraPos

project2D :: Floating a => Camera a -> Matrix4D a
project2D :: forall a. Floating a => Camera a -> Matrix4D a
project2D Camera{a
Point3D a
cameraPos :: forall a. Camera a -> Point3D a
cameraFoV :: forall a. Camera a -> a
cameraAspectRatio :: forall a. Camera a -> a
cameraAngleY :: forall a. Camera a -> a
cameraAngleX :: forall a. Camera a -> a
cameraPos :: Point3D a
cameraFoV :: a
cameraAspectRatio :: a
cameraAngleY :: a
cameraAngleX :: a
..} = a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> Matrix4D a
forall a.
a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> Matrix4D a
Matrix4D
  (a
2 a -> a -> a
forall a. Num a => a -> a -> a
* a
n a -> a -> a
forall a. Fractional a => a -> a -> a
/ (a
r a -> a -> a
forall a. Num a => a -> a -> a
- a
l)) a
0 ((a
r a -> a -> a
forall a. Num a => a -> a -> a
+ a
l) a -> a -> a
forall a. Fractional a => a -> a -> a
/ (a
r a -> a -> a
forall a. Num a => a -> a -> a
- a
l)) a
0
  a
0 (a
2 a -> a -> a
forall a. Num a => a -> a -> a
* a
n a -> a -> a
forall a. Fractional a => a -> a -> a
/ (a
t a -> a -> a
forall a. Num a => a -> a -> a
- a
b)) ((a
t a -> a -> a
forall a. Num a => a -> a -> a
+ a
b) a -> a -> a
forall a. Fractional a => a -> a -> a
/ (a
t a -> a -> a
forall a. Num a => a -> a -> a
- a
b)) a
0
  a
0 a
0 (- (a
f a -> a -> a
forall a. Num a => a -> a -> a
+ a
n) a -> a -> a
forall a. Fractional a => a -> a -> a
/ (a
f a -> a -> a
forall a. Num a => a -> a -> a
- a
n)) (- a
2 a -> a -> a
forall a. Num a => a -> a -> a
* a
f a -> a -> a
forall a. Num a => a -> a -> a
* a
n a -> a -> a
forall a. Fractional a => a -> a -> a
/ (a
f a -> a -> a
forall a. Num a => a -> a -> a
- a
n))
  a
0 a
0 (-a
1) a
0
  where
    n :: a
n = a
1
    f :: a
f = a
2
    r :: a
r = a
n a -> a -> a
forall a. Num a => a -> a -> a
* a -> a
forall a. Floating a => a -> a
tan (a
cameraFoV a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
2)
    l :: a
l = -a
r
    t :: a
t = a
r a -> a -> a
forall a. Num a => a -> a -> a
* a
cameraAspectRatio
    b :: a
b = -a
t


matrixVectorMult4D :: Num a => Matrix4D a -> Vector4D a -> Vector4D a
matrixVectorMult4D :: forall a. Num a => Matrix4D a -> Vector4D a -> Vector4D a
matrixVectorMult4D
  (Matrix4D
    a
a1 a
a2 a
a3 a
a4
    a
b1 a
b2 a
b3 a
b4
    a
c1 a
c2 a
c3 a
c4
    a
d1 a
d2 a
d3 a
d4)
  (Vector4D a
a a
b a
c a
d)
    = a -> a -> a -> a -> Vector4D a
forall a. a -> a -> a -> a -> Vector4D a
Vector4D a
a' a
b' a
c' a
d'
  where
    a' :: a
a' = [a] -> a
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((a -> a -> a) -> [a] -> [a] -> [a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> a -> a
forall a. Num a => a -> a -> a
(*) [a
a1, a
b1, a
c1, a
d1] [a
a, a
b, a
c, a
d])
    b' :: a
b' = [a] -> a
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((a -> a -> a) -> [a] -> [a] -> [a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> a -> a
forall a. Num a => a -> a -> a
(*) [a
a2, a
b2, a
c2, a
d2] [a
a, a
b, a
c, a
d])
    c' :: a
c' = [a] -> a
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((a -> a -> a) -> [a] -> [a] -> [a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> a -> a
forall a. Num a => a -> a -> a
(*) [a
a3, a
b3, a
c3, a
d3] [a
a, a
b, a
c, a
d])
    d' :: a
d' = [a] -> a
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((a -> a -> a) -> [a] -> [a] -> [a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> a -> a
forall a. Num a => a -> a -> a
(*) [a
a4, a
b4, a
c4, a
d4] [a
a, a
b, a
c, a
d])

matrix3Dto4D :: Num a => Matrix3D a -> Matrix4D a
matrix3Dto4D :: forall a. Num a => Matrix3D a -> Matrix4D a
matrix3Dto4D
  (Matrix3D
    a
a1 a
b1 a
c1
    a
a2 a
b2 a
c2
    a
a3 a
b3 a
c3) = a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> Matrix4D a
forall a.
a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> Matrix4D a
Matrix4D
      a
a1 a
b1 a
c1 a
0
      a
a2 a
b2 a
c2 a
0
      a
a3 a
b3 a
c3 a
0
      a
0 a
0 a
0 a
1

fromAffine :: Fractional a => Vector4D a -> (Point2D a, a)
fromAffine :: forall a. Fractional a => Vector4D a -> (Point2D a, a)
fromAffine (Vector4D a
a a
b a
c a
d) = ((a
x, a
y), a
zIndex)
  where
    x :: a
x = a
a a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
d
    y :: a
y = a
b a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
d
    zIndex :: a
zIndex = a
c a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
d

point3Dto2D :: Floating a => Camera a -> a -> Point3D a -> (Point2D a, a)
point3Dto2D :: forall a.
Floating a =>
Camera a -> a -> Point3D a -> (Point2D a, a)
point3Dto2D Camera a
camera a
rotY (a
x, a
y, a
z) = Vector4D a -> (Point2D a, a)
forall a. Fractional a => Vector4D a -> (Point2D a, a)
fromAffine (Vector4D a -> (Point2D a, a)) -> Vector4D a -> (Point2D a, a)
forall a b. (a -> b) -> a -> b
$
  (Matrix4D a -> Vector4D a -> Vector4D a)
-> Vector4D a -> [Matrix4D a] -> Vector4D a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Matrix4D a -> Vector4D a -> Vector4D a
forall a. Num a => Matrix4D a -> Vector4D a -> Vector4D a
matrixVectorMult4D (a -> a -> a -> a -> Vector4D a
forall a. a -> a -> a -> a -> Vector4D a
Vector4D a
x a
y a
z a
1) ([Matrix4D a] -> Vector4D a) -> [Matrix4D a] -> Vector4D a
forall a b. (a -> b) -> a -> b
$ [Matrix4D a] -> [Matrix4D a]
forall a. [a] -> [a]
reverse
    [ Matrix3D a -> Matrix4D a
forall a. Num a => Matrix3D a -> Matrix4D a
matrix3Dto4D (a -> Matrix3D a
forall a. Floating a => a -> Matrix3D a
rotateY a
rotY)
    , Camera a -> Matrix4D a
forall a. Num a => Camera a -> Matrix4D a
viewTranslate Camera a
camera
    , Camera a -> Matrix4D a
forall a. Floating a => Camera a -> Matrix4D a
viewRotateY Camera a
camera
    , Camera a -> Matrix4D a
forall a. Floating a => Camera a -> Matrix4D a
viewRotateX Camera a
camera
    , Camera a -> Matrix4D a
forall a. Floating a => Camera a -> Matrix4D a
project2D Camera a
camera
    ]

data RenderObjectData = RenderObjectData
  { RenderObjectData -> String
renderObjectDataLabel     :: String
  , RenderObjectData -> String
renderObjectDataFullLabel :: String
  , RenderObjectData -> String
renderObjectDataColor     :: String
  }

renderCube
  :: (Floating a, Show a)
  => Camera a
  -> a
  -> (String -> Maybe RenderObjectData)
  -> String
renderCube :: forall a.
(Floating a, Show a) =>
Camera a -> a -> (String -> Maybe RenderObjectData) -> String
renderCube Camera a
camera a
rotY String -> Maybe RenderObjectData
renderDataOf' = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null)
  [ String
"<svg class=\"rzk-render\" viewBox=\"-175 -200 350 375\" width=\"150\" height=\"150\">"
  , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n"
      [ String
"  <path d=\"M " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
x1 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
y1
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" L " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
x2 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
y2
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" L " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
x3 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
y3
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" Z\" style=\"fill: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
renderObjectDataColor String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"; opacity: 0.2\"><title>" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
renderObjectDataFullLabel String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"</title></path>" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
        String
"  <text x=\"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
x String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\" y=\"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
y String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\" fill=\"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
renderObjectDataColor String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\">" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
renderObjectDataLabel String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"</text>"
      | (String
faceId, (((a
x1, a
y1), (a
x2, a
y2), (a
x3, a
y3)), Integer
_)) <- [(String, (((a, a), (a, a), (a, a)), Integer))]
faces
      , Just RenderObjectData{String
renderObjectDataColor :: RenderObjectData -> String
renderObjectDataLabel :: RenderObjectData -> String
renderObjectDataFullLabel :: RenderObjectData -> String
renderObjectDataColor :: String
renderObjectDataFullLabel :: String
renderObjectDataLabel :: String
..} <- [String -> Maybe RenderObjectData
renderDataOf String
faceId]
      , let x :: a
x = (a
x1 a -> a -> a
forall a. Num a => a -> a -> a
+ a
x2 a -> a -> a
forall a. Num a => a -> a -> a
+ a
x3) a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
3
      , let y :: a
y = (a
y1 a -> a -> a
forall a. Num a => a -> a -> a
+ a
y2 a -> a -> a
forall a. Num a => a -> a -> a
+ a
y3) a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
3 ]
  , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n"
      [ String
"  <polyline points=\"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
x1 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"," String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
y1 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
x2 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"," String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
y2
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\" stroke=\"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
renderObjectDataColor String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\" stroke-width=\"3\" marker-end=\"url(#arrow)\"><title>" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
renderObjectDataFullLabel String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"</title></polyline>" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
        String
"  <text x=\"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
x String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\" y=\"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
y String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\" fill=\"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
renderObjectDataColor String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\" stroke=\"white\" stroke-width=\"10\" stroke-opacity=\".8\" paint-order=\"stroke\">" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
renderObjectDataLabel String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"</text>"
      | (String
edge, (((a
x1, a
y1), (a
x2, a
y2)), Integer
_)) <- [(String, (((a, a), (a, a)), Integer))]
edges
      , Just RenderObjectData{String
renderObjectDataColor :: RenderObjectData -> String
renderObjectDataLabel :: RenderObjectData -> String
renderObjectDataFullLabel :: RenderObjectData -> String
renderObjectDataColor :: String
renderObjectDataFullLabel :: String
renderObjectDataLabel :: String
..} <- [String -> Maybe RenderObjectData
renderDataOf String
edge]
      , let x :: a
x = (a
x1 a -> a -> a
forall a. Num a => a -> a -> a
+ a
x2) a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
2
      , let y :: a
y = (a
y1 a -> a -> a
forall a. Num a => a -> a -> a
+ a
y2) a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
2 ]
  , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n"
      [ String
"  <text x=\"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
x String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\" y=\"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
y String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\" fill=\"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
renderObjectDataColor String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\">" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
renderObjectDataLabel String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"</text>"
      | (String
v, ((a
x, a
y), a
_)) <- [(String, ((a, a), a))]
vertices
      , Just RenderObjectData{String
renderObjectDataColor :: RenderObjectData -> String
renderObjectDataLabel :: RenderObjectData -> String
renderObjectDataFullLabel :: RenderObjectData -> String
renderObjectDataColor :: String
renderObjectDataLabel :: String
renderObjectDataFullLabel :: String
..} <- [String -> Maybe RenderObjectData
renderDataOf String
v]]
  , String
"</svg>" ]
  where
    renderDataOf :: String -> Maybe RenderObjectData
renderDataOf String
shapeId =
      case String -> Maybe RenderObjectData
renderDataOf' String
shapeId of
        Maybe RenderObjectData
Nothing -> Maybe RenderObjectData
forall a. Maybe a
Nothing
        Just RenderObjectData{String
renderObjectDataColor :: RenderObjectData -> String
renderObjectDataLabel :: RenderObjectData -> String
renderObjectDataFullLabel :: RenderObjectData -> String
renderObjectDataLabel :: String
renderObjectDataFullLabel :: String
renderObjectDataColor :: String
..} -> RenderObjectData -> Maybe RenderObjectData
forall a. a -> Maybe a
Just RenderObjectData
          -- FIXME: move constants to configurable parameters
          { renderObjectDataLabel :: String
renderObjectDataLabel = String -> Int -> String -> String
forall {t :: * -> *} {t :: * -> *} {a}.
(Foldable t, Foldable t, IsString (t a)) =>
t Char -> Int -> t a -> t a
hideWhenLargerThan String
shapeId Int
5 String
renderObjectDataLabel
          , renderObjectDataFullLabel :: String
renderObjectDataFullLabel = Int -> String -> String
limitLength Int
30 String
renderObjectDataFullLabel
          , String
renderObjectDataColor :: String
renderObjectDataColor :: String
.. }

    hideWhenLargerThan :: t Char -> Int -> t a -> t a
hideWhenLargerThan t Char
shapeId Int
n t a
s
      | t a -> Bool
forall a. t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
s Bool -> Bool -> Bool
|| t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n = if Char
'-' Char -> t Char -> Bool
forall a. Eq a => a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t Char
shapeId then t a
"" else t a
"•"
      | Bool
otherwise = t a
s

    vertices :: [(String, ((a, a), a))]
vertices =
      [ (Integer -> String
forall a. Show a => a -> String
show Integer
x String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
y String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
z, ((a
500 a -> a -> a
forall a. Num a => a -> a -> a
* a
x'', a
500 a -> a -> a
forall a. Num a => a -> a -> a
* a
y''), a
zIndex))
      | Integer
x <- [Integer
0,Integer
1]
      , Integer
y <- [Integer
0,Integer
1]
      , Integer
z <- [Integer
0,Integer
1]
      , let f :: Integer -> a
f Integer
c = a
2 a -> a -> a
forall a. Num a => a -> a -> a
* Integer -> a
forall a. Num a => Integer -> a
fromInteger Integer
c a -> a -> a
forall a. Num a => a -> a -> a
- a
1
      , let x' :: a
x' = Integer -> a
forall a. Num a => Integer -> a
f Integer
x
      , let y' :: a
y' = Integer -> a
forall a. Num a => Integer -> a
f (Integer
1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
y)
      , let z' :: a
z' = Integer -> a
forall a. Num a => Integer -> a
f Integer
z
      , let ((a
x'', a
y''), a
zIndex) = Camera a -> a -> Point3D a -> ((a, a), a)
forall a.
Floating a =>
Camera a -> a -> Point3D a -> (Point2D a, a)
point3Dto2D Camera a
camera a
rotY (a
x', a
y', a
z') ]

    radius :: a
radius = a
20

    mkEdge :: b -> (b, b) -> (b, b) -> ((b, b), (b, b))
mkEdge b
r (b
x1, b
y1) (b
x2, b
y2) = ((b
x1 b -> b -> b
forall a. Num a => a -> a -> a
+ b
dx, b
y1 b -> b -> b
forall a. Num a => a -> a -> a
+ b
dy), ((b
x2 b -> b -> b
forall a. Num a => a -> a -> a
- b
dx), (b
y2 b -> b -> b
forall a. Num a => a -> a -> a
- b
dy)))
      where
        d :: b
d = b -> b
forall a. Floating a => a -> a
sqrt ((b
x2 b -> b -> b
forall a. Num a => a -> a -> a
- b
x1)b -> Integer -> b
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
2 b -> b -> b
forall a. Num a => a -> a -> a
+ (b
y2 b -> b -> b
forall a. Num a => a -> a -> a
- b
y1)b -> Integer -> b
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
2)
        dx :: b
dx = b
r b -> b -> b
forall a. Num a => a -> a -> a
* (b
x2 b -> b -> b
forall a. Num a => a -> a -> a
- b
x1) b -> b -> b
forall a. Fractional a => a -> a -> a
/ b
d
        dy :: b
dy = b
r b -> b -> b
forall a. Num a => a -> a -> a
* (b
y2 b -> b -> b
forall a. Num a => a -> a -> a
- b
y1) b -> b -> b
forall a. Fractional a => a -> a -> a
/ b
d

    scaleAround :: (b, b) -> b -> (b, b) -> (b, b)
scaleAround (b
cx, b
cy) b
s (b
x, b
y) = (b
cx b -> b -> b
forall a. Num a => a -> a -> a
+ b
s b -> b -> b
forall a. Num a => a -> a -> a
* (b
x b -> b -> b
forall a. Num a => a -> a -> a
- b
cx), b
cy b -> b -> b
forall a. Num a => a -> a -> a
+ b
s b -> b -> b
forall a. Num a => a -> a -> a
* (b
y b -> b -> b
forall a. Num a => a -> a -> a
- b
cy))

    mkFace :: (a, a) -> (a, a) -> (a, a) -> ((a, a), (a, a), (a, a))
mkFace (a
x1, a
y1) (a
x2, a
y2) (a
x3, a
y3) = ((a, a)
p1, (a, a)
p2, (a, a)
p3)
      where
        cx :: a
cx = (a
x1 a -> a -> a
forall a. Num a => a -> a -> a
+ a
x2 a -> a -> a
forall a. Num a => a -> a -> a
+ a
x3) a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
3
        cy :: a
cy = (a
y1 a -> a -> a
forall a. Num a => a -> a -> a
+ a
y2 a -> a -> a
forall a. Num a => a -> a -> a
+ a
y3) a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
3
        p1 :: (a, a)
p1 = (a, a) -> a -> (a, a) -> (a, a)
forall {b}. Num b => (b, b) -> b -> (b, b) -> (b, b)
scaleAround (a
cx, a
cy) a
0.85 (a
x1, a
y1)
        p2 :: (a, a)
p2 = (a, a) -> a -> (a, a) -> (a, a)
forall {b}. Num b => (b, b) -> b -> (b, b) -> (b, b)
scaleAround (a
cx, a
cy) a
0.85 (a
x2, a
y2)
        p3 :: (a, a)
p3 = (a, a) -> a -> (a, a) -> (a, a)
forall {b}. Num b => (b, b) -> b -> (b, b) -> (b, b)
scaleAround (a
cx, a
cy) a
0.85 (a
x3, a
y3)

    edges :: [(String, (((a, a), (a, a)), Integer))]
edges =
      [ (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"-" [String
fromName, String
toName], (a -> (a, a) -> (a, a) -> ((a, a), (a, a))
forall {b}. Floating b => b -> (b, b) -> (b, b) -> ((b, b), (b, b))
mkEdge a
radius (a, a)
from (a, a)
to, Integer
0))
      | (String
fromName, ((a, a)
from, a
_)) : [(String, ((a, a), a))]
vs <- [(String, ((a, a), a))] -> [[(String, ((a, a), a))]]
forall a. [a] -> [[a]]
tails [(String, ((a, a), a))]
vertices
      , (String
toName, ((a, a)
to, a
_)) <- [(String, ((a, a), a))]
vs
      , [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Char -> Char -> Bool) -> String -> String -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
(<=) String
fromName String
toName)
      ]

    faces :: [(String, (((a, a), (a, a), (a, a)), Integer))]
faces =
      [ (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"-" [String
name1, String
name2, String
name3], ((a, a) -> (a, a) -> (a, a) -> ((a, a), (a, a), (a, a))
forall {a}.
Fractional a =>
(a, a) -> (a, a) -> (a, a) -> ((a, a), (a, a), (a, a))
mkFace (a, a)
v1 (a, a)
v2 (a, a)
v3, Integer
0))
      | (String
name1, ((a, a)
v1, a
_)) : [(String, ((a, a), a))]
vs <- [(String, ((a, a), a))] -> [[(String, ((a, a), a))]]
forall a. [a] -> [[a]]
tails [(String, ((a, a), a))]
vertices
      , (String
name2, ((a, a)
v2, a
_)) : [(String, ((a, a), a))]
vs' <- [(String, ((a, a), a))] -> [[(String, ((a, a), a))]]
forall a. [a] -> [[a]]
tails [(String, ((a, a), a))]
vs
      , [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Char -> Char -> Bool) -> String -> String -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
(<=) String
name1 String
name2)
      , (String
name3, ((a, a)
v3, a
_)) <- [(String, ((a, a), a))]
vs'
      , [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Char -> Char -> Bool) -> String -> String -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
(<=) String
name2 String
name3)
      ]


defaultCamera :: Floating a => Camera a
defaultCamera :: forall a. Floating a => Camera a
defaultCamera = Camera
  { cameraPos :: Point3D a
cameraPos = (a
0, a
7, a
10)
  , cameraAngleY :: a
cameraAngleY = a
forall a. Floating a => a
pi
  , cameraAngleX :: a
cameraAngleX = a
forall a. Floating a => a
pia -> a -> a
forall a. Fractional a => a -> a -> a
/a
5
  , cameraFoV :: a
cameraFoV = a
forall a. Floating a => a
pia -> a -> a
forall a. Fractional a => a -> a -> a
/a
15
  , cameraAspectRatio :: a
cameraAspectRatio = a
1
  }