{-# 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
import           Data.Bifunctor           (first)
import           Data.List                (intercalate, intersect, nub, 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 TypeCheck var a
tc = Except (TypeErrorInScopedContext var) a
-> Either (TypeErrorInScopedContext var) a
forall e a. Except e a -> Either e a
runExcept (TypeCheck var a
-> Context var -> Except (TypeErrorInScopedContext var) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT TypeCheck var a
tc Context var
forall var. Context var
emptyContext)

-- 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
    ([(String, [Decl'])]
checked, [TypeErrorInScopedContext VarIdent]
errors) <- [(String, Module)]
-> TypeCheck
     VarIdent ([(String, [Decl'])], [TypeErrorInScopedContext VarIdent])
typecheckModulesWithLocation' [(String, Module)]
modulesToTypecheck
    ([(String, [Decl'])], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([(String, [Decl'])], [TypeErrorInScopedContext VarIdent])
forall a.
a
-> ReaderT
     (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, [Decl'])]
cached [(String, [Decl'])] -> [(String, [Decl'])] -> [(String, [Decl'])]
forall a. Semigroup a => a -> a -> a
<> [(String, [Decl'])]
checked, [TypeErrorInScopedContext VarIdent]
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) (Except (TypeErrorInScopedContext VarIdent)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
  m :: (String, Module)
m@(String
path, Module
_) : [(String, Module)]
ms -> do
    ([Decl']
decls, [TypeErrorInScopedContext VarIdent]
errs) <- (String, Module)
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
typecheckModuleWithLocation (String, Module)
m
    case [TypeErrorInScopedContext VarIdent]
errs of
      TypeErrorInScopedContext VarIdent
_:[TypeErrorInScopedContext VarIdent]
_ -> ([(String, [Decl'])], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([(String, [Decl'])], [TypeErrorInScopedContext VarIdent])
forall a.
a
-> ReaderT
     (Context VarIdent) (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
          ([(String, [Decl'])]
decls', [TypeErrorInScopedContext VarIdent]
errors) <- [(String, Module)]
-> TypeCheck
     VarIdent ([(String, [Decl'])], [TypeErrorInScopedContext VarIdent])
typecheckModulesWithLocation' [(String, Module)]
ms
          ([(String, [Decl'])], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([(String, [Decl'])], [TypeErrorInScopedContext VarIdent])
forall a.
a
-> ReaderT
     (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((String
path, [Decl']
decls) (String, [Decl']) -> [(String, [Decl'])] -> [(String, [Decl'])]
forall a. a -> [a] -> [a]
: [(String, [Decl'])]
decls', [TypeErrorInScopedContext VarIdent]
errors)

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) (Except (TypeErrorInScopedContext VarIdent)) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  m :: (String, Module)
m@(String
path, Module
_) : [(String, Module)]
ms -> do
    ([Decl']
decls, [TypeErrorInScopedContext VarIdent]
errs) <- (String, Module)
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
typecheckModuleWithLocation (String, Module)
m
    case [TypeErrorInScopedContext VarIdent]
errs of
      TypeErrorInScopedContext VarIdent
err : [TypeErrorInScopedContext VarIdent]
_ -> do
        TypeErrorInScopedContext VarIdent
-> TypeCheck VarIdent [(String, [Decl'])]
forall a.
TypeErrorInScopedContext VarIdent
-> ReaderT
     (Context VarIdent) (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) (Except (TypeErrorInScopedContext VarIdent)) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  Module
m : [Module]
ms -> do
    ([Decl']
decls, [TypeErrorInScopedContext VarIdent]
errs) <- Maybe String
-> Module
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
typecheckModule Maybe String
forall a. Maybe a
Nothing Module
m
    case [TypeErrorInScopedContext VarIdent]
errs of
      TypeErrorInScopedContext VarIdent
err : [TypeErrorInScopedContext VarIdent]
_ -> do
        TypeErrorInScopedContext VarIdent -> TypeCheck VarIdent [Decl']
forall a.
TypeErrorInScopedContext VarIdent
-> ReaderT
     (Context VarIdent) (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) (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) (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) (Except (TypeErrorInScopedContext VarIdent)) ())
-> [VarIdent]
-> ReaderT
     (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ VarIdent
-> ReaderT
     (Context VarIdent) (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)
          [ParamDecl]
paramDecls <- [[ParamDecl]] -> [ParamDecl]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[ParamDecl]] -> [ParamDecl])
-> ReaderT
     (Context VarIdent)
     (Except (TypeErrorInScopedContext VarIdent))
     [[ParamDecl]]
-> ReaderT
     (Context VarIdent)
     (Except (TypeErrorInScopedContext VarIdent))
     [ParamDecl]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Param' BNFC'Position
 -> ReaderT
      (Context VarIdent)
      (Except (TypeErrorInScopedContext VarIdent))
      [ParamDecl])
-> [Param' BNFC'Position]
-> ReaderT
     (Context VarIdent)
     (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)
     (Except (TypeErrorInScopedContext VarIdent))
     [ParamDecl]
forall var. Param' BNFC'Position -> TypeCheck var [ParamDecl]
paramToParamDecl [Param' BNFC'Position]
params
          TermT VarIdent
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' ([ParamDecl] -> Term' BNFC'Position -> Term' BNFC'Position
addParamDecls [ParamDecl]
paramDecls 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) (Except (TypeErrorInScopedContext VarIdent)) a
-> (a
    -> ReaderT
         (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) b)
-> ReaderT
     (Context VarIdent) (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
          TermT VarIdent
term' <- 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' ([Param' BNFC'Position]
-> Term' BNFC'Position -> Term' BNFC'Position
addParams [Param' BNFC'Position]
params Term' BNFC'Position
term)) TermT VarIdent
ty' TypeCheck VarIdent (TermT VarIdent)
-> (TermT VarIdent -> TypeCheck VarIdent (TermT VarIdent))
-> TypeCheck VarIdent (TermT VarIdent)
forall a b.
ReaderT
  (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) a
-> (a
    -> ReaderT
         (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) b)
-> ReaderT
     (Context VarIdent) (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
          Maybe LocationInfo
loc <- (Context VarIdent -> Maybe LocationInfo)
-> ReaderT
     (Context VarIdent)
     (Except (TypeErrorInScopedContext VarIdent))
     (Maybe LocationInfo)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context VarIdent -> Maybe LocationInfo
forall var. Context var -> Maybe LocationInfo
location
          let decl :: Decl'
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
          (([Decl'], [TypeErrorInScopedContext VarIdent])
 -> ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a b.
(a -> b)
-> ReaderT
     (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) a
-> ReaderT
     (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Decl'] -> [Decl'])
-> ([Decl'], [TypeErrorInScopedContext VarIdent])
-> ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Decl'
decl Decl' -> [Decl'] -> [Decl']
forall a. a -> [a] -> [a]
:)) (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
$
            Decl'
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a. Decl' -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclPrepared Decl'
decl (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
              Context{Bool
[[TermT VarIdent]]
[TermT VarIdent]
[ScopeInfo VarIdent]
[Action VarIdent]
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: forall var. Context var -> Maybe LocationInfo
localScopes :: [ScopeInfo VarIdent]
localTopes :: [TermT VarIdent]
localTopesNF :: [TermT VarIdent]
localTopesNFUnion :: [[TermT VarIdent]]
localTopesEntailBottom :: Bool
actionStack :: [Action VarIdent]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
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 -> Bool
localTopesNFUnion :: forall var. Context var -> [[TermT var]]
localTopesNF :: forall var. Context var -> [TermT var]
localTopes :: forall var. Context var -> [TermT var]
localScopes :: forall var. Context var -> [ScopeInfo var]
..} <- ReaderT
  (Context VarIdent)
  (Except (TypeErrorInScopedContext VarIdent))
  (Context VarIdent)
forall r (m :: * -> *). MonadReader r m => m r
ask
              Maybe String
termSVG <-
                case Maybe RenderBackend
renderBackend of
                  Just RenderBackend
RenderSVG -> TermT VarIdent
-> ReaderT
     (Context VarIdent)
     (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)
     (Except (TypeErrorInScopedContext VarIdent))
     (Maybe String)
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError VarIdent
 -> ReaderT
      (Context VarIdent)
      (Except (TypeErrorInScopedContext VarIdent))
      (Maybe String))
-> TypeError VarIdent
-> ReaderT
     (Context VarIdent)
     (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)
     (Except (TypeErrorInScopedContext VarIdent))
     (Maybe String)
forall a.
a
-> ReaderT
     (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
              (TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
 -> TypeCheck
      VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> (String
    -> TypeCheck
         VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
    -> TypeCheck
         VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> Maybe String
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a. a -> a
id String
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a. String -> a -> a
trace Maybe String
termSVG (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
                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.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) (Except (TypeErrorInScopedContext VarIdent)) ())
-> [VarIdent]
-> ReaderT
     (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ VarIdent
-> ReaderT
     (Context VarIdent) (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)
          [ParamDecl]
paramDecls <- [[ParamDecl]] -> [ParamDecl]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[ParamDecl]] -> [ParamDecl])
-> ReaderT
     (Context VarIdent)
     (Except (TypeErrorInScopedContext VarIdent))
     [[ParamDecl]]
-> ReaderT
     (Context VarIdent)
     (Except (TypeErrorInScopedContext VarIdent))
     [ParamDecl]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Param' BNFC'Position
 -> ReaderT
      (Context VarIdent)
      (Except (TypeErrorInScopedContext VarIdent))
      [ParamDecl])
-> [Param' BNFC'Position]
-> ReaderT
     (Context VarIdent)
     (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)
     (Except (TypeErrorInScopedContext VarIdent))
     [ParamDecl]
forall var. Param' BNFC'Position -> TypeCheck var [ParamDecl]
paramToParamDecl [Param' BNFC'Position]
params
          TermT VarIdent
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' ([ParamDecl] -> Term' BNFC'Position -> Term' BNFC'Position
addParamDecls [ParamDecl]
paramDecls 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) (Except (TypeErrorInScopedContext VarIdent)) a
-> (a
    -> ReaderT
         (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) b)
-> ReaderT
     (Context VarIdent) (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
          Maybe LocationInfo
loc <- (Context VarIdent -> Maybe LocationInfo)
-> ReaderT
     (Context VarIdent)
     (Except (TypeErrorInScopedContext VarIdent))
     (Maybe LocationInfo)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context VarIdent -> Maybe LocationInfo
forall var. Context var -> Maybe LocationInfo
location
          let decl :: Decl'
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
          (([Decl'], [TypeErrorInScopedContext VarIdent])
 -> ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a b.
(a -> b)
-> ReaderT
     (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) a
-> ReaderT
     (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Decl'] -> [Decl'])
-> ([Decl'], [TypeErrorInScopedContext VarIdent])
-> ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Decl'
decl Decl' -> [Decl'] -> [Decl']
forall a. a -> [a] -> [a]
:)) (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
$
            Decl'
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a. Decl' -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclPrepared Decl'
decl (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.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
          TermT VarIdent
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) (Except (TypeErrorInScopedContext VarIdent)) a
-> (a
    -> ReaderT
         (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) b)
-> ReaderT
     (Context VarIdent) (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
          TermT VarIdent
_term' <- 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
term) TermT VarIdent
ty'
          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 (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
          TermT VarIdent
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) (Except (TypeErrorInScopedContext VarIdent)) a
-> (a
    -> ReaderT
         (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) b)
-> ReaderT
     (Context VarIdent) (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
          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
<> Term VarIdent -> String
forall a. Show a => a -> String
show (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
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
            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.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
          TermT VarIdent
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) (Except (TypeErrorInScopedContext VarIdent)) a
-> (a
    -> ReaderT
         (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) b)
-> ReaderT
     (Context VarIdent) (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
          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
<> Term VarIdent -> String
forall a. Show a => a -> String
show (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
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
            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.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
          TermT VarIdent
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
          Maybe LocationInfo
loc <- (Context VarIdent -> Maybe LocationInfo)
-> ReaderT
     (Context VarIdent)
     (Except (TypeErrorInScopedContext VarIdent))
     (Maybe LocationInfo)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context VarIdent -> Maybe LocationInfo
forall var. Context var -> Maybe LocationInfo
location
          let decls :: [Decl']
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 ]
          (([Decl'], [TypeErrorInScopedContext VarIdent])
 -> ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a b.
(a -> b)
-> ReaderT
     (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) a
-> ReaderT
     (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Decl'] -> [Decl'])
-> ([Decl'], [TypeErrorInScopedContext VarIdent])
-> ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ([Decl']
decls [Decl'] -> [Decl'] -> [Decl']
forall a. Semigroup a => a -> a -> a
<>)) (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
$
            [Decl']
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a. [Decl'] -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclsPrepared [Decl']
decls (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.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
        ([Command]
sectionCommands, [Command]
moreCommands') <- SectionName
-> [Command] -> TypeCheck VarIdent ([Command], [Command])
forall var.
SectionName -> [Command] -> TypeCheck var ([Command], [Command])
splitSectionCommands SectionName
name [Command]
moreCommands
        Maybe SectionName
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
withSection (SectionName -> Maybe SectionName
forall a. a -> Maybe a
Just SectionName
name) (Integer
-> [Command]
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
go Integer
i [Command]
sectionCommands) (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
          Integer
-> [Command]
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
go (Integer
i Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ [Command] -> Integer
forall a. Integral a => [Command] -> a
countCommands [Command]
sectionCommands) [Command]
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
  ([Command]
cs1, [Command]
cs2) <- SectionName -> [Command] -> TypeCheck var ([Command], [Command])
forall var.
SectionName -> [Command] -> TypeCheck var ([Command], [Command])
splitSectionCommands SectionName
name' [Command]
moreCommands
  ([Command]
cs3, [Command]
cs4) <- SectionName -> [Command] -> TypeCheck var ([Command], [Command])
forall var.
SectionName -> [Command] -> TypeCheck var ([Command], [Command])
splitSectionCommands SectionName
name [Command]
cs2
  ([Command], [Command]) -> TypeCheck var ([Command], [Command])
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Command]
cs1 [Command] -> [Command] -> [Command]
forall a. Semigroup a => a -> a -> a
<> [Command]
cs3, [Command]
cs4)
splitSectionCommands SectionName
name (Rzk.CommandSectionEnd BNFC'Position
_loc SectionName
endName : [Command]
moreCommands) = do
  Bool
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) ()
-> ReaderT (Context var) (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) (Except (TypeErrorInScopedContext var)) ()
 -> ReaderT
      (Context var) (Except (TypeErrorInScopedContext var)) ())
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) ()
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) ()
forall a b. (a -> b) -> a -> b
$
    TypeError var
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) ()
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var
 -> ReaderT
      (Context var) (Except (TypeErrorInScopedContext var)) ())
-> TypeError var
-> ReaderT (Context var) (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) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [Command]
moreCommands)
splitSectionCommands SectionName
name (Command
command : [Command]
moreCommands) = do
  ([Command]
cs1, [Command]
cs2) <- SectionName -> [Command] -> TypeCheck var ([Command], [Command])
forall var.
SectionName -> [Command] -> TypeCheck var ([Command], [Command])
splitSectionCommands SectionName
name [Command]
moreCommands
  ([Command], [Command]) -> TypeCheck var ([Command], [Command])
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Command
command Command -> [Command] -> [Command]
forall a. a -> [a] -> [a]
: [Command]
cs1, [Command]
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\")"
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 Any -> Verbosity
forall var. Context var -> Verbosity
verbosity Context Any
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) (Except (TypeErrorInScopedContext var)) [ParamDecl]
forall a.
a
-> ReaderT (Context var) (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) (Except (TypeErrorInScopedContext var)) [ParamDecl]
forall a.
a
-> ReaderT (Context var) (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) (Except (TypeErrorInScopedContext var)) [ParamDecl]
forall a.
a
-> ReaderT (Context var) (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) (Except (TypeErrorInScopedContext var)) [ParamDecl]
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var
 -> ReaderT
      (Context var) (Except (TypeErrorInScopedContext var)) [ParamDecl])
-> TypeError var
-> ReaderT
     (Context var) (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"

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)
  | 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)
  | TypeErrorUndefined var
  | TypeErrorTopeNotSatisfied [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

ppTypeError' :: TypeError' -> String
ppTypeError' :: TypeError VarIdent -> String
ppTypeError' = \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
forall a. Show a => a -> String
show (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
forall a. Show a => a -> String
show (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
forall a. Show a => a -> String
show (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
forall a. Show a => a -> String
show (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
forall a. Show a => a -> String
show (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
forall a. Show a => a -> String
show (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
forall a. Show a => a -> String
show (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
""
    ]

  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
forall a. Show a => a -> String
show 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
forall a. Show a => a -> String
show 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
forall a. Show a => a -> String
show 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
forall a. Show a => a -> String
show 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
forall a. Show a => a -> String
show 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
forall a. Show a => a -> String
show 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
forall a. Show a => a -> String
show (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
forall a. Show a => a -> String
show (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
forall a. Show a => a -> String
show (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
forall a. Show a => a -> String
show 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
forall a. Show a => a -> String
show Term VarIdent
term
    ]
  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
forall a. Show a => a -> String
show (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
forall a. Show a => a -> String
show [TermT VarIdent]
topes))
    , 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
forall a. Show a => a -> String
show ([TermT VarIdent] -> [TermT VarIdent]
forall var. Eq var => [TermT var] -> [TermT var]
generateTopesForPoints (TermT VarIdent -> [TermT VarIdent]
forall var. Eq var => TermT var -> [TermT var]
allTopePoints TermT VarIdent
tope))))] -- FIXME: remove
  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
forall a. Show a => a -> String
show (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
forall a. Show a => a -> String
show (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
forall a. Show a => a -> String
show 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
forall a. Show a => a -> String
show (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
forall a. Show a => a -> String
show (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
forall a. Show a => a -> String
show (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)
    ]

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
  [ TypeError VarIdent -> String
ppTypeError' TypeError VarIdent
typeErrorError
  , String
""
  , OutputDirection -> Context VarIdent -> String
ppContext' OutputDirection
dir 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) (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 var
context <- ReaderT
  (Context var) (Except (TypeErrorInScopedContext var)) (Context var)
forall r (m :: * -> *). MonadReader r m => m r
ask
  TypeErrorInScopedContext var
-> TypeCheck var (TypeErrorInScopedContext var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeErrorInScopedContext var
 -> TypeCheck var (TypeErrorInScopedContext var))
-> TypeErrorInScopedContext var
-> TypeCheck var (TypeErrorInScopedContext var)
forall a b. (a -> b) -> a -> b
$ TypeErrorInContext var -> TypeErrorInScopedContext var
forall var. TypeErrorInContext var -> TypeErrorInScopedContext var
PlainTypeError (TypeErrorInContext var -> TypeErrorInScopedContext var)
-> TypeErrorInContext var -> TypeErrorInScopedContext var
forall a b. (a -> b) -> a -> b
$ TypeErrorInContext
    { typeErrorError :: TypeError var
typeErrorError = TypeError var
err
    , typeErrorContext :: Context var
typeErrorContext = Context var
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) (Except (TypeErrorInScopedContext var)) a)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TypeErrorInScopedContext var
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall a.
TypeErrorInScopedContext var
-> ReaderT (Context var) (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)
  | ActionContextEquiv [TermT var] [TermT var]
  | ActionWHNF (TermT var)
  | ActionNF (TermT var)
  | ActionCheckCoherence (TermT var, TermT var) (TermT var, TermT var)
  | ActionCloseSection (Maybe Rzk.SectionName)
  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

ppTermInContext :: Eq var => TermT var -> TypeCheck var String
ppTermInContext :: forall var. Eq var => TermT var -> TypeCheck var String
ppTermInContext TermT var
term =  do
  [var]
vars <- TermT var -> TypeCheck var [var]
forall var. Eq var => TermT var -> TypeCheck var [var]
freeVarsT_ TermT var
term
  let mapping :: [(var, VarIdent)]
mapping = [var] -> [VarIdent] -> [(var, VarIdent)]
forall a b. [a] -> [b] -> [(a, b)]
zip [var]
vars [VarIdent]
defaultVarIdents
      toRzkVarIdent :: [(var, Maybe VarIdent)] -> var -> VarIdent
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
  [(var, Maybe VarIdent)]
origs <- (Context var -> [(var, Maybe VarIdent)])
-> ReaderT
     (Context var)
     (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
  String -> TypeCheck var String
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Term VarIdent -> String
forall a. Show a => a -> String
show (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped ([(var, Maybe VarIdent)] -> var -> VarIdent
toRzkVarIdent [(var, Maybe VarIdent)]
origs (var -> VarIdent) -> TermT var -> TermT VarIdent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
term)))

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 = 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 :: Int -> Action' -> String
ppAction :: Int -> Action VarIdent -> String
ppAction 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
forall a. Show a => a -> String
show Term VarIdent
term
    , String
"against type"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
forall a. Show a => a -> String
show (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
forall a. Show a => a -> String
show (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
forall a. Show a => a -> String
show (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
forall a. Show a => a -> String
show (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"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TermT VarIdent -> String
forall a. Show a => a -> String
show TermT VarIdent
expected
    , String
"with term"
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TermT VarIdent -> String
forall a. Show a => a -> String
show 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
forall a. Show a => a -> String
show 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
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
. 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
forall a. Show a => a -> String
show (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
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
. 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
forall a. Show a => a -> String
show (TermT VarIdent -> Term VarIdent
forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
term) ]

  ActionContextEquiv [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
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
. 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 equivalent to 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
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
. 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
forall a. Show a => a -> String
show 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
forall a. Show a => a -> String
show (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
forall a. Show a => a -> String
show (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
forall a. Show a => a -> String
show (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
forall a. Show a => a -> String
show (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
forall a. Show a => a -> String
show (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)"]


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
<> 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)

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{Bool
[[TermT var]]
[TermT var]
[ScopeInfo var]
[Action var]
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: forall var. Context var -> Maybe LocationInfo
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 -> Bool
localTopesNFUnion :: forall var. Context var -> [[TermT var]]
localTopesNF :: forall var. Context var -> [TermT var]
localTopes :: forall var. Context var -> [TermT var]
localScopes :: forall var. Context var -> [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopes :: [TermT var]
localTopesNF :: [TermT var]
localTopesNFUnion :: [[TermT var]]
localTopesEntailBottom :: Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
..} <- ReaderT
  (Context var) (Except (TypeErrorInScopedContext var)) (Context var)
forall r (m :: * -> *). MonadReader r m => m r
ask
  Verbosity
-> Verbosity -> String -> TypeCheck var a -> TypeCheck var a
forall a. Verbosity -> Verbosity -> String -> a -> a
trace' Verbosity
msgLevel Verbosity
verbosity String
msg TypeCheck var a
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) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall a.
(Context var -> Context var)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (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) (Except (TypeErrorInScopedContext var)) a
 -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a)
-> (Context var -> Context var)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall a b. (a -> b) -> a -> b
$ \Context{Bool
[[TermT var]]
[TermT var]
[ScopeInfo var]
[Action var]
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: forall var. Context var -> Maybe LocationInfo
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 -> Bool
localTopesNFUnion :: forall var. Context var -> [[TermT var]]
localTopesNF :: forall var. Context var -> [TermT var]
localTopes :: forall var. Context var -> [TermT var]
localScopes :: forall var. Context var -> [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopes :: [TermT var]
localTopesNF :: [TermT var]
localTopesNFUnion :: [[TermT var]]
localTopesEntailBottom :: Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
..} -> Context { verbosity :: Verbosity
verbosity = Verbosity
v, Bool
[[TermT var]]
[TermT var]
[ScopeInfo var]
[Action var]
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
location :: Maybe LocationInfo
renderBackend :: Maybe RenderBackend
covariance :: Covariance
currentCommand :: Maybe Command
actionStack :: [Action var]
localTopesEntailBottom :: Bool
localTopesNFUnion :: [[TermT var]]
localTopesNF :: [TermT var]
localTopes :: [TermT var]
localScopes :: [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopes :: [TermT var]
localTopesNF :: [TermT var]
localTopesNFUnion :: [[TermT var]]
localTopesEntailBottom :: Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
covariance :: Covariance
renderBackend :: Maybe RenderBackend
.. }

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) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall a.
(Context var -> Context var)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (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) (Except (TypeErrorInScopedContext var)) a
 -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a)
-> (Context var -> Context var)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall a b. (a -> b) -> a -> b
$ \Context{Bool
[[TermT var]]
[TermT var]
[ScopeInfo var]
[Action var]
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: forall var. Context var -> Maybe LocationInfo
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 -> Bool
localTopesNFUnion :: forall var. Context var -> [[TermT var]]
localTopesNF :: forall var. Context var -> [TermT var]
localTopes :: forall var. Context var -> [TermT var]
localScopes :: forall var. Context var -> [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopes :: [TermT var]
localTopesNF :: [TermT var]
localTopesNFUnion :: [[TermT var]]
localTopesEntailBottom :: Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
..} -> Context { renderBackend :: Maybe RenderBackend
renderBackend = Maybe RenderBackend
v, Bool
[[TermT var]]
[TermT var]
[ScopeInfo var]
[Action var]
Maybe Command
Maybe LocationInfo
Covariance
Verbosity
location :: Maybe LocationInfo
covariance :: Covariance
verbosity :: Verbosity
currentCommand :: Maybe Command
actionStack :: [Action var]
localTopesEntailBottom :: Bool
localTopesNFUnion :: [[TermT var]]
localTopesNF :: [TermT var]
localTopes :: [TermT var]
localScopes :: [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopes :: [TermT var]
localTopesNF :: [TermT var]
localTopesNFUnion :: [[TermT var]]
localTopesEntailBottom :: Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
.. }

data Covariance
  = Covariant     -- ^ Positive position.
  | Contravariant -- ^ Negative 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
.. }

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 -> Maybe VarIdent
varOrig                :: Maybe VarIdent
  , forall var. VarInfo var -> Bool
varIsAssumption        :: Bool -- FIXME: perhaps, introduce something like decl kind?
  , 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)

data Context var = Context
  { forall var. Context var -> [ScopeInfo var]
localScopes            :: [ScopeInfo var]
  , forall var. Context var -> [TermT var]
localTopes             :: [TermT var]
  , forall var. Context var -> [TermT var]
localTopesNF           :: [TermT var]
  , forall var. Context var -> [[TermT var]]
localTopesNFUnion      :: [[TermT var]]
  , forall var. Context var -> Bool
localTopesEntailBottom :: 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
  } 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
[[TermT var]]
[TermT var]
[ScopeInfo var]
[Action var]
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: forall var. Context var -> Maybe LocationInfo
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 -> Bool
localTopesNFUnion :: forall var. Context var -> [[TermT var]]
localTopesNF :: forall var. Context var -> [TermT var]
localTopes :: forall var. Context var -> [TermT var]
localScopes :: forall var. Context var -> [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopes :: [TermT var]
localTopesNF :: [TermT var]
localTopesNFUnion :: [[TermT var]]
localTopesEntailBottom :: Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
..} = 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
[[TermT var]]
[TermT var]
[Action var]
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: Maybe LocationInfo
renderBackend :: Maybe RenderBackend
covariance :: Covariance
verbosity :: Verbosity
currentCommand :: Maybe Command
actionStack :: [Action var]
localTopesEntailBottom :: Bool
localTopesNFUnion :: [[TermT var]]
localTopesNF :: [TermT var]
localTopes :: [TermT var]
localTopes :: [TermT var]
localTopesNF :: [TermT var]
localTopesNFUnion :: [[TermT var]]
localTopesEntailBottom :: Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
.. }

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 :: [TermT var]
localTopes = [TermT var
forall var. TermT var
topeTopT]
  , localTopesNF :: [TermT var]
localTopesNF = [TermT var
forall var. TermT var
topeTopT]
  , localTopesNFUnion :: [[TermT var]]
localTopesNFUnion = [[TermT var
forall var. TermT var
topeTopT]]
  , localTopesEntailBottom :: Bool
localTopesEntailBottom = 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
  }

askCurrentScope :: TypeCheck var (ScopeInfo var)
askCurrentScope :: forall var. TypeCheck var (ScopeInfo var)
askCurrentScope = (Context var -> [ScopeInfo var])
-> ReaderT
     (Context var)
     (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)
  (Except (TypeErrorInScopedContext var))
  [ScopeInfo var]
-> ([ScopeInfo var]
    -> ReaderT
         (Context var)
         (Except (TypeErrorInScopedContext var))
         (ScopeInfo var))
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (ScopeInfo var)
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  []              -> String
-> ReaderT
     (Context var)
     (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)
     (Except (TypeErrorInScopedContext var))
     (ScopeInfo var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ScopeInfo var
scope

varInfos :: Context var -> [(var, VarInfo var)]
varInfos :: forall var. Context var -> [(var, VarInfo var)]
varInfos Context{Bool
[[TermT var]]
[TermT var]
[ScopeInfo var]
[Action var]
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: forall var. Context var -> Maybe LocationInfo
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 -> Bool
localTopesNFUnion :: forall var. Context var -> [[TermT var]]
localTopesNF :: forall var. Context var -> [TermT var]
localTopes :: forall var. Context var -> [TermT var]
localScopes :: forall var. Context var -> [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopes :: [TermT var]
localTopesNF :: [TermT var]
localTopesNFUnion :: [[TermT var]]
localTopesEntailBottom :: Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
..} = (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 VarInfo var -> Maybe VarIdent
forall var. VarInfo var -> Maybe VarIdent
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

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
  ([Decl']
decls, [err]
errs) <- TypeCheck VarIdent ([Decl'], [err])
tc
  if [err] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [err]
errs
    then ([Decl'] -> [Decl']) -> ([Decl'], [err]) -> ([Decl'], [err])
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ([Decl']
decls [Decl'] -> [Decl'] -> [Decl']
forall a. Semigroup a => a -> a -> a
<>)
      (([Decl'], [err]) -> ([Decl'], [err]))
-> TypeCheck VarIdent ([Decl'], [err])
-> TypeCheck VarIdent ([Decl'], [err])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Decl']
-> TypeCheck VarIdent ([Decl'], [err])
-> TypeCheck VarIdent ([Decl'], [err])
forall a. [Decl'] -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclsPrepared [Decl']
decls TypeCheck VarIdent ([Decl'], [err])
next
    else ([Decl'], [err]) -> TypeCheck VarIdent ([Decl'], [err])
forall a.
a
-> ReaderT
     (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Decl']
decls, [err]
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
    ([Decl']
decls, [TypeErrorInScopedContext VarIdent]
errs) <- TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
sectionBody
    [Decl']
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a. [Decl'] -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclsPrepared [Decl']
decls (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
$
      Action VarIdent
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall var a.
Eq var =>
Action var -> TypeCheck var a -> TypeCheck var a
performing (Maybe SectionName -> Action VarIdent
forall var. Maybe SectionName -> Action var
ActionCloseSection 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
        Either
  (TypeErrorInScopedContext VarIdent)
  ([Decl'], [TypeErrorInScopedContext VarIdent])
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)
     (Except (TypeErrorInScopedContext VarIdent))
     (Either
        (TypeErrorInScopedContext VarIdent)
        ([Decl'], [TypeErrorInScopedContext VarIdent]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TypeErrorInScopedContext VarIdent]
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
endSection [TypeErrorInScopedContext VarIdent]
errs) ReaderT
  (Context VarIdent)
  (Except (TypeErrorInScopedContext VarIdent))
  (Either
     (TypeErrorInScopedContext VarIdent)
     ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> (TypeErrorInScopedContext VarIdent
    -> ReaderT
         (Context VarIdent)
         (Except (TypeErrorInScopedContext VarIdent))
         (Either
            (TypeErrorInScopedContext VarIdent)
            ([Decl'], [TypeErrorInScopedContext VarIdent])))
-> ReaderT
     (Context VarIdent)
     (Except (TypeErrorInScopedContext VarIdent))
     (Either
        (TypeErrorInScopedContext VarIdent)
        ([Decl'], [TypeErrorInScopedContext VarIdent]))
forall a.
ReaderT
  (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) a
-> (TypeErrorInScopedContext VarIdent
    -> ReaderT
         (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) a)
-> ReaderT
     (Context VarIdent) (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)
     (Except (TypeErrorInScopedContext VarIdent))
     (Either
        (TypeErrorInScopedContext VarIdent)
        ([Decl'], [TypeErrorInScopedContext VarIdent]))
forall a.
a
-> ReaderT
     (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (TypeErrorInScopedContext VarIdent)
   ([Decl'], [TypeErrorInScopedContext VarIdent])
 -> ReaderT
      (Context VarIdent)
      (Except (TypeErrorInScopedContext VarIdent))
      (Either
         (TypeErrorInScopedContext VarIdent)
         ([Decl'], [TypeErrorInScopedContext VarIdent])))
-> (TypeErrorInScopedContext VarIdent
    -> Either
         (TypeErrorInScopedContext VarIdent)
         ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> TypeErrorInScopedContext VarIdent
-> ReaderT
     (Context VarIdent)
     (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 Either
  (TypeErrorInScopedContext VarIdent)
  ([Decl'], [TypeErrorInScopedContext VarIdent])
result of
          Left TypeErrorInScopedContext VarIdent
err              -> ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a.
a
-> ReaderT
     (Context VarIdent) (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) (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) (Except (TypeErrorInScopedContext VarIdent)) a
-> ReaderT
     (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) a
forall a.
(Context VarIdent -> Context VarIdent)
-> ReaderT
     (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) a
-> ReaderT
     (Context VarIdent) (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) (Except (TypeErrorInScopedContext VarIdent)) a
 -> ReaderT
      (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) a)
-> (Context VarIdent -> Context VarIdent)
-> ReaderT
     (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) a
-> ReaderT
     (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) a
forall a b. (a -> b) -> a -> b
$ \Context{Bool
[[TermT VarIdent]]
[TermT VarIdent]
[ScopeInfo VarIdent]
[Action VarIdent]
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: forall var. Context var -> Maybe LocationInfo
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 -> Bool
localTopesNFUnion :: forall var. Context var -> [[TermT var]]
localTopesNF :: forall var. Context var -> [TermT var]
localTopes :: forall var. Context var -> [TermT var]
localScopes :: forall var. Context var -> [ScopeInfo var]
localScopes :: [ScopeInfo VarIdent]
localTopes :: [TermT VarIdent]
localTopesNF :: [TermT VarIdent]
localTopesNFUnion :: [[TermT VarIdent]]
localTopesEntailBottom :: Bool
actionStack :: [Action VarIdent]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
..} -> 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
[[TermT VarIdent]]
[TermT VarIdent]
[Action VarIdent]
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: Maybe LocationInfo
renderBackend :: Maybe RenderBackend
covariance :: Covariance
verbosity :: Verbosity
currentCommand :: Maybe Command
actionStack :: [Action VarIdent]
localTopesEntailBottom :: Bool
localTopesNFUnion :: [[TermT VarIdent]]
localTopesNF :: [TermT VarIdent]
localTopes :: [TermT VarIdent]
localTopes :: [TermT VarIdent]
localTopesNF :: [TermT VarIdent]
localTopesNFUnion :: [[TermT VarIdent]]
localTopesEntailBottom :: Bool
actionStack :: [Action VarIdent]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
.. }

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) (Except (TypeErrorInScopedContext VarIdent)) a
-> (a
    -> ReaderT
         (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) b)
-> ReaderT
     (Context VarIdent) (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
  ([Decl var]
decls, [TypeErrorInScopedContext var]
errs') <- [TypeErrorInScopedContext var]
-> [(var, VarInfo var)]
-> [(var, VarInfo var)]
-> TypeCheck var ([Decl var], [TypeErrorInScopedContext var])
forall var.
Eq var =>
[TypeErrorInScopedContext var]
-> [(var, VarInfo var)]
-> [(var, VarInfo var)]
-> TypeCheck var ([Decl var], [TypeErrorInScopedContext var])
collectScopeDecls [TypeErrorInScopedContext var]
errs [] [(var, VarInfo var)]
scopeVars
  -- only issue unused variable errors if there were no errors prior in the section
  -- when (null errs) $ do
  [[TypeErrorInScopedContext var]]
unusedErrors <- [Decl var]
-> (Decl var
    -> ReaderT
         (Context var)
         (Except (TypeErrorInScopedContext var))
         [TypeErrorInScopedContext var])
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     [[TypeErrorInScopedContext var]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Decl var]
decls ((Decl var
  -> ReaderT
       (Context var)
       (Except (TypeErrorInScopedContext var))
       [TypeErrorInScopedContext var])
 -> ReaderT
      (Context var)
      (Except (TypeErrorInScopedContext var))
      [[TypeErrorInScopedContext var]])
-> (Decl var
    -> ReaderT
         (Context var)
         (Except (TypeErrorInScopedContext var))
         [TypeErrorInScopedContext var])
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     [[TypeErrorInScopedContext var]]
forall a b. (a -> b) -> a -> b
$ \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)
      then do
        TypeErrorInScopedContext var
err <- (Context var -> Context var)
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (TypeErrorInScopedContext var)
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (TypeErrorInScopedContext var)
forall a.
(Context var -> Context var)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (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)
   (Except (TypeErrorInScopedContext var))
   (TypeErrorInScopedContext var)
 -> ReaderT
      (Context var)
      (Except (TypeErrorInScopedContext var))
      (TypeErrorInScopedContext var))
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (TypeErrorInScopedContext var)
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (TypeErrorInScopedContext var)
forall a b. (a -> b) -> a -> b
$
          TypeError var
-> ReaderT
     (Context var)
     (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)
        [TypeErrorInScopedContext var]
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     [TypeErrorInScopedContext var]
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return [TypeErrorInScopedContext var
err]
      else [TypeErrorInScopedContext var]
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     [TypeErrorInScopedContext var]
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  ([Decl var], [TypeErrorInScopedContext var])
-> TypeCheck var ([Decl var], [TypeErrorInScopedContext var])
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Decl var]
decls, [TypeErrorInScopedContext var]
errs' [TypeErrorInScopedContext var]
-> [TypeErrorInScopedContext var] -> [TypeErrorInScopedContext var]
forall a. Semigroup a => a -> a -> a
<> [[TypeErrorInScopedContext var]] -> [TypeErrorInScopedContext var]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[TypeErrorInScopedContext var]]
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 VarIdent
Maybe LocationInfo
TermT var
varType :: forall var. VarInfo var -> TermT var
varValue :: forall var. VarInfo var -> Maybe (TermT var)
varOrig :: forall var. VarInfo var -> Maybe VarIdent
varIsAssumption :: forall var. VarInfo var -> Bool
varDeclaredAssumptions :: forall var. VarInfo var -> [var]
varLocation :: forall var. VarInfo var -> Maybe LocationInfo
varType :: TermT var
varValue :: Maybe (TermT var)
varOrig :: Maybe VarIdent
varIsAssumption :: 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 VarIdent
Maybe LocationInfo
TermT var
varType :: forall var. VarInfo var -> TermT var
varValue :: forall var. VarInfo var -> Maybe (TermT var)
varOrig :: forall var. VarInfo var -> Maybe VarIdent
varIsAssumption :: forall var. VarInfo var -> Bool
varDeclaredAssumptions :: forall var. VarInfo var -> [var]
varLocation :: forall var. VarInfo var -> Maybe LocationInfo
varType :: TermT var
varValue :: Maybe (TermT var)
varOrig :: Maybe VarIdent
varIsAssumption :: Bool
varDeclaredAssumptions :: [var]
varLocation :: Maybe LocationInfo
..}
  | Bool
varIsAssumption = VarInfo{Bool
[var]
Maybe (TermT var)
Maybe VarIdent
Maybe LocationInfo
TermT var
varType :: TermT var
varValue :: Maybe (TermT var)
varOrig :: Maybe VarIdent
varIsAssumption :: Bool
varDeclaredAssumptions :: [var]
varLocation :: Maybe LocationInfo
varType :: TermT var
varValue :: Maybe (TermT var)
varOrig :: Maybe VarIdent
varIsAssumption :: 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
      , varOrig :: Maybe VarIdent
varOrig = Maybe VarIdent
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)
     (Except (TypeErrorInScopedContext var))
     (Bool, [(var, VarInfo var)])
forall a.
a
-> ReaderT (Context var) (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
  [var]
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)
  [var]
varsInBody <- Maybe [var] -> [var]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Maybe [var] -> [var])
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) (Maybe [var])
-> TypeCheck var [var]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TermT var -> TypeCheck var [var])
-> Maybe (TermT var)
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) (Maybe [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 TermT var -> TypeCheck var [var]
forall var. Eq var => TermT var -> TypeCheck var [var]
freeVarsT_ (VarInfo var -> Maybe (TermT var)
forall var. VarInfo var -> Maybe (TermT var)
varValue VarInfo var
xInfo)
  let xFreeVars :: [var]
xFreeVars = [var]
varsInBody [var] -> [var] -> [var]
forall a. Semigroup a => a -> a -> a
<> [var]
varsInType
  let hasAssumption :: Bool
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
  TermT var
xType <- var -> TypeCheck var (TermT var)
forall var. Eq var => var -> TypeCheck var (TermT var)
typeOfVar var
x
  Maybe (TermT var)
xValue <- var -> TypeCheck var (Maybe (TermT var))
forall var. Eq var => var -> TypeCheck var (Maybe (TermT var))
valueOfVar var
x
  let assumptionInType :: Bool
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 :: Bool
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
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 Bool
hasAssumption
     then do
       Bool
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) ()
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
implicitAssumption (ReaderT (Context var) (Except (TypeErrorInScopedContext var)) ()
 -> ReaderT
      (Context var) (Except (TypeErrorInScopedContext var)) ())
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) ()
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) ()
forall a b. (a -> b) -> a -> b
$ do
         TypeError var
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) ()
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var
 -> ReaderT
      (Context var) (Except (TypeErrorInScopedContext var)) ())
-> TypeError var
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) ()
forall a b. (a -> b) -> a -> b
$ (var, TermT var) -> var -> TypeError var
forall var. (var, TermT var) -> var -> TypeError var
TypeErrorImplicitAssumption (var
a, VarInfo var -> TermT var
forall var. VarInfo var -> TermT var
varType VarInfo var
aInfo) var
x
       (Bool
_used, [(var, VarInfo var)]
xs'') <- (var, VarInfo var)
-> [(var, VarInfo var)]
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (Bool, [(var, VarInfo var)])
forall var.
Eq var =>
(var, VarInfo var)
-> [(var, VarInfo var)]
-> TypeCheck var (Bool, [(var, VarInfo var)])
makeAssumptionExplicit (var
a, VarInfo var
aInfo) [(var, VarInfo var)]
xs'
       (Bool, [(var, VarInfo var)])
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (Bool, [(var, VarInfo var)])
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True {- USED -}, (var
x, VarInfo var
xInfo') (var, VarInfo var) -> [(var, VarInfo var)] -> [(var, VarInfo var)]
forall a. a -> [a] -> [a]
: [(var, VarInfo var)]
xs'')
     else do
       (Bool
used, [(var, VarInfo var)]
xs'') <- (var, VarInfo var)
-> [(var, VarInfo var)]
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext 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)
assumption [(var, VarInfo var)]
xs
       (Bool, [(var, VarInfo var)])
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (Bool, [(var, VarInfo var)])
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
used, (var
x, VarInfo var
xInfo) (var, VarInfo var) -> [(var, VarInfo var)] -> [(var, VarInfo var)]
forall a. a -> [a] -> [a]
: [(var, VarInfo var)]
xs'')
  where
    xType' :: TermT var
xType' = Maybe VarIdent
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall var.
Maybe VarIdent
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeFunT (VarInfo var -> Maybe VarIdent
forall var. VarInfo var -> Maybe VarIdent
varOrig VarInfo var
aInfo) (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
-> Maybe VarIdent
-> Maybe (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall var.
TermT var
-> Maybe VarIdent
-> Maybe (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
lambdaT TermT var
xType' (VarInfo var -> Maybe VarIdent
forall var. VarInfo var -> Maybe VarIdent
varOrig VarInfo var
aInfo) Maybe (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
      , varOrig :: Maybe VarIdent
varOrig = VarInfo var -> Maybe VarIdent
forall var. VarInfo var -> Maybe VarIdent
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 => [TypeErrorInScopedContext var] -> [(var, VarInfo var)] -> [(var, VarInfo var)] -> TypeCheck var ([Decl var], [TypeErrorInScopedContext var])
collectScopeDecls :: forall var.
Eq var =>
[TypeErrorInScopedContext var]
-> [(var, VarInfo var)]
-> [(var, VarInfo var)]
-> TypeCheck var ([Decl var], [TypeErrorInScopedContext var])
collectScopeDecls [TypeErrorInScopedContext var]
errs [(var, VarInfo var)]
recentVars (decl :: (var, VarInfo var)
decl@(var
var, VarInfo{Bool
[var]
Maybe (TermT var)
Maybe VarIdent
Maybe LocationInfo
TermT var
varType :: forall var. VarInfo var -> TermT var
varValue :: forall var. VarInfo var -> Maybe (TermT var)
varOrig :: forall var. VarInfo var -> Maybe VarIdent
varIsAssumption :: forall var. VarInfo var -> Bool
varDeclaredAssumptions :: forall var. VarInfo var -> [var]
varLocation :: forall var. VarInfo var -> Maybe LocationInfo
varType :: TermT var
varValue :: Maybe (TermT var)
varOrig :: Maybe VarIdent
varIsAssumption :: Bool
varDeclaredAssumptions :: [var]
varLocation :: Maybe LocationInfo
..}) : [(var, VarInfo var)]
vars)
  | Bool
varIsAssumption = do
      (Bool
used, [(var, VarInfo var)]
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
      [TypeErrorInScopedContext var]
unusedErr <-
        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 Bool
used
          then (Context var -> Context var)
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     [TypeErrorInScopedContext var]
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     [TypeErrorInScopedContext var]
forall a.
(Context var -> Context var)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (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 = varLocation }) (ReaderT
   (Context var)
   (Except (TypeErrorInScopedContext var))
   [TypeErrorInScopedContext var]
 -> ReaderT
      (Context var)
      (Except (TypeErrorInScopedContext var))
      [TypeErrorInScopedContext var])
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     [TypeErrorInScopedContext var]
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     [TypeErrorInScopedContext var]
forall a b. (a -> b) -> a -> b
$
            TypeErrorInScopedContext var -> [TypeErrorInScopedContext var]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeErrorInScopedContext var -> [TypeErrorInScopedContext var])
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (TypeErrorInScopedContext var)
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     [TypeErrorInScopedContext var]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeError var
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (TypeErrorInScopedContext var)
forall var.
TypeError var -> TypeCheck var (TypeErrorInScopedContext var)
fromTypeError (var -> TermT var -> TypeError var
forall var. var -> TermT var -> TypeError var
TypeErrorUnusedVariable var
var TermT var
varType)
          else [TypeErrorInScopedContext var]
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     [TypeErrorInScopedContext var]
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
      [TypeErrorInScopedContext var]
-> [(var, VarInfo var)]
-> [(var, VarInfo var)]
-> TypeCheck var ([Decl var], [TypeErrorInScopedContext var])
forall var.
Eq var =>
[TypeErrorInScopedContext var]
-> [(var, VarInfo var)]
-> [(var, VarInfo var)]
-> TypeCheck var ([Decl var], [TypeErrorInScopedContext var])
collectScopeDecls ([TypeErrorInScopedContext var]
errs [TypeErrorInScopedContext var]
-> [TypeErrorInScopedContext var] -> [TypeErrorInScopedContext var]
forall a. Semigroup a => a -> a -> a
<> [TypeErrorInScopedContext var]
unusedErr) [(var, VarInfo var)]
recentVars' [(var, VarInfo var)]
vars
  | Bool
otherwise = do
      [TypeErrorInScopedContext var]
-> [(var, VarInfo var)]
-> [(var, VarInfo var)]
-> TypeCheck var ([Decl var], [TypeErrorInScopedContext var])
forall var.
Eq var =>
[TypeErrorInScopedContext var]
-> [(var, VarInfo var)]
-> [(var, VarInfo var)]
-> TypeCheck var ([Decl var], [TypeErrorInScopedContext var])
collectScopeDecls [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 [TypeErrorInScopedContext var]
errs [(var, VarInfo var)]
recentVars [] = do
  Maybe LocationInfo
loc <- (Context var -> Maybe LocationInfo)
-> ReaderT
     (Context var)
     (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
  ([Decl var], [TypeErrorInScopedContext var])
-> TypeCheck var ([Decl var], [TypeErrorInScopedContext var])
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe LocationInfo -> (var, VarInfo var) -> Decl var
forall {var}. Maybe LocationInfo -> (var, VarInfo var) -> Decl var
toDecl Maybe LocationInfo
loc ((var, VarInfo var) -> Decl var)
-> [(var, VarInfo var)] -> [Decl var]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(var, VarInfo var)]
recentVars, [TypeErrorInScopedContext var]
errs)
  where
    toDecl :: Maybe LocationInfo -> (var, VarInfo var) -> Decl var
toDecl Maybe LocationInfo
loc (var
var, VarInfo{Bool
[var]
Maybe (TermT var)
Maybe VarIdent
Maybe LocationInfo
TermT var
varType :: forall var. VarInfo var -> TermT var
varValue :: forall var. VarInfo var -> Maybe (TermT var)
varOrig :: forall var. VarInfo var -> Maybe VarIdent
varIsAssumption :: forall var. VarInfo var -> Bool
varDeclaredAssumptions :: forall var. VarInfo var -> [var]
varLocation :: forall var. VarInfo var -> Maybe LocationInfo
varType :: TermT var
varValue :: Maybe (TermT var)
varOrig :: Maybe VarIdent
varIsAssumption :: 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 (Maybe VarIdent
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 VarIdent
Maybe LocationInfo
TermT var
varType :: forall var. VarInfo var -> TermT var
varValue :: forall var. VarInfo var -> Maybe (TermT var)
varOrig :: forall var. VarInfo var -> Maybe VarIdent
varIsAssumption :: forall var. VarInfo var -> Bool
varDeclaredAssumptions :: forall var. VarInfo var -> [var]
varLocation :: forall var. VarInfo var -> Maybe LocationInfo
varType :: TermT var
varValue :: Maybe (TermT var)
varOrig :: Maybe VarIdent
varIsAssumption :: 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 = Maybe VarIdent
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall var.
Maybe VarIdent
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeFunT Maybe VarIdent
varOrig 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
-> Maybe VarIdent
-> Maybe (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall var.
TermT var
-> Maybe VarIdent
-> Maybe (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
lambdaT TermT var
newDeclType Maybe VarIdent
varOrig Maybe (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 = Maybe VarIdent
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall var.
Maybe VarIdent
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeFunT Maybe VarIdent
varOrig 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
[[TermT VarIdent]]
[TermT VarIdent]
[ScopeInfo VarIdent]
[Action VarIdent]
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: forall var. Context var -> Maybe LocationInfo
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 -> Bool
localTopesNFUnion :: forall var. Context var -> [[TermT var]]
localTopesNF :: forall var. Context var -> [TermT var]
localTopes :: forall var. Context var -> [TermT var]
localScopes :: forall var. Context var -> [ScopeInfo var]
localScopes :: [ScopeInfo VarIdent]
localTopes :: [TermT VarIdent]
localTopesNF :: [TermT VarIdent]
localTopesNFUnion :: [[TermT VarIdent]]
localTopesEntailBottom :: Bool
actionStack :: [Action VarIdent]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
..} = 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) [TermT VarIdent]
localTopes 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
forall a. Show a => a -> String
show (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
<> Int -> Action VarIdent -> String
ppAction 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
      [ Term VarIdent -> String
forall a. Show a => a -> String
show (VarIdent -> Term VarIdent
forall (t :: * -> * -> *) a. a -> FS t a
Pure VarIdent
x :: Term') String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" : " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Term VarIdent -> String
forall a. Show a => a -> String
show (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) ] ]
  ]

doesShadowName :: VarIdent -> TypeCheck var [VarIdent]
doesShadowName :: forall var. VarIdent -> TypeCheck var [VarIdent]
doesShadowName VarIdent
name = (Context var -> [VarIdent])
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) [VarIdent]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Context var -> [VarIdent])
 -> ReaderT
      (Context var) (Except (TypeErrorInScopedContext var)) [VarIdent])
-> (Context var -> [VarIdent])
-> ReaderT
     (Context var) (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] -> TypeCheck var ()) -> TypeCheck var ()
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    []         -> () -> TypeCheck var ()
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [VarIdent]
collisions -> 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
$
      [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] -> TypeCheck var ()) -> TypeCheck var ()
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    [] -> () -> TypeCheck var ()
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [VarIdent]
collisions -> String -> TypeCheck var ()
forall var. String -> TypeCheck var ()
issueWarning (String -> TypeCheck var ()) -> String -> TypeCheck 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) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall a.
(Context var -> Context var)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (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) (Except (TypeErrorInScopedContext var)) a
 -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a)
-> (Context var -> Context var)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall a b. (a -> b) -> a -> b
$ \Context{Bool
[[TermT var]]
[TermT var]
[ScopeInfo var]
[Action var]
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: forall var. Context var -> Maybe LocationInfo
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 -> Bool
localTopesNFUnion :: forall var. Context var -> [[TermT var]]
localTopesNF :: forall var. Context var -> [TermT var]
localTopes :: forall var. Context var -> [TermT var]
localScopes :: forall var. Context var -> [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopes :: [TermT var]
localTopesNF :: [TermT var]
localTopesNFUnion :: [[TermT var]]
localTopesEntailBottom :: Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
..} -> Context { location :: Maybe LocationInfo
location = LocationInfo -> Maybe LocationInfo
forall a. a -> Maybe a
Just LocationInfo
loc, Bool
[[TermT var]]
[TermT var]
[ScopeInfo var]
[Action var]
Maybe Command
Maybe RenderBackend
Covariance
Verbosity
renderBackend :: Maybe RenderBackend
covariance :: Covariance
verbosity :: Verbosity
currentCommand :: Maybe Command
actionStack :: [Action var]
localTopesEntailBottom :: Bool
localTopesNFUnion :: [[TermT var]]
localTopesNF :: [TermT var]
localTopes :: [TermT var]
localScopes :: [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopes :: [TermT var]
localTopesNF :: [TermT var]
localTopesNFUnion :: [[TermT var]]
localTopesEntailBottom :: Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
.. }

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) (Except (TypeErrorInScopedContext VarIdent)) a
-> ReaderT
     (Context VarIdent) (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
  Either
  (TypeErrorInScopedContext VarIdent)
  ([Decl'], [TypeErrorInScopedContext VarIdent])
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)
     (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)
  (Except (TypeErrorInScopedContext VarIdent))
  (Either
     (TypeErrorInScopedContext VarIdent)
     ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> (TypeErrorInScopedContext VarIdent
    -> ReaderT
         (Context VarIdent)
         (Except (TypeErrorInScopedContext VarIdent))
         (Either
            (TypeErrorInScopedContext VarIdent)
            ([Decl'], [TypeErrorInScopedContext VarIdent])))
-> ReaderT
     (Context VarIdent)
     (Except (TypeErrorInScopedContext VarIdent))
     (Either
        (TypeErrorInScopedContext VarIdent)
        ([Decl'], [TypeErrorInScopedContext VarIdent]))
forall a.
ReaderT
  (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) a
-> (TypeErrorInScopedContext VarIdent
    -> ReaderT
         (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) a)
-> ReaderT
     (Context VarIdent) (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)
     (Except (TypeErrorInScopedContext VarIdent))
     (Either
        (TypeErrorInScopedContext VarIdent)
        ([Decl'], [TypeErrorInScopedContext VarIdent]))
forall a.
a
-> ReaderT
     (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (TypeErrorInScopedContext VarIdent)
   ([Decl'], [TypeErrorInScopedContext VarIdent])
 -> ReaderT
      (Context VarIdent)
      (Except (TypeErrorInScopedContext VarIdent))
      (Either
         (TypeErrorInScopedContext VarIdent)
         ([Decl'], [TypeErrorInScopedContext VarIdent])))
-> (TypeErrorInScopedContext VarIdent
    -> Either
         (TypeErrorInScopedContext VarIdent)
         ([Decl'], [TypeErrorInScopedContext VarIdent]))
-> TypeErrorInScopedContext VarIdent
-> ReaderT
     (Context VarIdent)
     (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 Either
  (TypeErrorInScopedContext VarIdent)
  ([Decl'], [TypeErrorInScopedContext VarIdent])
result of
    Left TypeErrorInScopedContext VarIdent
err            -> ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
forall a.
a
-> ReaderT
     (Context VarIdent) (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) (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
[[TermT var]]
[TermT var]
[ScopeInfo var]
[Action var]
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: forall var. Context var -> Maybe LocationInfo
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 -> Bool
localTopesNFUnion :: forall var. Context var -> [[TermT var]]
localTopesNF :: forall var. Context var -> [TermT var]
localTopes :: forall var. Context var -> [TermT var]
localScopes :: forall var. Context var -> [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopes :: [TermT var]
localTopesNF :: [TermT var]
localTopesNFUnion :: [[TermT var]]
localTopesEntailBottom :: Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
..} = 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
[[TermT var]]
[TermT var]
[ScopeInfo var]
[Action var]
Maybe RenderBackend
Covariance
Verbosity
renderBackend :: Maybe RenderBackend
covariance :: Covariance
verbosity :: Verbosity
actionStack :: [Action var]
localTopesEntailBottom :: Bool
localTopesNFUnion :: [[TermT var]]
localTopesNF :: [TermT var]
localTopes :: [TermT var]
localScopes :: [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopes :: [TermT var]
localTopesNF :: [TermT var]
localTopesNFUnion :: [[TermT var]]
localTopesEntailBottom :: Bool
actionStack :: [Action var]
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
.. }
    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
  TermT VarIdent
ty' <- TermT VarIdent -> TypeCheck VarIdent (TermT VarIdent)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT VarIdent
ty
  Maybe (TermT VarIdent)
term' <- (TermT VarIdent -> TypeCheck VarIdent (TermT VarIdent))
-> Maybe (TermT VarIdent)
-> ReaderT
     (Context VarIdent)
     (Except (TypeErrorInScopedContext VarIdent))
     (Maybe (TermT VarIdent))
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 VarIdent -> TypeCheck VarIdent (TermT VarIdent)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT Maybe (TermT VarIdent)
term
  Decl' -> TypeCheck VarIdent a -> TypeCheck VarIdent a
forall a. Decl' -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclPrepared (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 VarIdent
x TermT VarIdent
ty' Maybe (TermT VarIdent)
term' Bool
isAssumption [VarIdent]
vars Maybe LocationInfo
loc) TypeCheck VarIdent a
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) (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) (Except (TypeErrorInScopedContext VarIdent)) a
-> ReaderT
     (Context VarIdent) (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 :: Maybe VarIdent
varOrig = VarIdent -> Maybe VarIdent
forall a. a -> Maybe a
Just VarIdent
x
      , varIsAssumption :: Bool
varIsAssumption = Bool
isAssumption
      , varDeclaredAssumptions :: [VarIdent]
varDeclaredAssumptions = [VarIdent]
vars
      , varLocation :: Maybe LocationInfo
varLocation = Maybe LocationInfo
loc
      }

type TypeCheck var = ReaderT (Context var) (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
  [(var, TermT var)]
types <- (Context var -> [(var, TermT var)])
-> ReaderT
     (Context var)
     (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 -> TermT var
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
  [var] -> TypeCheck var [var]
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((var -> TermT var) -> TermT var -> [var]
forall a. Eq a => (a -> TermT a) -> TermT a -> [a]
freeVarsT var -> TermT var
typeOfVar' TermT var
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)

entail :: Eq var => [TermT var] -> TermT var -> Bool
entail :: forall var. Eq var => [TermT var] -> TermT var -> Bool
entail [TermT var]
topes TermT var
tope = ([TermT var] -> Bool) -> [[TermT var]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([TermT var] -> TermT var -> Bool
forall var. Eq var => [TermT var] -> TermT var -> Bool
`solveRHS` TermT var
tope) ([[TermT var]] -> Bool) -> [[TermT var]] -> Bool
forall a b. (a -> b) -> a -> b
$
  [TermT var] -> [TermT var] -> [TermT var]
forall var. Eq var => [TermT var] -> [TermT var] -> [TermT var]
saturateTopes (TermT var -> [TermT var]
forall var. Eq var => TermT var -> [TermT var]
allTopePoints TermT var
tope) ([TermT var] -> [TermT var]) -> [[TermT var]] -> [[TermT var]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    [TermT var] -> [[TermT var]]
forall var. Eq var => [TermT var] -> [[TermT var]]
simplifyLHSwithDisjunctions [TermT var]
topes'
  where
    topes' :: [TermT var]
topes' = [TermT var] -> [TermT var]
forall var. Eq var => [TermT var] -> [TermT var]
nubTermT ([TermT var]
topes [TermT var] -> [TermT var] -> [TermT var]
forall a. Semigroup a => a -> a -> a
<> [TermT var] -> [TermT var]
forall var. Eq var => [TermT var] -> [TermT var]
generateTopesForPoints (TermT var -> [TermT var]
forall var. Eq var => TermT var -> [TermT var]
allTopePoints TermT var
tope))

entailM :: Eq var => [TermT var] -> TermT var -> TypeCheck var Bool
entailM :: forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
entailM [TermT var]
topes TermT var
tope = do
  -- genTopes <- generateTopesForPointsM (allTopePoints tope)
  let topes' :: [TermT var]
topes'    = [TermT var] -> [TermT var]
forall var. Eq var => [TermT var] -> [TermT var]
nubTermT [TermT var]
topes -- (topes <> genTopes)
      topes'' :: [[TermT var]]
topes''   = [TermT var] -> [[TermT var]]
forall var. Eq var => [TermT var] -> [[TermT var]]
simplifyLHSwithDisjunctions [TermT var]
topes'
      topes''' :: [[TermT var]]
topes'''  = [TermT var] -> [TermT var] -> [TermT var]
forall var. Eq var => [TermT var] -> [TermT var] -> [TermT var]
saturateTopes (TermT var -> [TermT var]
forall var. Eq var => TermT var -> [TermT var]
allTopePoints TermT var
tope) ([TermT var] -> [TermT var]) -> [[TermT var]] -> [[TermT var]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[TermT var]]
topes''
  [String]
prettyTopes <- (TermT var
 -> ReaderT
      (Context var) (Except (TypeErrorInScopedContext var)) String)
-> [TermT var]
-> ReaderT
     (Context var) (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) (Except (TypeErrorInScopedContext var)) String
forall var. Eq var => TermT var -> TypeCheck var String
ppTermInContext ([TermT var] -> [TermT var] -> [TermT var]
forall var. Eq var => [TermT var] -> [TermT var] -> [TermT var]
saturateTopes (TermT var -> [TermT var]
forall var. Eq var => TermT var -> [TermT var]
allTopePoints TermT var
tope) ([TermT var] -> [TermT var]
forall var. Eq var => [TermT var] -> [TermT var]
simplifyLHS [TermT var]
topes'))
  String
prettyTope <- TermT var
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) String
forall var. Eq var => TermT var -> TypeCheck var String
ppTermInContext TermT var
tope
  Verbosity -> String -> TypeCheck var Bool -> TypeCheck var Bool
forall var a.
Verbosity -> String -> TypeCheck var a -> TypeCheck var a
traceTypeCheck Verbosity
Debug
    (String
"entail " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
prettyTopes String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" |- " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
prettyTope) (TypeCheck var Bool -> TypeCheck var Bool)
-> TypeCheck var Bool -> TypeCheck var Bool
forall a b. (a -> b) -> a -> b
$
      [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool)
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) [Bool]
-> TypeCheck var Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([TermT var] -> TypeCheck var Bool)
-> [[TermT var]]
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) [Bool]
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] -> TermT var -> TypeCheck var Bool
forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
`solveRHSM` TermT var
tope) [[TermT var]]
topes'''

entailTraceM :: Eq var => [TermT var] -> TermT var -> TypeCheck var Bool
entailTraceM :: forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
entailTraceM [TermT var]
topes TermT var
tope = do
  [String]
topes' <- (TermT var
 -> ReaderT
      (Context var) (Except (TypeErrorInScopedContext var)) String)
-> [TermT var]
-> ReaderT
     (Context var) (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) (Except (TypeErrorInScopedContext var)) String
forall var. Eq var => TermT var -> TypeCheck var String
ppTermInContext [TermT var]
topes
  String
tope' <- TermT var
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) String
forall var. Eq var => TermT var -> TypeCheck var String
ppTermInContext TermT var
tope
  Bool
result <- String -> TypeCheck var Bool -> TypeCheck var Bool
forall a. String -> a -> a
trace (String
"entail " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
topes' String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" |- " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
tope') (TypeCheck var Bool -> TypeCheck var Bool)
-> TypeCheck var Bool -> TypeCheck var Bool
forall a b. (a -> b) -> a -> b
$
        [TermT var]
topes [TermT var] -> TermT var -> TypeCheck var Bool
forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
`entailM` TermT var
tope
  Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> TypeCheck var Bool) -> Bool -> TypeCheck var Bool
forall a b. (a -> b) -> a -> b
$ String -> Bool -> Bool
forall a. String -> a -> a
trace (String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Bool -> String
forall a. Show a => a -> String
show Bool
result) Bool
result

nubTermT :: Eq var => [TermT var] -> [TermT var]
nubTermT :: forall var. Eq var => [TermT var] -> [TermT var]
nubTermT []     = []
nubTermT (TermT var
t:[TermT var]
ts) = TermT var
t TermT var -> [TermT var] -> [TermT var]
forall a. a -> [a] -> [a]
: [TermT var] -> [TermT var]
forall var. Eq var => [TermT var] -> [TermT var]
nubTermT ((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
t) [TermT var]
ts)

saturateTopes :: Eq var => [TermT var] -> [TermT var] -> [TermT var]
saturateTopes :: forall var. Eq var => [TermT var] -> [TermT var] -> [TermT var]
saturateTopes [TermT var]
_points [TermT var]
topes = (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
tope [TermT var]
ts -> 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]
ts)
  [TermT var] -> [TermT var] -> [TermT var]
forall var. Eq var => [TermT var] -> [TermT var] -> [TermT var]
generateTopes
  [TermT var]
topes

-- 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] -> 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 ]
      ]

generateTopesForPoints :: Eq var => [TermT var] -> [TermT var]
generateTopesForPoints :: forall var. Eq var => [TermT var] -> [TermT var]
generateTopesForPoints [TermT var]
points = [TermT var] -> [TermT var]
forall var. Eq var => [TermT var] -> [TermT var]
nubTermT ([TermT var] -> [TermT var]) -> [TermT var] -> [TermT var]
forall a b. (a -> b) -> a -> b
$ [[TermT var]] -> [TermT var]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [ 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
topeLEQT TermT var
x TermT var
y) (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
y TermT var
x)
    | 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]
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 ]
  ]

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]
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 ]
        ]
  [[TermT var]]
topes <- [(TermT var, TermT var)]
-> ((TermT var, TermT var) -> TypeCheck var [TermT var])
-> ReaderT
     (Context var) (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, TermT var)]
pairs (((TermT var, TermT var) -> TypeCheck var [TermT var])
 -> ReaderT
      (Context var)
      (Except (TypeErrorInScopedContext var))
      [[TermT var]])
-> ((TermT var, TermT var) -> TypeCheck var [TermT var])
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) [[TermT var]]
forall a b. (a -> b) -> a -> b
$ \(TermT var
x, TermT var
y) -> do
    TermT var
xType <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
x
    TermT var
yType <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
y
    [TermT var] -> TypeCheck var [TermT var]
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TermT var] -> TypeCheck var [TermT var])
-> [TermT var] -> TypeCheck var [TermT var]
forall a b. (a -> b) -> a -> b
$ if (TermT var
xType TermT var -> TermT var -> Bool
forall a. Eq a => a -> a -> Bool
== TermT var
forall var. TermT var
cube2T) Bool -> Bool -> Bool
&& (TermT var
yType TermT var -> TermT var -> Bool
forall a. Eq a => a -> a -> Bool
== TermT var
forall var. TermT var
cube2T)
      then [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
topeLEQT TermT var
x TermT var
y) (TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
y TermT var
x)]
      else []
  [TermT var] -> TypeCheck var [TermT var]
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([[TermT var]] -> [TermT var]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[TermT var]]
topes)

allTopePoints :: Eq var => TermT var -> [TermT var]
allTopePoints :: forall var. Eq var => TermT var -> [TermT var]
allTopePoints = [TermT var] -> [TermT var]
forall var. Eq var => [TermT var] -> [TermT var]
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 var. Eq var => [TermT var] -> [TermT var]
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 :: TermT var
infoWHNF :: Maybe (TermT var)
infoNF :: Maybe (TermT var)
infoNF :: forall term. TypeInfo term -> Maybe term
infoWHNF :: forall term. TypeInfo term -> Maybe term
infoType :: forall term. TypeInfo term -> term
..} TermF (Scope (FS (AnnF TypeInfo TermF)) var) (TermT var)
_))
    | Cube2T{} <- TermT var
infoType -> [TermT var
p]
  TermT var
_ -> []

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

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

    TopeEQT  TypeInfo (TermT var)
_ (PairT TypeInfo (TermT var)
_ TermT var
x TermT var
y) (PairT TypeInfo (TermT var)
_ TermT var
x' TermT var
y') : [TermT var]
topes' ->
      [TermT var] -> [[TermT var]]
forall var. Eq var => [TermT var] -> [[TermT var]]
simplifyLHSwithDisjunctions (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 a. a -> [a] -> [a]
: TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
y TermT var
y' TermT var -> [TermT var] -> [TermT var]
forall a. a -> [a] -> [a]
: [TermT var]
topes')
    TermT var
t : [TermT var]
topes' -> ([TermT var] -> [TermT var]) -> [[TermT var]] -> [[TermT var]]
forall a b. (a -> b) -> [a] -> [b]
map (TermT var
t TermT var -> [TermT var] -> [TermT var]
forall a. a -> [a] -> [a]
:) ([TermT var] -> [[TermT var]]
forall var. Eq var => [TermT var] -> [[TermT var]]
simplifyLHSwithDisjunctions [TermT var]
topes')

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

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

    TopeEQT  TypeInfo (TermT var)
_ (PairT TypeInfo (TermT var)
_ TermT var
x TermT var
y) (PairT TypeInfo (TermT var)
_ TermT var
x' TermT var
y') : [TermT var]
topes' ->
      [TermT var] -> [TermT var]
forall var. Eq var => [TermT var] -> [TermT var]
simplifyLHS (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 a. a -> [a] -> [a]
: TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
y TermT var
y' TermT var -> [TermT var] -> [TermT var]
forall a. a -> [a] -> [a]
: [TermT var]
topes')
    TermT var
t : [TermT var]
topes' -> TermT var
t TermT var -> [TermT var] -> [TermT var]
forall a. a -> [a] -> [a]
: [TermT var] -> [TermT var]
forall var. Eq var => [TermT var] -> [TermT var]
simplifyLHS [TermT var]
topes'

solveRHSM :: Eq var => [TermT var] -> TermT var -> TypeCheck var Bool
solveRHSM :: forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
solveRHSM [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 -> TypeCheck var Bool
forall a.
a
-> ReaderT (Context var) (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) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return 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 -> TypeCheck var Bool
forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
solveRHSM [TermT var]
topes (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 ->
      [TermT var] -> TermT var -> TypeCheck var Bool
forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
solveRHSM [TermT var]
topes (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) ->
      [TermT var] -> TermT var -> TypeCheck var Bool
forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
solveRHSM [TermT var]
topes (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
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
          ] -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    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) (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) (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) (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) (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)
     (Except (TypeErrorInScopedContext var))
     (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TermT var] -> TermT var -> TypeCheck var Bool
forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
solveRHSM [TermT var]
topes TermT var
l
      ReaderT
  (Context var)
  (Except (TypeErrorInScopedContext var))
  (Bool -> Bool)
-> TypeCheck var Bool -> TypeCheck var Bool
forall a b.
ReaderT
  (Context var) (Except (TypeErrorInScopedContext var)) (a -> b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [TermT var] -> TermT var -> TypeCheck var Bool
forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
solveRHSM [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 -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    TopeOrT  TypeInfo (TermT var)
_ TermT var
l TermT var
r -> do
      Bool
l' <- [TermT var] -> TermT var -> TypeCheck var Bool
forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
solveRHSM [TermT var]
topes TermT var
l
      Bool
r' <- [TermT var] -> TermT var -> TypeCheck var Bool
forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
solveRHSM [TermT var]
topes TermT var
r
      if (Bool
l' Bool -> Bool -> Bool
|| Bool
r')
        then Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        else do
          [TermT var]
lems <- [TermT var] -> TypeCheck var [TermT var]
forall var. Eq var => [TermT var] -> TypeCheck var [TermT var]
generateTopesForPointsM (TermT var -> [TermT var]
forall var. Eq var => TermT var -> [TermT var]
allTopePoints TermT var
tope)
          let lems' :: [TermT var]
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] ]
          case [TermT var]
lems' of
            TopeOrT TypeInfo (TermT var)
_ TermT var
t1 TermT var
t2 : [TermT var]
_ -> do
              Bool
l'' <- [TermT var] -> TermT var -> TypeCheck var Bool
forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
solveRHSM ([TermT var] -> [TermT var] -> [TermT var]
forall var. Eq var => [TermT var] -> [TermT var] -> [TermT var]
saturateTopes [] (TermT var
t1 TermT var -> [TermT var] -> [TermT var]
forall a. a -> [a] -> [a]
: [TermT var]
topes)) TermT var
tope
              Bool
r'' <- [TermT var] -> TermT var -> TypeCheck var Bool
forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
solveRHSM ([TermT var] -> [TermT var] -> [TermT var]
forall var. Eq var => [TermT var] -> [TermT var] -> [TermT var]
saturateTopes [] (TermT var
t2 TermT var -> [TermT var] -> [TermT var]
forall a. a -> [a] -> [a]
: [TermT var]
topes)) TermT var
tope
              Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
l'' Bool -> Bool -> Bool
&& Bool
r'')
            [TermT var]
_ -> Bool -> TypeCheck var Bool
forall a.
a
-> ReaderT (Context var) (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) (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
  [TermT var]
ctxTopes <- (Context var -> [TermT var])
-> ReaderT
     (Context var) (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]
localTopes
  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
ActionContextEntails [TermT var]
ctxTopes TermT var
tope) (TypeCheck var Bool -> TypeCheck var Bool)
-> TypeCheck var Bool -> TypeCheck var Bool
forall a b. (a -> b) -> a -> b
$ do
    [TermT var]
topes' <- (Context var -> [TermT var])
-> ReaderT
     (Context var) (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]
localTopesNF
    TermT var
tope' <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
tope
    [TermT var]
topes' [TermT var] -> TermT var -> TypeCheck var Bool
forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
`entailM` TermT var
tope'

checkTopeEntails :: Eq var => TermT var -> TypeCheck var Bool
checkTopeEntails :: forall var. Eq var => TermT var -> TypeCheck var Bool
checkTopeEntails TermT var
tope = do
  [TermT var]
ctxTopes <- (Context var -> [TermT var])
-> ReaderT
     (Context var) (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]
localTopes
  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
ActionContextEntailedBy [TermT var]
ctxTopes TermT var
tope) (TypeCheck var Bool -> TypeCheck var Bool)
-> TypeCheck var Bool -> TypeCheck var Bool
forall a b. (a -> b) -> a -> b
$ do
    [TermT var]
contextTopes <- (Context var -> [TermT var])
-> ReaderT
     (Context var) (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]
localTopesNF
    TermT var
restrictionTope <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
tope
    let contextTopesRHS :: TermT var
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
    [TermT var
restrictionTope] [TermT var] -> TermT var -> TypeCheck var Bool
forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
`entailM` TermT var
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
  TermT var
l' <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope 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
r
  [TermT var
l'] [TermT var] -> TermT var -> TypeCheck var Bool
forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
`entailM` TermT var
r'

contextEntailedBy :: Eq var => TermT var -> TypeCheck var ()
contextEntailedBy :: forall var. Eq var => TermT var -> TypeCheck var ()
contextEntailedBy TermT var
tope = do
  [TermT var]
ctxTopes <- (Context var -> [TermT var])
-> ReaderT
     (Context var) (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]
localTopes
  Action var -> TypeCheck var () -> TypeCheck var ()
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
ActionContextEntailedBy [TermT var]
ctxTopes TermT var
tope) (TypeCheck var () -> TypeCheck var ())
-> TypeCheck var () -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$ do
    [TermT var]
contextTopes <- (Context var -> [TermT var])
-> ReaderT
     (Context var) (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]
localTopesNF
    TermT var
restrictionTope <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
tope
    let contextTopesRHS :: TermT var
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
topeOrT TermT var
forall var. TermT var
topeBottomT [TermT var]
contextTopes
    [TermT var
restrictionTope] [TermT var] -> TermT var -> TypeCheck var Bool
forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
`entailM` TermT var
contextTopesRHS TypeCheck var Bool
-> (Bool -> TypeCheck var ()) -> TypeCheck var ()
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
False -> 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 [TermT var
restrictionTope] TermT var
contextTopesRHS
      Bool
True -> () -> TypeCheck var ()
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

contextEntails :: Eq var => TermT var -> TypeCheck var ()
contextEntails :: forall var. Eq var => TermT var -> TypeCheck var ()
contextEntails TermT var
tope = do
  [TermT var]
ctxTopes <- (Context var -> [TermT var])
-> ReaderT
     (Context var) (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]
localTopes
  Action var -> TypeCheck var () -> TypeCheck var ()
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
ActionContextEntails [TermT var]
ctxTopes TermT var
tope) (TypeCheck var () -> TypeCheck var ())
-> TypeCheck var () -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$ do
    Bool
topeIsEntailed <- TermT var -> TypeCheck var Bool
forall var. Eq var => TermT var -> TypeCheck var Bool
checkTope TermT var
tope
    [TermT var]
topes' <- (Context var -> [TermT var])
-> ReaderT
     (Context var) (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]
localTopesNF
    Bool -> TypeCheck var () -> TypeCheck var ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
topeIsEntailed (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
$ [TermT var] -> TermT var -> TypeError var
forall var. [TermT var] -> TermT var -> TypeError var
TypeErrorTopeNotSatisfied [TermT var]
topes' TermT var
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
  TermT var
expected' <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
expected
  TermT var
actual' <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
actual
  Bool -> Bool -> Bool
(&&)
    (Bool -> Bool -> Bool)
-> TypeCheck var Bool
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TermT var
expected'] [TermT var] -> TermT var -> TypeCheck var Bool
forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
`entailM` TermT var
actual'
    ReaderT
  (Context var)
  (Except (TypeErrorInScopedContext var))
  (Bool -> Bool)
-> TypeCheck var Bool -> TypeCheck var Bool
forall a b.
ReaderT
  (Context var) (Except (TypeErrorInScopedContext var)) (a -> b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [TermT var
actual'] [TermT var] -> TermT var -> TypeCheck var Bool
forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
`entailM` TermT var
expected'

contextEquiv :: Eq var => [TermT var] -> TypeCheck var ()
contextEquiv :: forall var. Eq var => [TermT var] -> TypeCheck var ()
contextEquiv [TermT var]
topes = do
  [TermT var]
ctxTopes <- (Context var -> [TermT var])
-> ReaderT
     (Context var) (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]
localTopes
  Action var -> TypeCheck var () -> TypeCheck var ()
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
ActionContextEquiv [TermT var]
ctxTopes [TermT var]
topes) (TypeCheck var () -> TypeCheck var ())
-> TypeCheck var () -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$ do
    [TermT var]
contextTopes <- (Context var -> [TermT var])
-> ReaderT
     (Context var) (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]
localTopesNF
    [TermT var]
recTopes <- (TermT var
 -> ReaderT
      (Context var) (Except (TypeErrorInScopedContext var)) (TermT var))
-> [TermT var]
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) [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
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope [TermT var]
topes
    let contextTopesRHS :: TermT var
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
topeOrT TermT var
forall var. TermT var
topeBottomT [TermT var]
contextTopes
        recTopesRHS :: TermT var
recTopesRHS     = (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]
recTopes
    [TermT var]
contextTopes [TermT var] -> TermT var -> TypeCheck var Bool
forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
`entailM` TermT var
recTopesRHS TypeCheck var Bool
-> (Bool -> TypeCheck var ()) -> TypeCheck var ()
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
False -> 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 [TermT var]
contextTopes TermT var
recTopesRHS
      Bool
True -> () -> TypeCheck var ()
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [TermT var]
recTopes [TermT var] -> TermT var -> TypeCheck var Bool
forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
`entailM` TermT var
contextTopesRHS TypeCheck var Bool
-> (Bool -> TypeCheck var ()) -> TypeCheck var ()
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
False -> 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 [TermT var]
recTopes TermT var
contextTopesRHS
      Bool
True -> () -> TypeCheck var ()
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
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) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall a.
(Context var -> Context var)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (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) (Except (TypeErrorInScopedContext var)) a
 -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a)
-> (Context var -> Context var)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall a b. (a -> b) -> a -> b
$ \Context{Bool
[[TermT var]]
[TermT var]
[ScopeInfo var]
[Action var]
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: forall var. Context var -> Maybe LocationInfo
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 -> Bool
localTopesNFUnion :: forall var. Context var -> [[TermT var]]
localTopesNF :: forall var. Context var -> [TermT var]
localTopes :: forall var. Context var -> [TermT var]
localScopes :: forall var. Context var -> [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopes :: [TermT var]
localTopesNF :: [TermT var]
localTopesNFUnion :: [[TermT var]]
localTopesEntailBottom :: Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
..} -> Context
  { covariance :: Covariance
covariance = Covariance -> Covariance
switch Covariance
covariance, Bool
[[TermT var]]
[TermT var]
[ScopeInfo var]
[Action var]
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Verbosity
location :: Maybe LocationInfo
renderBackend :: Maybe RenderBackend
verbosity :: Verbosity
currentCommand :: Maybe Command
actionStack :: [Action var]
localTopesEntailBottom :: Bool
localTopesNFUnion :: [[TermT var]]
localTopesNF :: [TermT var]
localTopes :: [TermT var]
localScopes :: [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopes :: [TermT var]
localTopesNF :: [TermT var]
localTopesNFUnion :: [[TermT var]]
localTopesEntailBottom :: Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
renderBackend :: Maybe RenderBackend
.. }
    where
      switch :: Covariance -> Covariance
switch Covariance
Covariant     = Covariance
Contravariant
      switch Covariance
Contravariant = Covariance
Covariant

enterScopeContext :: Maybe VarIdent -> TermT var -> Context var -> Context (Inc var)
enterScopeContext :: forall var.
Maybe VarIdent -> TermT var -> Context var -> Context (Inc var)
enterScopeContext Maybe VarIdent
orig TermT var
ty 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  = Maybe (TermT (Inc var))
forall a. Maybe a
Nothing
    , varOrig :: Maybe VarIdent
varOrig   = Maybe VarIdent
orig
    , varIsAssumption :: Bool
varIsAssumption = 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)

enterScope :: Maybe VarIdent -> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope :: forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig TermT var
ty TypeCheck (Inc var) b
action = do
  Context (Inc var)
newContext <- (Context var -> Context (Inc var))
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (Context (Inc var))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Maybe VarIdent -> TermT var -> Context var -> Context (Inc var)
forall var.
Maybe VarIdent -> TermT var -> Context var -> Context (Inc var)
enterScopeContext Maybe VarIdent
orig TermT var
ty)
  Except (TypeErrorInScopedContext var) b -> TypeCheck var b
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 (Except (TypeErrorInScopedContext var) b -> TypeCheck var b)
-> Except (TypeErrorInScopedContext var) b -> TypeCheck var b
forall a b. (a -> b) -> a -> b
$ (TypeErrorInScopedContext (Inc var)
 -> TypeErrorInScopedContext var)
-> ExceptT (TypeErrorInScopedContext (Inc var)) Identity b
-> Except (TypeErrorInScopedContext var) b
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 Maybe VarIdent
orig) (ExceptT (TypeErrorInScopedContext (Inc var)) Identity b
 -> Except (TypeErrorInScopedContext var) b)
-> ExceptT (TypeErrorInScopedContext (Inc var)) Identity b
-> Except (TypeErrorInScopedContext var) b
forall a b. (a -> b) -> a -> b
$
    TypeCheck (Inc var) b
-> Context (Inc var)
-> ExceptT (TypeErrorInScopedContext (Inc var)) Identity b
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT TypeCheck (Inc var) b
action Context (Inc var)
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 var
ctx@Context{Bool
[[TermT var]]
[TermT var]
[ScopeInfo var]
[Action var]
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: forall var. Context var -> Maybe LocationInfo
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 -> Bool
localTopesNFUnion :: forall var. Context var -> [[TermT var]]
localTopesNF :: forall var. Context var -> [TermT var]
localTopes :: forall var. Context var -> [TermT var]
localScopes :: forall var. Context var -> [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopes :: [TermT var]
localTopesNF :: [TermT var]
localTopesNFUnion :: [[TermT var]]
localTopesEntailBottom :: Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
..} <- ReaderT
  (Context var) (Except (TypeErrorInScopedContext var)) (Context var)
forall r (m :: * -> *). MonadReader r m => m r
ask
  Bool
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) ()
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Action var] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Action var]
actionStack Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1000) (ReaderT (Context var) (Except (TypeErrorInScopedContext var)) ()
 -> ReaderT
      (Context var) (Except (TypeErrorInScopedContext var)) ())
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) ()
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) ()
forall a b. (a -> b) -> a -> b
$  -- FIXME: which depth is reasonable? factor out into a parameter
    TypeError var
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) ()
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var
 -> ReaderT
      (Context var) (Except (TypeErrorInScopedContext var)) ())
-> TypeError var
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) ()
forall a b. (a -> b) -> a -> b
$ String -> TypeError var
forall var. String -> TypeError var
TypeErrorOther String
"maximum depth reached"
  Verbosity -> String -> TypeCheck var a -> TypeCheck var a
forall var a.
Verbosity -> String -> TypeCheck var a -> TypeCheck var a
traceTypeCheck Verbosity
Debug ([(var, Maybe VarIdent)] -> Int -> Action var -> String
forall var.
Eq var =>
[(var, Maybe VarIdent)] -> Int -> Action var -> String
ppSomeAction (Context var -> [(var, Maybe VarIdent)]
forall var. Context var -> [(var, Maybe VarIdent)]
varOrigs Context var
ctx) ([Action var] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Action var]
actionStack) Action var
action) (TypeCheck var a -> TypeCheck var a)
-> TypeCheck var a -> TypeCheck var a
forall a b. (a -> b) -> a -> b
$
    (Context var -> Context var) -> TypeCheck var a -> TypeCheck var a
forall a.
(Context var -> Context var)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (Context var -> Context var -> Context var
forall a b. a -> b -> a
const Context { actionStack :: [Action var]
actionStack = Action var
action Action var -> [Action var] -> [Action var]
forall a. a -> [a] -> [a]
: [Action var]
actionStack, Bool
[[TermT var]]
[TermT var]
[ScopeInfo var]
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: Maybe LocationInfo
renderBackend :: Maybe RenderBackend
covariance :: Covariance
verbosity :: Verbosity
currentCommand :: Maybe Command
localTopesEntailBottom :: Bool
localTopesNFUnion :: [[TermT var]]
localTopesNF :: [TermT var]
localTopes :: [TermT var]
localScopes :: [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopes :: [TermT var]
localTopesNF :: [TermT var]
localTopesNFUnion :: [[TermT var]]
localTopesEntailBottom :: Bool
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
.. }) (TypeCheck var a -> TypeCheck var a)
-> TypeCheck var a -> TypeCheck var a
forall a b. (a -> b) -> a -> b
$ TypeCheck var a
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)
     (Except (TypeErrorInScopedContext var))
     (TermT var, TermT var)
forall a.
a
-> ReaderT (Context var) (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)
     (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)
     (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)])
-- ------------------------------------
etaMatch Maybe (TermT var)
_mterm expected :: TermT var
expected@LambdaT{} actual :: TermT var
actual@LambdaT{} = (TermT var, TermT var)
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (TermT var, TermT var)
forall a.
a
-> ReaderT (Context var) (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)
     (Except (TypeErrorInScopedContext var))
     (TermT var, TermT var)
forall a.
a
-> ReaderT (Context var) (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
  TermT var
actual' <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
etaExpand TermT var
actual
  (TermT var, TermT var)
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (TermT var, TermT var)
forall a.
a
-> ReaderT (Context var) (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 actual :: TermT var
actual@LambdaT{} = do
  TermT var
expected' <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
etaExpand TermT var
expected
  (TermT var, TermT var)
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (TermT var, TermT var)
forall a.
a
-> ReaderT (Context var) (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{} TermT var
actual = do
  TermT var
actual' <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
etaExpand TermT var
actual
  (TermT var, TermT var)
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (TermT var, TermT var)
forall a.
a
-> ReaderT (Context var) (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 actual :: TermT var
actual@PairT{} = do
  TermT var
expected' <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
etaExpand TermT var
expected
  (TermT var, TermT var)
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (TermT var, TermT var)
forall a.
a
-> ReaderT (Context var) (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 TermT var
actual = (TermT var, TermT var)
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (TermT var, TermT var)
forall a.
a
-> ReaderT (Context var) (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) (Except (TypeErrorInScopedContext var)) (TermT var)
forall a.
a
-> ReaderT (Context var) (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) (Except (TypeErrorInScopedContext var)) (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
term
etaExpand TermT var
term = do
  TermT var
ty <- TermT var
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
term
  case TermT var -> TermT var
forall var. TermT var -> TermT var
stripTypeRestrictions TermT var
ty of
    TypeFunT TypeInfo (TermT var)
_ty Maybe VarIdent
orig TermT var
param Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope Scope (FS (AnnF TypeInfo TermF)) var
ret -> TermT var
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT var
 -> ReaderT
      (Context var) (Except (TypeErrorInScopedContext var)) (TermT var))
-> TermT var
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) (TermT var)
forall a b. (a -> b) -> a -> b
$
      TermT var
-> Maybe VarIdent
-> Maybe (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall var.
TermT var
-> Maybe VarIdent
-> Maybe (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
lambdaT TermT var
ty Maybe VarIdent
orig ((TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> Maybe (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
forall a. a -> Maybe a
Just (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 Maybe VarIdent
_orig TermT var
a Scope (FS (AnnF TypeInfo TermF)) var
b -> TermT var
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT var
 -> ReaderT
      (Context var) (Except (TypeErrorInScopedContext var)) (TermT var))
-> TermT var
-> ReaderT
     (Context var) (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) (Except (TypeErrorInScopedContext var)) (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT var
 -> ReaderT
      (Context var) (Except (TypeErrorInScopedContext var)) (TermT var))
-> TermT var
-> ReaderT
     (Context var) (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) (Except (TypeErrorInScopedContext var)) (TermT var)
forall a.
a
-> ReaderT (Context var) (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) (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) (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) (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) (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) (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) (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) (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) (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) (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) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (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) (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) (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) (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) (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) (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) (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) (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) (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) (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) (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) (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) (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) (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) (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) (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) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

  TypeFunT TypeInfo (TermT var)
_ty Maybe VarIdent
orig TermT var
param Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
_mtope Scope (FS (AnnF TypeInfo TermF)) var
ret -> do
    Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) Bool -> TypeCheck var Bool
forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig 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) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (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) (Except (TypeErrorInScopedContext var)) (Maybe a)
go [] = Maybe a
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) (Maybe a)
forall a.
a
-> ReaderT (Context var) (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) (Except (TypeErrorInScopedContext var)) (Maybe a))
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) (Maybe a)
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (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) (Except (TypeErrorInScopedContext var)) (Maybe a)
forall a.
a
-> ReaderT (Context var) (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) (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) (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) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TermT var)
forall a. Maybe a
Nothing

-- | 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 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
ActionWHNF 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
$ case TermT var
tt of
  -- use cached result if it exists
  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
infoWHNF TypeInfo (TermT var)
info -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (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) (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) (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) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt

  -- cube layer (except vars, pairs, and applications)
  CubeProductT{} -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
tt
  CubeUnitT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (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) (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) (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) (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) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt

  -- tope layer (except vars, pairs of points, and applications)
  TopeTopT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (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) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  TopeAndT{} -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
tt
  TopeOrT{} -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
tt
  TopeEQT{} -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
tt
  TopeLEQT{} -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
tt

  -- type layer terms that should not be evaluated further
  LambdaT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  PairT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  ReflT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  TypeFunT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  TypeSigmaT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  TypeIdT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  RecBottomT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  TypeUnitT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (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) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt

  -- 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)
whnfT TermT var
term

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

    -- CubeUnitT{} -> pure cubeUnitStarT -- compute an expression of 1 cube to its only point
    TypeUnitT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT 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 (TermT var)
_info TypeUnitT{} [(TermT var, TermT var)]
_rs -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT 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)
    TermT var
typeOf_tt -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
typeOf_tt TypeCheck var (TermT var)
-> (TermT var -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      UniverseCubeT{} -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
tt

      -- now we are in the type layer
      TermT var
_ -> (TermT var -> TermT var)
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b.
(a -> b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (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
termIsWHNF (TypeCheck var (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b. (a -> b) -> a -> b
$ do
        -- check if we are in the empty context
        Bool
inBottom <- (Context var -> Bool)
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context var -> Bool
forall var. Context var -> Bool
localTopesEntailBottom
        if Bool
inBottom
           then TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
forall var. TermT var
recBottomT -- if so, reduce to recBOT
           else TermT var -> TypeCheck var (Maybe (TermT var))
forall var.
Eq var =>
TermT var -> TypeCheck var (Maybe (TermT var))
tryRestriction TermT var
typeOf_tt TypeCheck var (Maybe (TermT var))
-> (Maybe (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just TermT var
tt' -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
tt'
            Maybe (TermT var)
Nothing -> case TermT var
tt of
              t :: TermT var
t@(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) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (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) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
t
                  Just TermT var
term -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
term

              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)
whnfT TermT var
f TypeCheck var (TermT var)
-> (TermT var -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  LambdaT TypeInfo (TermT var)
_ty Maybe VarIdent
_orig Maybe (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)
whnfT (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)
typeOf TermT var
f' TypeCheck var (TermT var)
-> (TermT var -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    TypeFunT TypeInfo (TermT var)
_ty Maybe VarIdent
_orig TermT var
_param (Just Scope (FS (AnnF TypeInfo TermF)) var
tope) UniverseTopeT{} -> do
                      TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeAndT
                        (TermT var -> TermT var -> TermT var)
-> TypeCheck var (TermT var)
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (TermT var -> TermT var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (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 -> TermT var -> TermT var)
-> TypeCheck var (TermT var)
-> ReaderT
     (Context var)
     (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)
nfT TermT var
f' ReaderT
  (Context var)
  (Except (TypeErrorInScopedContext var))
  (TermT var -> TermT var)
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var) (Except (TypeErrorInScopedContext var)) (a -> b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (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)
nfT TermT var
x)
                        ReaderT
  (Context var)
  (Except (TypeErrorInScopedContext var))
  (TermT var -> TermT var)
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var) (Except (TypeErrorInScopedContext var)) (a -> b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (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)
nfT (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)
                    -- 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 (TermT var)
info Maybe VarIdent
_orig TermT var
_param Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
_mtope ret :: Scope (FS (AnnF TypeInfo TermF)) var
ret@TypeRestrictedT{}
                      | TypeRestrictedT{} <- TypeInfo (TermT var) -> TermT var
forall term. TypeInfo term -> term
infoType TypeInfo (TermT var)
info -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (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
AppT TypeInfo (TermT var)
ty TermT var
f' TermT var
x)
                      | Bool
otherwise -> do
                          let ret' :: TermT var
ret' = 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
ret
                          TermT var -> TypeCheck var (Maybe (TermT var))
forall var.
Eq var =>
TermT var -> TypeCheck var (Maybe (TermT var))
tryRestriction TermT var
ret' TypeCheck var (Maybe (TermT var))
-> (Maybe (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case -- FIXME: to many unnecessary checks?
                            Maybe (TermT var)
Nothing  -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (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
AppT TypeInfo (TermT var)
ty { infoType = ret' } TermT var
f' TermT var
x)
                            Just TermT var
tt' -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
tt'
                    TermT var
_ -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (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
AppT TypeInfo (TermT var)
ty TermT var
f' 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)
whnfT TermT var
t TypeCheck var (TermT var)
-> (TermT var -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  PairT TypeInfo (TermT var)
_ TermT var
l TermT var
_r -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
l
                  TermT var
t'           -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (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)
whnfT TermT var
t TypeCheck var (TermT var)
-> (TermT var -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  PairT TypeInfo (TermT var)
_ TermT var
_l TermT var
r -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
r
                  TermT var
t'           -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (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')
              IdJT TypeInfo (TermT var)
ty TermT var
tA TermT var
a TermT var
tC TermT var
d TermT var
x TermT var
p ->
                TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
p TypeCheck var (TermT var)
-> (TermT var -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  ReflT{} -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
d
                  TermT var
p'      -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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)
ty TermT var
tA TermT var
a TermT var
tC TermT var
d TermT var
x TermT var
p')

              RecOrT TypeInfo (TermT var)
_ty [(TermT var, TermT var)]
rs -> do
                let go :: [(TermT var, a)]
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) (Maybe a)
go [] = Maybe a
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) (Maybe a)
forall a.
a
-> ReaderT (Context var) (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) (Except (TypeErrorInScopedContext var)) (Maybe a))
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) (Maybe a)
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (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) (Except (TypeErrorInScopedContext var)) (Maybe a)
forall a.
a
-> ReaderT (Context var) (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) (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) (Except (TypeErrorInScopedContext var)) (Maybe a)
go [(TermT var, TermT var)]
rs TypeCheck var (Maybe (TermT var))
-> (Maybe (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  Just TermT var
tt' -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
tt'
                  Maybe (TermT var)
Nothing
                    | [TermT var
tt'] <- [TermT var] -> [TermT var]
forall var. Eq var => [TermT var] -> [TermT var]
nubTermT (((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) -> b
snd [(TermT var, TermT var)]
rs) -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
tt'
                    | Bool
otherwise -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt

              TypeRestrictedT TypeInfo (TermT var)
ty TermT var
type_ [(TermT var, TermT var)]
rs -> do
                [(TermT var, TermT var)]
rs' <- ((TermT var, TermT var)
 -> ReaderT
      (Context var)
      (Except (TypeErrorInScopedContext var))
      (TermT var, TermT var))
-> [(TermT var, TermT var)]
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     [(TermT var, TermT 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 (\(TermT var
tope, TermT var
term) -> (,) (TermT var -> TermT var -> (TermT var, TermT var))
-> TypeCheck var (TermT var)
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (TermT 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)
nfT TermT var
tope ReaderT
  (Context var)
  (Except (TypeErrorInScopedContext var))
  (TermT var -> (TermT var, TermT var))
-> TypeCheck var (TermT var)
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (TermT var, TermT var)
forall a b.
ReaderT
  (Context var) (Except (TypeErrorInScopedContext var)) (a -> b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
term) [(TermT var, TermT var)]
rs
                case ((TermT var, TermT var) -> Bool)
-> [(TermT var, TermT var)] -> [(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
topeBottomT) (TermT var -> Bool)
-> ((TermT var, TermT var) -> TermT var)
-> (TermT var, TermT var)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TermT var, TermT var) -> TermT var
forall a b. (a, b) -> a
fst) [(TermT var, TermT var)]
rs' of
                  []   -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
type_  -- get rid of restrictions at BOT
                  [(TermT var, TermT var)]
rs'' -> 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)
ty (TermT var -> [(TermT var, TermT var)] -> TermT var)
-> TypeCheck var (TermT var)
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     ([(TermT 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)
whnfT TermT var
type_ ReaderT
  (Context var)
  (Except (TypeErrorInScopedContext var))
  ([(TermT var, TermT var)] -> TermT var)
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     [(TermT var, TermT var)]
-> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var) (Except (TypeErrorInScopedContext var)) (a -> b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [(TermT var, TermT var)]
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     [(TermT var, TermT var)]
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(TermT var, TermT 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) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (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
  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) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (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) (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) (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) (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) (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) (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) (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) (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) (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) (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) (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) (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) (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)
     (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)
  (Except (TypeErrorInScopedContext var))
  (TermT var -> TermT var)
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var) (Except (TypeErrorInScopedContext var)) (a -> b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (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

  -- tope layer constants
  TopeTopT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (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) (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) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (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) (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) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (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) (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) (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
    TermT var
l' <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope 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
r
    case (TermT var
l', TermT var
r') of
      (TopeBottomT{}, TermT var
_) -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (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) (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) (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)
     (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)
  (Except (TypeErrorInScopedContext var))
  (TermT var -> TermT var)
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var) (Except (TypeErrorInScopedContext var)) (a -> b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (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)
     (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)
  (Except (TypeErrorInScopedContext var))
  (TermT var -> TermT var)
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var) (Except (TypeErrorInScopedContext var)) (a -> b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (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

  -- 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)
     (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)
  (Except (TypeErrorInScopedContext var))
  (TermT var -> TermT var)
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var) (Except (TypeErrorInScopedContext var)) (a -> b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (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) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      LambdaT TypeInfo (TermT var)
_ty Maybe VarIdent
_orig Maybe (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) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        TypeFunT TypeInfo (TermT var)
_ty Maybe VarIdent
_orig TermT var
_param (Just Scope (FS (AnnF TypeInfo TermF)) var
tope) UniverseTopeT{} -> do
          TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeAndT
            (TermT var -> TermT var -> TermT var)
-> TypeCheck var (TermT var)
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (TermT var -> TermT var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (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)
            ReaderT
  (Context var)
  (Except (TypeErrorInScopedContext var))
  (TermT var -> TermT var)
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var) (Except (TypeErrorInScopedContext var)) (a -> b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (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 -> 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
_ -> 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) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (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) (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) (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) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (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) (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) (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 Maybe VarIdent
orig Maybe (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
_mparam Scope (FS (AnnF TypeInfo TermF)) var
body
    | TypeFunT TypeInfo (TermT var)
_ty Maybe VarIdent
_origF 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 ->
        TypeInfo (TermT var)
-> Maybe VarIdent
-> Maybe (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)
-> Maybe VarIdent
-> Maybe
     (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 Maybe VarIdent
orig ((TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> Maybe (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
forall a. a -> Maybe a
Just (TermT var
param, Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope)) (Scope (FS (AnnF TypeInfo TermF)) var -> TermT var)
-> ReaderT
     (Context var)
     (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
<$> Maybe VarIdent
-> TermT var
-> TypeCheck (Inc var) (Scope (FS (AnnF TypeInfo TermF)) var)
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (Scope (FS (AnnF TypeInfo TermF)) var)
forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig 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"

  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"

  RecOrT{} -> String -> TypeCheck var (TermT var)
forall a. String -> a
panicImpossible String
"recOR in the tope layer"
  RecBottomT{} -> String -> TypeCheck var (TermT var)
forall a. String -> a
panicImpossible String
"recBOT 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 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
$ case TermT var
tt of
  -- universe constants
  UniverseT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (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) (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) (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) (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) (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) (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) (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) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt

  -- cube layer with computation
  CubeProductT{} -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
tt

  -- tope layer constants
  TopeTopT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (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) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt

  -- tope layer with computation
  TopeAndT{} -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
tt
  TopeOrT{} -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
tt
  TopeEQT{} -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
tt
  TopeLEQT{} -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
tt

  -- type layer constants
  ReflT TypeInfo (TermT var)
ty Maybe (TermT var, Maybe (TermT var))
_x -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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)
ty Maybe (TermT var, Maybe (TermT var))
forall a. Maybe a
Nothing)
  RecBottomT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  TypeUnitT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (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) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt

  -- 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)
nfT TermT var
term

  -- now we are in the type layer
  TermT var
_ -> do
    -- check if we are in the empty context
    Bool
inBottom <- (Context var -> Bool)
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context var -> Bool
forall var. Context var -> Bool
localTopesEntailBottom
    if Bool
inBottom
       then TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
forall var. TermT var
recBottomT -- if so, reduce to recBOT
       else TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
tt TypeCheck var (TermT var)
-> (TermT var
    -> ReaderT
         (Context var)
         (Except (TypeErrorInScopedContext var))
         (Maybe (TermT var)))
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (Maybe (TermT var))
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TermT var
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (Maybe (TermT var))
forall var.
Eq var =>
TermT var -> TypeCheck var (Maybe (TermT var))
tryRestriction ReaderT
  (Context var)
  (Except (TypeErrorInScopedContext var))
  (Maybe (TermT var))
-> (Maybe (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just TermT var
tt' -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
tt'
        Maybe (TermT var)
Nothing -> case TermT var
tt of
          t :: TermT var
t@(Pure var
var) ->
            var
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (Maybe (TermT var))
forall var. Eq var => var -> TypeCheck var (Maybe (TermT var))
valueOfVar var
var ReaderT
  (Context var)
  (Except (TypeErrorInScopedContext var))
  (Maybe (TermT var))
-> (Maybe (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (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) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
t
              Just TermT var
term -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
term

          TypeFunT TypeInfo (TermT var)
ty Maybe VarIdent
orig TermT var
param Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope Scope (FS (AnnF TypeInfo TermF)) var
ret -> do
            TermT var
param' <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
param
            Maybe VarIdent
-> TermT var
-> TypeCheck (Inc var) (TermT var)
-> TypeCheck var (TermT var)
forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig 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
              Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope' <- (Scope (FS (AnnF TypeInfo TermF)) var
 -> ReaderT
      (Context (Inc var))
      (Except (TypeErrorInScopedContext (Inc var)))
      (Scope (FS (AnnF TypeInfo TermF)) var))
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> ReaderT
     (Context (Inc var))
     (Except (TypeErrorInScopedContext (Inc var)))
     (Maybe (Scope (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) -> Maybe a -> f (Maybe b)
traverse Scope (FS (AnnF TypeInfo TermF)) var
-> ReaderT
     (Context (Inc var))
     (Except (TypeErrorInScopedContext (Inc var)))
     (Scope (FS (AnnF TypeInfo TermF)) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope
              (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
$
                TypeInfo (TermT var)
-> Maybe VarIdent
-> 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)
-> Maybe VarIdent
-> 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)
ty Maybe VarIdent
orig TermT var
param' Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope' (Scope (FS (AnnF TypeInfo TermF)) var -> TermT var)
-> ReaderT
     (Context (Inc var))
     (Except (TypeErrorInScopedContext (Inc var)))
     (Scope (FS (AnnF TypeInfo TermF)) var)
-> TypeCheck (Inc var) (TermT var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scope (FS (AnnF TypeInfo TermF)) var
-> ReaderT
     (Context (Inc var))
     (Except (TypeErrorInScopedContext (Inc var)))
     (Scope (FS (AnnF TypeInfo TermF)) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT Scope (FS (AnnF TypeInfo TermF)) var
ret
          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)
whnfT TermT var
f TypeCheck var (TermT var)
-> (TermT var -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              LambdaT TypeInfo (TermT var)
_ty Maybe VarIdent
_orig Maybe (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)
nfT (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)
typeOf TermT var
f' TypeCheck var (TermT var)
-> (TermT var -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                TypeFunT TypeInfo (TermT var)
_ty Maybe VarIdent
_orig TermT var
_param (Just Scope (FS (AnnF TypeInfo TermF)) var
tope) UniverseTopeT{} -> do
                  TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var
topeAndT
                    (TermT var -> TermT var -> TermT var)
-> TypeCheck var (TermT var)
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (TermT var -> TermT var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (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 -> TermT var -> TermT var)
-> TypeCheck var (TermT var)
-> ReaderT
     (Context var)
     (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)
nfT TermT var
f' ReaderT
  (Context var)
  (Except (TypeErrorInScopedContext var))
  (TermT var -> TermT var)
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var) (Except (TypeErrorInScopedContext var)) (a -> b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (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)
nfT TermT var
x)
                    ReaderT
  (Context var)
  (Except (TypeErrorInScopedContext var))
  (TermT var -> TermT var)
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var) (Except (TypeErrorInScopedContext var)) (a -> b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (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)
nfT (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
_ -> 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 -> TermT var -> TermT var)
-> TypeCheck var (TermT var)
-> ReaderT
     (Context var)
     (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)
nfT TermT var
f' ReaderT
  (Context var)
  (Except (TypeErrorInScopedContext var))
  (TermT var -> TermT var)
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var) (Except (TypeErrorInScopedContext var)) (a -> b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (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)
nfT TermT var
x
          LambdaT TypeInfo (TermT var)
ty Maybe VarIdent
orig Maybe (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
_mparam Scope (FS (AnnF TypeInfo TermF)) var
body -> do
            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 Maybe VarIdent
_orig TermT var
param Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope Scope (FS (AnnF TypeInfo TermF)) var
_ret -> do
                TermT var
param' <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
param
                Maybe VarIdent
-> TermT var
-> TypeCheck (Inc var) (TermT var)
-> TypeCheck var (TermT var)
forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig 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
                  Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope' <- (Scope (FS (AnnF TypeInfo TermF)) var
 -> ReaderT
      (Context (Inc var))
      (Except (TypeErrorInScopedContext (Inc var)))
      (Scope (FS (AnnF TypeInfo TermF)) var))
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> ReaderT
     (Context (Inc var))
     (Except (TypeErrorInScopedContext (Inc var)))
     (Maybe (Scope (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) -> Maybe a -> f (Maybe b)
traverse Scope (FS (AnnF TypeInfo TermF)) var
-> ReaderT
     (Context (Inc var))
     (Except (TypeErrorInScopedContext (Inc var)))
     (Scope (FS (AnnF TypeInfo TermF)) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope
                  (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
$
                    TypeInfo (TermT var)
-> Maybe VarIdent
-> Maybe (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)
-> Maybe VarIdent
-> Maybe
     (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 Maybe VarIdent
orig ((TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> Maybe (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
forall a. a -> Maybe a
Just (TermT var
param', Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope')) (Scope (FS (AnnF TypeInfo TermF)) var -> TermT var)
-> ReaderT
     (Context (Inc var))
     (Except (TypeErrorInScopedContext (Inc var)))
     (Scope (FS (AnnF TypeInfo TermF)) var)
-> TypeCheck (Inc var) (TermT var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scope (FS (AnnF TypeInfo TermF)) var
-> ReaderT
     (Context (Inc var))
     (Except (TypeErrorInScopedContext (Inc var)))
     (Scope (FS (AnnF TypeInfo TermF)) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT Scope (FS (AnnF TypeInfo TermF)) var
body
              TermT var
_ -> String -> TypeCheck var (TermT var)
forall a. String -> a
panicImpossible String
"lambda with a non-function type"


          TypeSigmaT TypeInfo (TermT var)
ty Maybe VarIdent
orig TermT var
a Scope (FS (AnnF TypeInfo TermF)) var
b -> do
            TermT var
a' <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
a
            Maybe VarIdent
-> TermT var
-> TypeCheck (Inc var) (TermT var)
-> TypeCheck var (TermT var)
forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig TermT var
a' (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
              TypeInfo (TermT var)
-> Maybe VarIdent
-> TermT var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> Maybe VarIdent
-> FS (AnnF ann TermF) a
-> Scope (FS (AnnF ann TermF)) a
-> FS (AnnF ann TermF) a
TypeSigmaT TypeInfo (TermT var)
ty Maybe VarIdent
orig TermT var
a' (Scope (FS (AnnF TypeInfo TermF)) var -> TermT var)
-> ReaderT
     (Context (Inc var))
     (Except (TypeErrorInScopedContext (Inc var)))
     (Scope (FS (AnnF TypeInfo TermF)) var)
-> TypeCheck (Inc var) (TermT var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scope (FS (AnnF TypeInfo TermF)) var
-> ReaderT
     (Context (Inc var))
     (Except (TypeErrorInScopedContext (Inc var)))
     (Scope (FS (AnnF TypeInfo TermF)) var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT Scope (FS (AnnF TypeInfo TermF)) var
b
          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)
     (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)
nfT TermT var
l ReaderT
  (Context var)
  (Except (TypeErrorInScopedContext var))
  (TermT var -> TermT var)
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var) (Except (TypeErrorInScopedContext var)) (a -> b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (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)
nfT TermT var
r
          FirstT TypeInfo (TermT var)
ty 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 -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              PairT TypeInfo (TermT var)
_ TermT var
l TermT var
_r -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
l
              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)
ty (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)
nfT 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)
whnfT TermT var
t TypeCheck var (TermT var)
-> (TermT var -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              PairT TypeInfo (TermT var)
_ TermT var
_l TermT var
r -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
r
              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)
ty (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)
nfT TermT var
t'

          TypeIdT TypeInfo (TermT var)
ty TermT var
x Maybe (TermT var)
_tA TermT var
y -> 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)
ty (TermT var -> Maybe (TermT var) -> TermT var -> TermT var)
-> TypeCheck var (TermT var)
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (Maybe (TermT 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)
nfT TermT var
x ReaderT
  (Context var)
  (Except (TypeErrorInScopedContext var))
  (Maybe (TermT var) -> TermT var -> TermT var)
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (Maybe (TermT var))
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (TermT var -> TermT var)
forall a b.
ReaderT
  (Context var) (Except (TypeErrorInScopedContext var)) (a -> b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (TermT var)
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (Maybe (TermT var))
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TermT var)
forall a. Maybe a
Nothing ReaderT
  (Context var)
  (Except (TypeErrorInScopedContext var))
  (TermT var -> TermT var)
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var) (Except (TypeErrorInScopedContext var)) (a -> b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (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)
nfT TermT var
y
          IdJT TypeInfo (TermT var)
ty TermT var
tA TermT var
a TermT var
tC TermT var
d TermT var
x TermT var
p ->
            TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
p TypeCheck var (TermT var)
-> (TermT var -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              ReflT{} -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
d
              TermT var
p' -> 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)
ty (TermT var
 -> TermT var
 -> TermT var
 -> TermT var
 -> TermT var
 -> TermT var
 -> TermT var)
-> TypeCheck var (TermT var)
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (TermT var
      -> TermT var -> TermT var -> TermT 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)
nfT TermT var
tA ReaderT
  (Context var)
  (Except (TypeErrorInScopedContext var))
  (TermT var
   -> TermT var -> TermT var -> TermT var -> TermT var -> TermT var)
-> TypeCheck var (TermT var)
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (TermT var -> TermT var -> TermT var -> TermT var -> TermT var)
forall a b.
ReaderT
  (Context var) (Except (TypeErrorInScopedContext var)) (a -> b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (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)
nfT TermT var
a ReaderT
  (Context var)
  (Except (TypeErrorInScopedContext var))
  (TermT var -> TermT var -> TermT var -> TermT var -> TermT var)
-> TypeCheck var (TermT var)
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (TermT var -> TermT var -> TermT var -> TermT var)
forall a b.
ReaderT
  (Context var) (Except (TypeErrorInScopedContext var)) (a -> b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (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)
nfT TermT var
tC ReaderT
  (Context var)
  (Except (TypeErrorInScopedContext var))
  (TermT var -> TermT var -> TermT var -> TermT var)
-> TypeCheck var (TermT var)
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (TermT var -> TermT var -> TermT var)
forall a b.
ReaderT
  (Context var) (Except (TypeErrorInScopedContext var)) (a -> b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (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)
nfT TermT var
d ReaderT
  (Context var)
  (Except (TypeErrorInScopedContext var))
  (TermT var -> TermT var -> TermT var)
-> TypeCheck var (TermT var)
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (TermT var -> TermT var)
forall a b.
ReaderT
  (Context var) (Except (TypeErrorInScopedContext var)) (a -> b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (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)
nfT TermT var
x ReaderT
  (Context var)
  (Except (TypeErrorInScopedContext var))
  (TermT var -> TermT var)
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var) (Except (TypeErrorInScopedContext var)) (a -> b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (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)
nfT TermT var
p'

          RecOrT TypeInfo (TermT var)
_ty [(TermT var, TermT var)]
rs -> do
            let go :: [(TermT var, a)]
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) (Maybe a)
go [] = Maybe a
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) (Maybe a)
forall a.
a
-> ReaderT (Context var) (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) (Except (TypeErrorInScopedContext var)) (Maybe a))
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) (Maybe a)
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (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) (Except (TypeErrorInScopedContext var)) (Maybe a)
forall a.
a
-> ReaderT (Context var) (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) (Except (TypeErrorInScopedContext var)) (Maybe a)
go [(TermT var, a)]
rs'
            [(TermT var, TermT var)]
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (Maybe (TermT var))
forall {var} {a}.
Eq var =>
[(TermT var, a)]
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) (Maybe a)
go [(TermT var, TermT var)]
rs ReaderT
  (Context var)
  (Except (TypeErrorInScopedContext var))
  (Maybe (TermT var))
-> (Maybe (TermT var) -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Just TermT var
tt' -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
tt'
              Maybe (TermT var)
Nothing
                | [TermT var
tt'] <- [TermT var] -> [TermT var]
forall var. Eq var => [TermT var] -> [TermT var]
nubTermT (((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) -> b
snd [(TermT var, TermT var)]
rs) -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
tt'
                | Bool
otherwise -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt


          TypeRestrictedT TypeInfo (TermT var)
ty TermT var
type_ [(TermT var, TermT var)]
rs -> do
            [Maybe (TermT var, TermT var)]
rs' <- [(TermT var, TermT var)]
-> ((TermT var, TermT var)
    -> ReaderT
         (Context var)
         (Except (TypeErrorInScopedContext var))
         (Maybe (TermT var, TermT var)))
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     [Maybe (TermT var, TermT var)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(TermT var, TermT var)]
rs (((TermT var, TermT var)
  -> ReaderT
       (Context var)
       (Except (TypeErrorInScopedContext var))
       (Maybe (TermT var, TermT var)))
 -> ReaderT
      (Context var)
      (Except (TypeErrorInScopedContext var))
      [Maybe (TermT var, TermT var)])
-> ((TermT var, TermT var)
    -> ReaderT
         (Context var)
         (Except (TypeErrorInScopedContext var))
         (Maybe (TermT var, TermT var)))
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     [Maybe (TermT var, TermT var)]
forall a b. (a -> b) -> a -> b
$ \(TermT var
tope, TermT var
term) -> do
              TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
tope TypeCheck var (TermT var)
-> (TermT var
    -> ReaderT
         (Context var)
         (Except (TypeErrorInScopedContext var))
         (Maybe (TermT var, TermT var)))
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (Maybe (TermT var, TermT var))
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                TopeBottomT{} -> Maybe (TermT var, TermT var)
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (Maybe (TermT var, TermT var))
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TermT var, TermT var)
forall a. Maybe a
Nothing
                TermT var
tope' -> do
                  TermT var
term' <- TermT var -> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope TermT var
tope' (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)
nfT TermT var
term
                  Maybe (TermT var, TermT var)
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (Maybe (TermT var, TermT var))
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((TermT var, TermT var) -> Maybe (TermT var, TermT var)
forall a. a -> Maybe a
Just (TermT var
tope', TermT var
term'))
            case [Maybe (TermT var, TermT var)] -> [(TermT var, TermT var)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (TermT var, TermT var)]
rs' of
              []   -> TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
type_
              [(TermT var, TermT var)]
rs'' -> 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)
ty (TermT var -> [(TermT var, TermT var)] -> TermT var)
-> TypeCheck var (TermT var)
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     ([(TermT 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)
nfT TermT var
type_ ReaderT
  (Context var)
  (Except (TypeErrorInScopedContext var))
  ([(TermT var, TermT var)] -> TermT var)
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     [(TermT var, TermT var)]
-> TypeCheck var (TermT var)
forall a b.
ReaderT
  (Context var) (Except (TypeErrorInScopedContext var)) (a -> b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [(TermT var, TermT var)]
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     [(TermT var, TermT var)]
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(TermT var, TermT var)]
rs''

checkDefinedVar :: VarIdent -> TypeCheck VarIdent ()
checkDefinedVar :: VarIdent
-> ReaderT
     (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) ()
checkDefinedVar VarIdent
x = (Context VarIdent -> Maybe (VarInfo VarIdent))
-> ReaderT
     (Context VarIdent)
     (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)
  (Except (TypeErrorInScopedContext VarIdent))
  (Maybe (VarInfo VarIdent))
-> (Maybe (VarInfo VarIdent)
    -> ReaderT
         (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) ())
-> ReaderT
     (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) ()
forall a b.
ReaderT
  (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) a
-> (a
    -> ReaderT
         (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) b)
-> ReaderT
     (Context VarIdent) (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) (Except (TypeErrorInScopedContext VarIdent)) ()
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError VarIdent
 -> ReaderT
      (Context VarIdent) (Except (TypeErrorInScopedContext VarIdent)) ())
-> TypeError VarIdent
-> ReaderT
     (Context VarIdent) (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) (Except (TypeErrorInScopedContext VarIdent)) ()
forall a.
a
-> ReaderT
     (Context VarIdent) (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)
     (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)
  (Except (TypeErrorInScopedContext var))
  (Maybe (Maybe (TermT var)))
-> (Maybe (Maybe (TermT var))
    -> ReaderT
         (Context var)
         (Except (TypeErrorInScopedContext var))
         (Maybe (TermT var)))
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (Maybe (TermT var))
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (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)
     (Except (TypeErrorInScopedContext var))
     (Maybe (TermT var))
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var
 -> ReaderT
      (Context var)
      (Except (TypeErrorInScopedContext var))
      (Maybe (TermT var)))
-> TypeError var
-> ReaderT
     (Context var)
     (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)
     (Except (TypeErrorInScopedContext var))
     (Maybe (TermT var))
forall a.
a
-> ReaderT (Context var) (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)
     (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)
  (Except (TypeErrorInScopedContext var))
  (Maybe (TermT var))
-> (Maybe (TermT var)
    -> ReaderT
         (Context var) (Except (TypeErrorInScopedContext var)) (TermT var))
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) (TermT var)
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (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) (Except (TypeErrorInScopedContext var)) (TermT var)
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var
 -> ReaderT
      (Context var) (Except (TypeErrorInScopedContext var)) (TermT var))
-> TypeError var
-> ReaderT
     (Context var) (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) (Except (TypeErrorInScopedContext var)) (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return TermT var
ty

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
infoNF :: forall term. TypeInfo term -> Maybe term
infoWHNF :: forall term. TypeInfo term -> Maybe term
infoType :: forall term. TypeInfo term -> 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) (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) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (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
  Bool
equiv <- Bool -> Bool -> Bool
(&&)
    (Bool -> Bool -> Bool)
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) Bool
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TermT var
l] [TermT var]
-> TermT var
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) Bool
forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
`entailM` TermT var
r
    ReaderT
  (Context var)
  (Except (TypeErrorInScopedContext var))
  (Bool -> Bool)
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) Bool
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) Bool
forall a b.
ReaderT
  (Context var) (Except (TypeErrorInScopedContext var)) (a -> b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [TermT var
r] [TermT var]
-> TermT var
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) Bool
forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
`entailM` TermT var
l
  Bool -> TypeCheck var () -> TypeCheck var ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
equiv (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 (TermT var -> TermT var -> TypeError var
forall var. TermT var -> TermT var -> TypeError var
TypeErrorTopesNotEquivalent TermT var
l TermT var
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
  [[TermT var]]
topeSubContexts <- (Context var -> [[TermT var]])
-> ReaderT
     (Context var) (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]]
localTopesNFUnion
  case [[TermT var]]
topeSubContexts of
    [] -> String -> TypeCheck var ()
forall a. String -> a
panicImpossible String
"empty set of alternative contexts"
    [[TermT var]
_] -> TypeCheck var ()
handleSingle
    [TermT var]
_:[TermT var]
_:[[TermT var]]
_ -> do
      [[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]]
topeSubContexts (([TermT var] -> TypeCheck var ()) -> TypeCheck var ())
-> ([TermT var] -> TypeCheck var ()) -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$ \[TermT var]
topes' -> do
        (Context var -> Context var)
-> TypeCheck var () -> TypeCheck var ()
forall a.
(Context var -> Context var)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\Context{Bool
[[TermT var]]
[TermT var]
[ScopeInfo var]
[Action var]
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: forall var. Context var -> Maybe LocationInfo
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 -> Bool
localTopesNFUnion :: forall var. Context var -> [[TermT var]]
localTopesNF :: forall var. Context var -> [TermT var]
localTopes :: forall var. Context var -> [TermT var]
localScopes :: forall var. Context var -> [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopes :: [TermT var]
localTopesNF :: [TermT var]
localTopesNFUnion :: [[TermT var]]
localTopesEntailBottom :: Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
..} -> Context
            { localTopes :: [TermT var]
localTopes = [TermT var]
topes'
            , localTopesNF :: [TermT var]
localTopesNF = [TermT var]
topes'
            , localTopesNFUnion :: [[TermT var]]
localTopesNFUnion = [[TermT var]
topes']
            , Bool
[ScopeInfo var]
[Action var]
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: Maybe LocationInfo
renderBackend :: Maybe RenderBackend
covariance :: Covariance
verbosity :: Verbosity
currentCommand :: Maybe Command
actionStack :: [Action var]
localTopesEntailBottom :: Bool
localScopes :: [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopesEntailBottom :: Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
.. }) (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) (Except (TypeErrorInScopedContext var)) a
-> (TypeErrorInScopedContext var
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a)
-> ReaderT (Context var) (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) (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) (Except (TypeErrorInScopedContext var)) ()
forall a.
a
-> ReaderT (Context var) (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) (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
  Maybe (TermT var)
-> TermT var
-> TermT var
-> ReaderT (Context var) (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) (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
$
  TermT var -> TermT var -> TypeCheck var ()
forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyViaDecompose TermT var
expected TermT var
actual TypeCheck var ()
-> (TypeErrorInScopedContext var -> TypeCheck var ())
-> TypeCheck var ()
forall a.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (TypeErrorInScopedContext var
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \TypeErrorInScopedContext var
_ -> do      -- NOTE: this gives a small, but noticeable speedup
    TermT var
expectedVal <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
expected
    TermT var
actualVal <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
actual
    (TermT var
expected', TermT var
actual') <- (Context var -> Covariance)
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) Covariance
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context var -> Covariance
forall var. Context var -> Covariance
covariance ReaderT
  (Context var) (Except (TypeErrorInScopedContext var)) Covariance
-> (Covariance
    -> ReaderT
         (Context var)
         (Except (TypeErrorInScopedContext var))
         (TermT var, TermT var))
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (TermT var, TermT var)
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Covariance
Covariant     -> Maybe (TermT var)
-> TermT var
-> TermT var
-> ReaderT
     (Context var)
     (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) -> (TermT var, TermT var)
forall a b. (a, b) -> (b, a)
swap ((TermT var, TermT var) -> (TermT var, TermT var))
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (TermT var, TermT var)
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (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)
     (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
    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) (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) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (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) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (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
            let def :: TypeCheck var ()
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 ()
forall {a}. TypeCheck var a
err
                err :: TypeCheck var a
err =
                  case Maybe (TermT var)
mterm of
                    Maybe (TermT var)
Nothing   -> TypeError var -> TypeCheck var a
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 a
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 :: TypeCheck (Inc var) a
errS = 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) -> TypeCheck (Inc var) a
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) -> TypeCheck (Inc var) a
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 TermT var
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) (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
              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 ()
forall {a}. TypeCheck var a
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 ()
forall {a}. TypeCheck var a
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 ()
forall {a}. TypeCheck var a
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 ()
forall {a}. TypeCheck var a
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) (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 Maybe VarIdent
_orig 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' Maybe VarIdent
orig' TermT var
cube' Maybe (FS (AnnF TypeInfo TermF) (Inc var))
mtope' FS (AnnF TypeInfo TermF) (Inc var)
ret' -> do
                    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
                    Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) () -> TypeCheck var ()
forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig' TermT var
cube (TypeCheck (Inc var) () -> TypeCheck var ())
-> TypeCheck (Inc var) () -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$ do
                      case FS (AnnF TypeInfo TermF) (Inc var)
ret' of
                        -- UniverseTopeT{} ->
                        --   (Just tope, Just tope') -> do
                        --     topeNF <- nfT tope
                        --     topeNF' <- nfT tope'
                        --     unifyTopes topeNF topeNF'
                        --   (Nothing, Nothing)      -> return ()
                        --   (Just tope, Nothing)    -> nfT tope >>= (`unifyTopes` topeTopT)
                        --   (Nothing, Just tope)    -> nfT tope >>= unifyTopes topeTopT
                        FS (AnnF TypeInfo TermF) (Inc var)
_ -> 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
                            FS (AnnF TypeInfo TermF) (Inc var)
topeNF <- FS (AnnF TypeInfo TermF) (Inc var)
-> TypeCheck (Inc var) (FS (AnnF TypeInfo TermF) (Inc var))
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) (Inc var)
tope
                            FS (AnnF TypeInfo TermF) (Inc var)
topeNF' <- FS (AnnF TypeInfo TermF) (Inc var)
-> TypeCheck (Inc var) (FS (AnnF TypeInfo TermF) (Inc var))
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) (Inc var)
tope'
                            FS (AnnF TypeInfo TermF) (Inc var)
-> FS (AnnF TypeInfo TermF) (Inc var) -> TypeCheck (Inc var) ()
forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTopes FS (AnnF TypeInfo TermF) (Inc var)
topeNF FS (AnnF TypeInfo TermF) (Inc var)
topeNF'
                          (Maybe (FS (AnnF TypeInfo TermF) (Inc var))
Nothing, Maybe (FS (AnnF TypeInfo TermF) (Inc var))
Nothing)      -> () -> TypeCheck (Inc var) ()
forall a.
a
-> ReaderT
     (Context (Inc var)) (Except (TypeErrorInScopedContext (Inc var))) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                          (Just FS (AnnF TypeInfo TermF) (Inc var)
tope, Maybe (FS (AnnF TypeInfo TermF) (Inc var))
Nothing)    -> FS (AnnF TypeInfo TermF) (Inc var)
-> TypeCheck (Inc var) (FS (AnnF TypeInfo TermF) (Inc var))
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) (Inc var)
tope TypeCheck (Inc var) (FS (AnnF TypeInfo TermF) (Inc var))
-> (FS (AnnF TypeInfo TermF) (Inc var) -> TypeCheck (Inc var) ())
-> TypeCheck (Inc var) ()
forall a b.
ReaderT
  (Context (Inc var)) (Except (TypeErrorInScopedContext (Inc var))) a
-> (a
    -> ReaderT
         (Context (Inc var))
         (Except (TypeErrorInScopedContext (Inc var)))
         b)
-> ReaderT
     (Context (Inc var)) (Except (TypeErrorInScopedContext (Inc var))) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (FS (AnnF TypeInfo TermF) (Inc var)
-> FS (AnnF TypeInfo TermF) (Inc var) -> TypeCheck (Inc var) ()
forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
`unifyTopes` FS (AnnF TypeInfo TermF) (Inc var)
forall var. TermT var
topeTopT)
                          (Maybe (FS (AnnF TypeInfo TermF) (Inc var))
Nothing, Just FS (AnnF TypeInfo TermF) (Inc var)
tope)    -> FS (AnnF TypeInfo TermF) (Inc var)
-> TypeCheck (Inc var) (FS (AnnF TypeInfo TermF) (Inc var))
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) (Inc var)
tope TypeCheck (Inc var) (FS (AnnF TypeInfo TermF) (Inc var))
-> (FS (AnnF TypeInfo TermF) (Inc var) -> TypeCheck (Inc var) ())
-> TypeCheck (Inc var) ()
forall a b.
ReaderT
  (Context (Inc var)) (Except (TypeErrorInScopedContext (Inc var))) a
-> (a
    -> ReaderT
         (Context (Inc var))
         (Except (TypeErrorInScopedContext (Inc var)))
         b)
-> ReaderT
     (Context (Inc var)) (Except (TypeErrorInScopedContext (Inc var))) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FS (AnnF TypeInfo TermF) (Inc var)
-> FS (AnnF TypeInfo TermF) (Inc var) -> TypeCheck (Inc var) ()
forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTopes FS (AnnF TypeInfo TermF) (Inc var)
forall var. TermT var
topeTopT
                      case Maybe (TermT var)
mterm of
                        Maybe (TermT var)
Nothing -> FS (AnnF TypeInfo TermF) (Inc var)
-> FS (AnnF TypeInfo TermF) (Inc var) -> TypeCheck (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)
-> TypeCheck (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 ()
forall {a}. TypeCheck var a
err

              TypeSigmaT TypeInfo (TermT var)
_ty Maybe VarIdent
_orig TermT var
a FS (AnnF TypeInfo TermF) (Inc var)
b ->
                case TermT var
actual' of
                  TypeSigmaT TypeInfo (TermT var)
_ty' Maybe VarIdent
orig' TermT var
a' FS (AnnF TypeInfo TermF) (Inc var)
b' -> 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 VarIdent
-> TermT var -> TypeCheck (Inc var) () -> TypeCheck var ()
forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig' TermT var
a (TypeCheck (Inc var) () -> TypeCheck var ())
-> TypeCheck (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)
-> TypeCheck (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 ()
forall {a}. TypeCheck var a
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 ()
forall {a}. TypeCheck var a
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'
                    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 ()
forall {a}. TypeCheck var a
err

              LambdaT TypeInfo (TermT var)
ty Maybe VarIdent
_orig Maybe (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 Maybe VarIdent
_origF 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' Maybe VarIdent
orig' Maybe (TermT var, Maybe (FS (AnnF TypeInfo TermF) (Inc var)))
_mparam' FS (AnnF TypeInfo TermF) (Inc var)
body' -> do
                        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' Maybe VarIdent
_origF' TermT var
param' Maybe (FS (AnnF TypeInfo TermF) (Inc var))
mtope' FS (AnnF TypeInfo TermF) (Inc var)
_ret' -> 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
param TermT var
param'
                            Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) () -> TypeCheck var ()
forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig' TermT var
param (TypeCheck (Inc var) () -> TypeCheck var ())
-> TypeCheck (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)
-> TypeCheck (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'
                                  FS (AnnF TypeInfo TermF) (Inc var)
-> TypeCheck (Inc var) () -> TypeCheck (Inc var) ()
forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope FS (AnnF TypeInfo TermF) (Inc var)
tope (TypeCheck (Inc var) () -> TypeCheck (Inc var) ())
-> TypeCheck (Inc var) () -> TypeCheck (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)
-> TypeCheck (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)
-> TypeCheck (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)))
_ -> TypeCheck (Inc var) ()
forall {a}. TypeCheck (Inc var) a
errS
                          TermT var
_ -> TypeCheck var ()
forall {a}. TypeCheck var a
err
                      TermT var
_ -> TypeCheck var ()
forall {a}. TypeCheck var a
err
                  TermT var
_ -> TypeCheck var ()
forall {a}. TypeCheck var a
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 ()
forall {a}. TypeCheck var a
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 ()
forall {a}. TypeCheck var a
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 ()
forall {a}. TypeCheck var a
err    -- FIXME: need better unification for restrictions

  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{Bool
[[TermT var]]
[TermT var]
[ScopeInfo var]
[Action var]
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: forall var. Context var -> Maybe LocationInfo
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 -> Bool
localTopesNFUnion :: forall var. Context var -> [[TermT var]]
localTopesNF :: forall var. Context var -> [TermT var]
localTopes :: forall var. Context var -> [TermT var]
localScopes :: forall var. Context var -> [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopes :: [TermT var]
localTopesNF :: [TermT var]
localTopesNFUnion :: [[TermT var]]
localTopesEntailBottom :: Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
..} <- ReaderT
  (Context var) (Except (TypeErrorInScopedContext var)) (Context var)
forall r (m :: * -> *). MonadReader r m => m r
ask
  TermT var
tope' <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
tope
  -- A small optimisation to help unify terms faster
  let refine :: TypeCheck var a -> TypeCheck var a
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
_ | 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]
localTopes -> 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
  TypeCheck var a -> TypeCheck var a
refine (TypeCheck var a -> TypeCheck var a)
-> TypeCheck var a -> TypeCheck var a
forall a b. (a -> b) -> a -> b
$ do
    (Context var -> Context var) -> TypeCheck var a -> TypeCheck var a
forall a.
(Context var -> Context var)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (TermT var -> [TermT var] -> Context var -> Context var
f TermT var
tope' [TermT var]
localTopesNF) TypeCheck var a
tc
  where
    f :: TermT var -> [TermT var] -> Context var -> Context var
f TermT var
tope' [TermT var]
localTopes' Context{Bool
[[TermT var]]
[TermT var]
[ScopeInfo var]
[Action var]
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: forall var. Context var -> Maybe LocationInfo
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 -> Bool
localTopesNFUnion :: forall var. Context var -> [[TermT var]]
localTopesNF :: forall var. Context var -> [TermT var]
localTopes :: forall var. Context var -> [TermT var]
localScopes :: forall var. Context var -> [ScopeInfo var]
localScopes :: [ScopeInfo var]
localTopes :: [TermT var]
localTopesNF :: [TermT var]
localTopesNFUnion :: [[TermT var]]
localTopesEntailBottom :: Bool
actionStack :: [Action var]
currentCommand :: Maybe Command
location :: Maybe LocationInfo
verbosity :: Verbosity
covariance :: Covariance
renderBackend :: Maybe RenderBackend
..} = Context
      { localTopes :: [TermT var]
localTopes = TermT var
tope TermT var -> [TermT var] -> [TermT var]
forall a. a -> [a] -> [a]
: [TermT var]
localTopes
      , localTopesNF :: [TermT var]
localTopesNF = TermT var
tope' TermT var -> [TermT var] -> [TermT var]
forall a. a -> [a] -> [a]
: [TermT var]
localTopesNF
      , localTopesNFUnion :: [[TermT var]]
localTopesNFUnion = ([TermT var] -> [TermT var]) -> [[TermT var]] -> [[TermT var]]
forall a b. (a -> b) -> [a] -> [b]
map [TermT var] -> [TermT var]
forall var. Eq var => [TermT var] -> [TermT var]
nubTermT
          [ [TermT var]
new [TermT var] -> [TermT var] -> [TermT var]
forall a. Semigroup a => a -> a -> a
<> [TermT var]
old
          | [TermT var]
new <- [TermT var] -> [[TermT var]]
forall var. Eq var => [TermT var] -> [[TermT var]]
simplifyLHSwithDisjunctions [TermT var
tope']
          , [TermT var]
old <- [[TermT var]]
localTopesNFUnion ]
      , localTopesEntailBottom :: Bool
localTopesEntailBottom = Bool
entailsBottom
      , [ScopeInfo var]
[Action var]
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
location :: Maybe LocationInfo
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
.. }
      where
        entailsBottom :: Bool
entailsBottom = (TermT var
tope' TermT var -> [TermT var] -> [TermT var]
forall a. a -> [a] -> [a]
: [TermT var]
localTopes') [TermT var] -> TermT var -> Bool
forall var. Eq var => [TermT var] -> TermT var -> Bool
`entail` TermT var
forall var. TermT var
topeBottomT

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 }

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
  -> Maybe VarIdent
  -> Maybe (TermT var, Maybe (Scope TermT var))
  -> Scope TermT var
  -> TermT var
lambdaT :: forall var.
TermT var
-> Maybe VarIdent
-> Maybe (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
lambdaT TermT var
ty Maybe VarIdent
orig Maybe (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)
-> Maybe VarIdent
-> Maybe (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)
-> Maybe VarIdent
-> Maybe
     (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 Maybe VarIdent
orig Maybe (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
      }

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
  :: Maybe VarIdent
  -> TermT var
  -> Maybe (Scope TermT var)
  -> Scope TermT var
  -> TermT var
typeFunT :: forall var.
Maybe VarIdent
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeFunT Maybe VarIdent
orig 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)
-> Maybe VarIdent
-> 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)
-> Maybe VarIdent
-> 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 Maybe VarIdent
orig 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
  :: Maybe VarIdent
  -> TermT var
  -> Scope TermT var
  -> TermT var
typeSigmaT :: forall var.
Maybe VarIdent
-> TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
typeSigmaT Maybe VarIdent
orig TermT var
a Scope (FS (AnnF TypeInfo TermF)) var
b = TermT var
t
  where
    t :: TermT var
t = TypeInfo (TermT var)
-> Maybe VarIdent
-> TermT var
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> Maybe VarIdent
-> FS (AnnF ann TermF) a
-> Scope (FS (AnnF ann TermF)) a
-> FS (AnnF ann TermF) a
TypeSigmaT TypeInfo (TermT var)
info Maybe VarIdent
orig 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
      }

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
$ do
  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) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case

    RecBottomT{} -> do
      TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return TermT var
forall var. TermT var
recBottomT

    TypeRestrictedT TypeInfo (TermT var)
_ty TermT var
ty' [(TermT var, TermT var)]
rs -> do
      TermT var
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'
      TermT var -> TypeCheck var ()
forall var. Eq var => TermT var -> TypeCheck var ()
contextEntailedBy ((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))
      [(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
rterm) -> 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
$
          TermT var -> TermT var -> TypeCheck var ()
forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms TermT var
rterm TermT var
term'
      TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return TermT var
term'    -- FIXME: correct?

    TermT var
ty' -> case Term var
term of
      Lambda Maybe VarIdent
orig Maybe (Term var, Maybe (Scope (FS TermF) var))
mparam Scope (FS TermF) var
body ->
        case TermT var
ty' of
          TypeFunT TypeInfo (TermT var)
_ty Maybe VarIdent
_orig' TermT var
param' Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope' Scope (FS (AnnF TypeInfo TermF)) var
ret -> do
            case Maybe (Term var, Maybe (Scope (FS TermF) var))
mparam of
              Maybe (Term var, Maybe (Scope (FS TermF) var))
Nothing -> () -> TypeCheck var ()
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              Just (Term var
param, Maybe (Scope (FS TermF) var)
Nothing) -> do
                (TermT var
paramType, Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope) <- do
                  TermT var
paramType <- Term var -> TypeCheck var (TermT var)
forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
param
                  TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
paramType TypeCheck var (TermT var)
-> (TermT var
    -> ReaderT
         (Context var)
         (Except (TypeErrorInScopedContext var))
         (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var)))
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    -- an argument can be a shape
                    TypeFunT TypeInfo (TermT var)
_ty Maybe VarIdent
_orig TermT var
cube Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
_mtope UniverseTopeT{} -> do
                      (VarIdent -> TypeCheck var ())
-> Maybe 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 Maybe VarIdent
orig
                      Maybe VarIdent
-> TermT var
-> TypeCheck
     (Inc var) (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig TermT var
cube (TypeCheck
   (Inc var) (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
 -> ReaderT
      (Context var)
      (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)
     (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)) (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)
     (Except (TypeErrorInScopedContext var))
     (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
forall a.
a
-> ReaderT (Context var) (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)
                TermT var -> TermT var -> TypeCheck var ()
forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms TermT var
param' TermT var
paramType
                (VarIdent -> TypeCheck var ())
-> Maybe 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 Maybe VarIdent
orig
                Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) () -> TypeCheck var ()
forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig TermT var
param' (TypeCheck (Inc var) () -> TypeCheck var ())
-> TypeCheck (Inc var) () -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$ do
                  (Scope (FS (AnnF TypeInfo TermF)) var -> TypeCheck (Inc var) ())
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> TypeCheck (Inc var) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Scope (FS (AnnF TypeInfo TermF)) var
-> Scope (FS (AnnF TypeInfo TermF)) var -> TypeCheck (Inc var) ()
forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms (Scope (FS (AnnF TypeInfo TermF)) var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
forall a. a -> Maybe a -> a
fromMaybe Scope (FS (AnnF TypeInfo TermF)) var
forall var. TermT var
topeTopT Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope')) Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope
              Just (Term var
param, Maybe (Scope (FS TermF) var)
mtope) -> do
                TermT var
param'' <- 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'
                TermT var -> TermT var -> TypeCheck var ()
forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms TermT var
param' TermT var
param''
                (VarIdent -> TypeCheck var ())
-> Maybe 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 Maybe VarIdent
orig
                Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) () -> TypeCheck var ()
forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig TermT var
param' (TypeCheck (Inc var) () -> TypeCheck var ())
-> TypeCheck (Inc var) () -> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$ do
                  Scope (FS (AnnF TypeInfo TermF)) var
mtope'' <- 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
-> Maybe (Scope (FS TermF) var) -> Scope (FS TermF) var
forall a. a -> Maybe a -> a
fromMaybe Scope (FS TermF) var
forall {a}. FS TermF a
TopeTop Maybe (Scope (FS TermF) var)
mtope) Scope (FS (AnnF TypeInfo TermF)) var
forall var. TermT var
topeT
                  Scope (FS (AnnF TypeInfo TermF)) var
-> Scope (FS (AnnF TypeInfo TermF)) var -> TypeCheck (Inc var) ()
forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms (Scope (FS (AnnF TypeInfo TermF)) var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
forall a. a -> Maybe a -> a
fromMaybe Scope (FS (AnnF TypeInfo TermF)) var
forall var. TermT var
topeTopT Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope') Scope (FS (AnnF TypeInfo TermF)) var
mtope''

            (VarIdent -> TypeCheck var ())
-> Maybe 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 Maybe VarIdent
orig
            Maybe VarIdent
-> TermT var
-> TypeCheck (Inc var) (TermT var)
-> TypeCheck var (TermT var)
forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig 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
                Scope (FS (AnnF TypeInfo TermF)) var
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
                TermT var -> TypeCheck (Inc var) (TermT var)
forall a.
a
-> ReaderT
     (Context (Inc var)) (Except (TypeErrorInScopedContext (Inc var))) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TermT var
-> Maybe VarIdent
-> Maybe (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall var.
TermT var
-> Maybe VarIdent
-> Maybe (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
lambdaT TermT var
ty' Maybe VarIdent
orig ((TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> Maybe (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
forall a. a -> Maybe a
Just (TermT var
param', Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope')) Scope (FS (AnnF TypeInfo TermF)) var
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

      Pair Term var
l Term var
r ->
        case TermT var
ty' of
          CubeProductT TypeInfo (TermT var)
_ty TermT var
a TermT var
b -> do
            TermT var
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
            TermT var
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
b
            TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (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
ty' TermT var
l' TermT var
r')
          TypeSigmaT TypeInfo (TermT var)
_ty Maybe VarIdent
_orig TermT var
a Scope (FS (AnnF TypeInfo TermF)) var
b -> do
            TermT var
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
            TermT var
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 -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
forall var.
TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
substituteT TermT var
l' Scope (FS (AnnF TypeInfo TermF)) var
b)
            TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (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
ty' TermT var
l' TermT var
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
            TermT var
tA <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
y
            Maybe (Term var, Maybe (Term var))
-> ((Term var, Maybe (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, Maybe (Term var))
mx (((Term var, Maybe (Term var)) -> TypeCheck var ())
 -> TypeCheck var ())
-> ((Term var, Maybe (Term var)) -> TypeCheck var ())
-> TypeCheck var ()
forall a b. (a -> b) -> a -> b
$ \(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
                TermT var
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
                TermT var -> TermT var -> TypeCheck var ()
forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms TermT var
tA TermT var
xty'
              TermT var
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
              TermT var -> TermT var -> TypeCheck var ()
forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms TermT var
x' TermT var
y
              TermT var -> TermT var -> TypeCheck var ()
forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms TermT var
x' TermT var
z
            Bool -> TypeCheck var () -> TypeCheck var ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (Term var, Maybe (Term var)) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Term var, Maybe (Term var))
mx) (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
y TermT var
z
            TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (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
ty' ((TermT var, Maybe (TermT var))
-> Maybe (TermT var, Maybe (TermT var))
forall a. a -> Maybe a
Just (TermT var
y, TermT var -> Maybe (TermT var)
forall a. a -> Maybe a
Just TermT var
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

        -- FIXME: this does not make typechecking faster, why?
--      RecOr rs -> do
--        rs' <- forM rs $ \(tope, rterm) -> do
--          tope' <- typecheck tope topeT
--          contextEntailedBy tope'
--          localTope tope' $ do
--            rterm' <- typecheck rterm ty
--            return (tope', rterm')
--        return (recOrT ty rs')

      Term var
_ -> do
        TermT var
term' <- Term var -> TypeCheck var (TermT var)
forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
term
        TermT var
inferredType <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
term'
        TermT var -> TermT var -> TermT var -> TypeCheck var ()
forall var.
Eq var =>
TermT var -> TermT var -> TermT var -> TypeCheck var ()
unifyTypes TermT var
term' TermT var
ty' TermT var
inferredType
        TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return TermT var
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
  TermT var
term' <- Term var -> TypeCheck var (TermT var)
forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
term
  TermT var
ty <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
term'
  TermT var
kind <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
ty
  TermT var -> TermT var -> TermT var -> TypeCheck var ()
forall var.
Eq var =>
TermT var -> TermT var -> TermT var -> TypeCheck var ()
unifyTypes TermT var
ty TermT var
expectedKind TermT var
kind
  TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return TermT var
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
  Pure var
x -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (var -> TermT var
forall (t :: * -> * -> *) a. a -> FS t a
Pure var
x)

  Term var
Universe     -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (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) (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) (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) (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) (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) (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) (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) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
forall var. TermT var
cube2_1T

  CubeProduct Term var
l Term var
r -> do
    TermT var
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
    TermT var
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
cubeT
    TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (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
cubeProductT TermT var
l' TermT var
r')

  Pair Term var
l Term var
r -> do
    TermT var
l' <- Term var -> TypeCheck var (TermT var)
forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
l
    TermT var
r' <- Term var -> TypeCheck var (TermT var)
forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
r
    TermT var
lt <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
l'
    TermT var
rt <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
r'
    TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
lt TypeCheck var (TermT var)
-> (TermT var -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      UniverseCubeT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (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')
      TermT var
_ -> do
        -- NOTE: infer as a non-dependent pair!
        TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (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 (Maybe VarIdent
-> TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
forall var.
Maybe VarIdent
-> TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
typeSigmaT Maybe VarIdent
forall a. Maybe a
Nothing 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
    TermT var
t' <- Term var -> TypeCheck var (TermT var)
forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
t
    (TermT var -> TermT var)
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b.
(a -> b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (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
stripTypeRestrictions (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 (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      RecBottomT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (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 Maybe VarIdent
_orig TermT var
lt Scope (FS (AnnF TypeInfo TermF)) var
_rt ->
        TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (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) (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
    TermT var
t' <- Term var -> TypeCheck var (TermT var)
forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
t
    (TermT var -> TermT var)
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b.
(a -> b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (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
stripTypeRestrictions (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 (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      RecBottomT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (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 Maybe VarIdent
_orig TermT var
lt Scope (FS (AnnF TypeInfo TermF)) var
rt ->
        TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (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) (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) (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) (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) (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) (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
    TermT var
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
    TermT var
lt <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
l'
    TermT var
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
lt
    TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (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
topeEQT TermT var
l' TermT var
r')

  TopeLEQ Term var
l Term var
r -> do
    TermT var
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
cube2T
    TermT var
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
cube2T
    TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (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')

  TopeAnd Term var
l Term var
r -> do
    TermT var
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
    TermT var
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
topeT
    TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (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
l' TermT var
r')

  TopeOr Term var
l Term var
r -> do
    TermT var
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
    TermT var
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
topeT
    TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (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
topeOrT TermT var
l' TermT var
r')

  Term var
RecBottom -> do
    TermT var -> TypeCheck 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) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return TermT var
forall var. TermT var
recBottomT

  RecOr [(Term var, Term var)]
rs -> do
    [(TermT var, (TermT var, TermT var))]
ttts <- [(Term var, Term var)]
-> ((Term var, Term var)
    -> ReaderT
         (Context var)
         (Except (TypeErrorInScopedContext var))
         (TermT var, (TermT var, TermT var)))
-> ReaderT
     (Context var)
     (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)
       (Except (TypeErrorInScopedContext var))
       (TermT var, (TermT var, TermT var)))
 -> ReaderT
      (Context var)
      (Except (TypeErrorInScopedContext var))
      [(TermT var, (TermT var, TermT var))])
-> ((Term var, Term var)
    -> ReaderT
         (Context var)
         (Except (TypeErrorInScopedContext var))
         (TermT var, (TermT var, TermT var)))
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     [(TermT var, (TermT var, TermT var))]
forall a b. (a -> b) -> a -> b
$ \(Term var
tope, Term var
term) -> do
      TermT var
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
      TermT var -> TypeCheck var ()
forall var. Eq var => TermT var -> TypeCheck var ()
contextEntailedBy TermT var
tope'
      TermT var
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (TermT var, (TermT var, TermT var))
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (TermT var, (TermT var, TermT var))
forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope TermT var
tope' (ReaderT
   (Context var)
   (Except (TypeErrorInScopedContext var))
   (TermT var, (TermT var, TermT var))
 -> ReaderT
      (Context var)
      (Except (TypeErrorInScopedContext var))
      (TermT var, (TermT var, TermT var)))
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (TermT var, (TermT var, TermT var))
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (TermT var, (TermT var, TermT var))
forall a b. (a -> b) -> a -> b
$ do
        TermT var
term' <- 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
term
        TermT var
ty <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
term'
        (TermT var, (TermT var, TermT var))
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (TermT var, (TermT var, TermT var))
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TermT var
tope', (TermT var
term', TermT var
ty))
    let rs' :: [(TermT var, TermT var)]
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)]
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
    [TypeCheck var ()] -> TypeCheck var ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ (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)
l (TermT var, TermT var)
r | (TermT var, TermT var)
l:[(TermT var, TermT var)]
rs'' <- [(TermT var, TermT var)] -> [[(TermT var, TermT var)]]
forall a. [a] -> [[a]]
tails [(TermT var, TermT var)]
rs', (TermT var, TermT var)
r <- [(TermT var, TermT var)]
rs'' ]
    [TermT var] -> TypeCheck var ()
forall var. Eq var => [TermT var] -> TypeCheck var ()
contextEquiv (((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
forall a b. (a, b) -> a
fst [(TermT var, (TermT var, TermT var))]
ttts)
    TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (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
recOrT (TermT var -> [(TermT var, TermT var)] -> TermT var
forall var. TermT var -> [(TermT var, TermT var)] -> TermT var
recOrT TermT var
forall var. TermT var
universeT [(TermT var, TermT var)]
ts) [(TermT var, TermT var)]
rs')

  TypeFun Maybe VarIdent
orig Term var
a Maybe (Scope (FS TermF) var)
Nothing Scope (FS TermF) var
b -> do
    TermT var
a' <- Term var -> TypeCheck var (TermT var)
forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
a
    TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
a' TypeCheck var (TermT var)
-> (TermT var -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \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 -> TypeCheck var ())
-> Maybe 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 Maybe VarIdent
orig
            Scope (FS (AnnF TypeInfo TermF)) var
b' <- Maybe VarIdent
-> TermT var
-> TypeCheck (Inc var) (Scope (FS (AnnF TypeInfo TermF)) var)
-> TypeCheck var (Scope (FS (AnnF TypeInfo TermF)) var)
forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig 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 (AnnF TypeInfo TermF)) var
-> Scope (FS TermF) var
-> TypeCheck (Inc var) (Scope (FS (AnnF TypeInfo TermF)) var)
forall var.
Eq var =>
TermT var -> Term var -> TypeCheck var (TermT var)
inferAs Scope (FS (AnnF TypeInfo TermF)) var
forall var. TermT var
universeT Scope (FS TermF) var
b
            TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe VarIdent
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall var.
Maybe VarIdent
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeFunT Maybe VarIdent
orig TermT var
a' Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
forall a. Maybe a
Nothing Scope (FS (AnnF TypeInfo TermF)) var
b')
      -- an argument can be a cube
      UniverseCubeT{} -> do
        (VarIdent -> TypeCheck var ())
-> Maybe 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 Maybe VarIdent
orig
        Scope (FS (AnnF TypeInfo TermF)) var
b' <- Maybe VarIdent
-> TermT var
-> TypeCheck (Inc var) (Scope (FS (AnnF TypeInfo TermF)) var)
-> TypeCheck var (Scope (FS (AnnF TypeInfo TermF)) var)
forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig 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 (AnnF TypeInfo TermF)) var
-> Scope (FS TermF) var
-> TypeCheck (Inc var) (Scope (FS (AnnF TypeInfo TermF)) var)
forall var.
Eq var =>
TermT var -> Term var -> TypeCheck var (TermT var)
inferAs Scope (FS (AnnF TypeInfo TermF)) var
forall var. TermT var
universeT Scope (FS TermF) var
b
        TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe VarIdent
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall var.
Maybe VarIdent
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeFunT Maybe VarIdent
orig TermT var
a' Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
forall a. Maybe a
Nothing Scope (FS (AnnF TypeInfo TermF)) var
b')
      -- an argument can be a shape
      TypeFunT TypeInfo (TermT var)
_ty Maybe VarIdent
_orig TermT var
cube Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope UniverseTopeT{} -> do
        (VarIdent -> TypeCheck var ())
-> Maybe 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 Maybe VarIdent
orig
        Maybe VarIdent
-> TermT var
-> TypeCheck (Inc var) (TermT var)
-> TypeCheck var (TermT var)
forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig 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
            Scope (FS (AnnF TypeInfo TermF)) var
b' <- Scope (FS (AnnF TypeInfo TermF)) var
-> Scope (FS TermF) var
-> TypeCheck (Inc var) (Scope (FS (AnnF TypeInfo TermF)) var)
forall var.
Eq var =>
TermT var -> Term var -> TypeCheck var (TermT var)
inferAs Scope (FS (AnnF TypeInfo TermF)) var
forall var. TermT var
universeT Scope (FS TermF) var
b
            case Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope of
              Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
Nothing -> TermT var -> TypeCheck (Inc var) (TermT var)
forall a.
a
-> ReaderT
     (Context (Inc var)) (Except (TypeErrorInScopedContext (Inc var))) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe VarIdent
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall var.
Maybe VarIdent
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeFunT Maybe VarIdent
orig 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)) (Except (TypeErrorInScopedContext (Inc var))) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe VarIdent
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall var.
Maybe VarIdent
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeFunT Maybe VarIdent
orig 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 Maybe VarIdent
orig Term var
cube (Just Scope (FS TermF) var
tope) Scope (FS TermF) var
ret -> do
    TermT var
cube' <- 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
    (VarIdent -> TypeCheck var ())
-> Maybe 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 Maybe VarIdent
orig
    Maybe VarIdent
-> TermT var
-> TypeCheck (Inc var) (TermT var)
-> TypeCheck var (TermT var)
forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig 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
      Scope (FS (AnnF TypeInfo TermF)) var
tope' <- 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
tope Scope (FS (AnnF TypeInfo TermF)) var
forall var. TermT var
topeT
      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
        Scope (FS (AnnF TypeInfo TermF)) var
ret' <- Scope (FS (AnnF TypeInfo TermF)) var
-> Scope (FS TermF) var
-> TypeCheck (Inc var) (Scope (FS (AnnF TypeInfo TermF)) var)
forall var.
Eq var =>
TermT var -> Term var -> TypeCheck var (TermT var)
inferAs Scope (FS (AnnF TypeInfo TermF)) var
forall var. TermT var
universeT Scope (FS TermF) var
ret
        TermT var -> TypeCheck (Inc var) (TermT var)
forall a.
a
-> ReaderT
     (Context (Inc var)) (Except (TypeErrorInScopedContext (Inc var))) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe VarIdent
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall var.
Maybe VarIdent
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeFunT Maybe VarIdent
orig 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
ret')

  TypeSigma Maybe VarIdent
orig Term var
a Scope (FS TermF) var
b -> do
    TermT var
a' <- 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
a  -- FIXME: separate universe of universes from universe of types
    (VarIdent -> TypeCheck var ())
-> Maybe 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 Maybe VarIdent
orig
    Scope (FS (AnnF TypeInfo TermF)) var
b' <- Maybe VarIdent
-> TermT var
-> TypeCheck (Inc var) (Scope (FS (AnnF TypeInfo TermF)) var)
-> TypeCheck var (Scope (FS (AnnF TypeInfo TermF)) var)
forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig 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 (AnnF TypeInfo TermF)) var
-> Scope (FS TermF) var
-> TypeCheck (Inc var) (Scope (FS (AnnF TypeInfo TermF)) var)
forall var.
Eq var =>
TermT var -> Term var -> TypeCheck var (TermT var)
inferAs Scope (FS (AnnF TypeInfo TermF)) var
forall var. TermT var
universeT Scope (FS TermF) var
b
    TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe VarIdent
-> TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
forall var.
Maybe VarIdent
-> TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
typeSigmaT Maybe VarIdent
orig TermT var
a' Scope (FS (AnnF TypeInfo TermF)) var
b')

  TypeId Term var
x (Just Term var
tA) Term var
y -> do
    TermT var
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
    TermT var
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'
    TermT var
y' <- Term var -> TermT var -> TypeCheck var (TermT var)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
y TermT var
tA'
    TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TermT var -> Maybe (TermT var) -> TermT var -> TermT var
forall var.
TermT var -> Maybe (TermT var) -> TermT var -> TermT var
typeIdT TermT var
x' (TermT var -> Maybe (TermT var)
forall a. a -> Maybe a
Just TermT var
tA') TermT var
y')

  TypeId Term var
x Maybe (Term var)
Nothing Term var
y -> do
    TermT var
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
    TermT var
tA <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
x'
    TermT var
y' <- Term var -> TermT var -> TypeCheck var (TermT var)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
y TermT var
tA
    TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TermT var -> Maybe (TermT var) -> TermT var -> TermT var
forall var.
TermT var -> Maybe (TermT var) -> TermT var -> TermT var
typeIdT TermT var
x' (TermT var -> Maybe (TermT var)
forall a. a -> Maybe a
Just TermT var
tA) TermT var
y')

  App Term var
f Term var
x -> do
    TermT var
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
    (TermT var -> TermT var)
-> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall a b.
(a -> b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (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
stripTypeRestrictions (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 -> TypeCheck var (TermT var))
-> TypeCheck var (TermT var)
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      RecBottomT{} -> TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
forall var. TermT var
recBottomT -- FIXME: is this ok?
      TypeFunT TypeInfo (TermT var)
_ty Maybe VarIdent
_orig TermT var
a Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope Scope (FS (AnnF TypeInfo TermF)) var
b -> do
        TermT var
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
a
        let result :: TermT var
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 Scope (FS (AnnF TypeInfo TermF)) var
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) (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) (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 -> TypeCheck var ())
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var) -> TypeCheck var ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TermT var -> TypeCheck var ()
forall var. Eq var => TermT var -> TypeCheck var ()
contextEntails (TermT var -> TypeCheck var ())
-> (Scope (FS (AnnF TypeInfo TermF)) var -> TermT var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TypeCheck 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) (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 Maybe VarIdent
_orig Maybe (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 Maybe VarIdent
orig (Just (Term var
ty, Maybe (Scope (FS TermF) var)
Nothing)) Scope (FS TermF) var
body -> do
    TermT var
ty' <- Term var -> TypeCheck var (TermT var)
forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
ty
    Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
ty' TypeCheck var (TermT var)
-> (TermT var
    -> ReaderT
         (Context var)
         (Except (TypeErrorInScopedContext var))
         (Maybe (Scope (FS (AnnF TypeInfo TermF)) var)))
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \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)
     (Except (TypeErrorInScopedContext var))
     (Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var
 -> ReaderT
      (Context var)
      (Except (TypeErrorInScopedContext var))
      (Maybe (Scope (FS (AnnF TypeInfo TermF)) var)))
-> TypeError var
-> ReaderT
     (Context var)
     (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)
     (Except (TypeErrorInScopedContext var))
     (Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
forall a.
a
-> ReaderT (Context var) (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)
     (Except (TypeErrorInScopedContext var))
     (Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
forall a.
a
-> ReaderT (Context var) (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 Maybe VarIdent
_orig TermT var
cube Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
_mtope UniverseTopeT{} -> do
        (VarIdent -> TypeCheck var ())
-> Maybe 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 Maybe VarIdent
orig
        Maybe VarIdent
-> TermT var
-> TypeCheck
     (Inc var) (Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig TermT var
cube (TypeCheck (Inc var) (Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
 -> ReaderT
      (Context var)
      (Except (TypeErrorInScopedContext var))
      (Maybe (Scope (FS (AnnF TypeInfo TermF)) var)))
-> TypeCheck
     (Inc var) (Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> ReaderT
     (Context var)
     (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)) (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)
     (Except (TypeErrorInScopedContext var))
     (Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
forall var a. TypeError var -> TypeCheck var a
issueTypeError (TypeError var
 -> ReaderT
      (Context var)
      (Except (TypeErrorInScopedContext var))
      (Maybe (Scope (FS (AnnF TypeInfo TermF)) var)))
-> TypeError var
-> ReaderT
     (Context var)
     (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
    (VarIdent -> TypeCheck var ())
-> Maybe 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 Maybe VarIdent
orig
    Maybe VarIdent
-> TermT var
-> TypeCheck (Inc var) (TermT var)
-> TypeCheck var (TermT var)
forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig TermT var
ty' (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
        Scope (FS (AnnF TypeInfo TermF)) var
body' <- Scope (FS TermF) var
-> TypeCheck (Inc var) (Scope (FS (AnnF TypeInfo TermF)) var)
forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Scope (FS TermF) var
body
        Scope (FS (AnnF TypeInfo TermF)) var
ret <- 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
body'
        TermT var -> TypeCheck (Inc var) (TermT var)
forall a.
a
-> ReaderT
     (Context (Inc var)) (Except (TypeErrorInScopedContext (Inc var))) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TermT var
-> Maybe VarIdent
-> Maybe (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall var.
TermT var
-> Maybe VarIdent
-> Maybe (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
lambdaT (Maybe VarIdent
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall var.
Maybe VarIdent
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeFunT Maybe VarIdent
orig TermT var
ty' Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope Scope (FS (AnnF TypeInfo TermF)) var
ret) Maybe VarIdent
orig ((TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> Maybe (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
forall a. a -> Maybe a
Just (TermT var
ty', Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope)) Scope (FS (AnnF TypeInfo TermF)) var
body')
  Lambda Maybe VarIdent
orig (Just (Term var
cube, Just Scope (FS TermF) var
tope)) Scope (FS TermF) var
body -> do
    TermT var
cube' <- 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
    (VarIdent -> TypeCheck var ())
-> Maybe 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 Maybe VarIdent
orig
    Maybe VarIdent
-> TermT var
-> TypeCheck (Inc var) (TermT var)
-> TypeCheck var (TermT var)
forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig 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
      Scope (FS (AnnF TypeInfo TermF)) var
tope' <- Scope (FS TermF) var
-> TypeCheck (Inc var) (Scope (FS (AnnF TypeInfo TermF)) var)
forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Scope (FS TermF) var
tope
      Scope (FS (AnnF TypeInfo TermF)) var
body' <- Scope (FS (AnnF TypeInfo TermF)) var
-> TypeCheck (Inc var) (Scope (FS (AnnF TypeInfo TermF)) var)
-> TypeCheck (Inc var) (Scope (FS (AnnF TypeInfo TermF)) 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) (Scope (FS (AnnF TypeInfo TermF)) var)
 -> TypeCheck (Inc var) (Scope (FS (AnnF TypeInfo TermF)) var))
-> TypeCheck (Inc var) (Scope (FS (AnnF TypeInfo TermF)) var)
-> TypeCheck (Inc var) (Scope (FS (AnnF TypeInfo TermF)) var)
forall a b. (a -> b) -> a -> b
$ Scope (FS TermF) var
-> TypeCheck (Inc var) (Scope (FS (AnnF TypeInfo TermF)) var)
forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Scope (FS TermF) var
body
      Scope (FS (AnnF TypeInfo TermF)) var
ret <- 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
body'
      TermT var -> TypeCheck (Inc var) (TermT var)
forall a.
a
-> ReaderT
     (Context (Inc var)) (Except (TypeErrorInScopedContext (Inc var))) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TermT var
-> Maybe VarIdent
-> Maybe (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall var.
TermT var
-> Maybe VarIdent
-> Maybe (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
lambdaT (Maybe VarIdent
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall var.
Maybe VarIdent
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeFunT Maybe VarIdent
orig 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
ret) Maybe VarIdent
orig ((TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
-> Maybe (TermT var, Maybe (Scope (FS (AnnF TypeInfo TermF)) var))
forall a. a -> Maybe a
Just (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
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
    TermT var
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
    TermT var
ty <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
x'
    TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (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
x' (TermT var -> Maybe (TermT var)
forall a. a -> Maybe a
Just TermT var
ty) TermT var
x') ((TermT var, Maybe (TermT var))
-> Maybe (TermT var, Maybe (TermT var))
forall a. a -> Maybe a
Just (TermT var
x', TermT var -> Maybe (TermT var)
forall a. a -> Maybe a
Just TermT var
ty)))
  Refl (Just (Term var
x, Just Term var
ty)) -> do
    TermT var
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
    TermT var
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
ty'
    TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (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
x' (TermT var -> Maybe (TermT var)
forall a. a -> Maybe a
Just TermT var
ty') TermT var
x') ((TermT var, Maybe (TermT var))
-> Maybe (TermT var, Maybe (TermT var))
forall a. a -> Maybe a
Just (TermT var
x', TermT var -> Maybe (TermT var)
forall a. a -> Maybe a
Just TermT var
ty')))

  IdJ Term var
tA Term var
a Term var
tC Term var
d Term var
x Term var
p -> do
    TermT var
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
    TermT var
a' <- 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
tA'
    let typeOf_C :: TermT var
typeOf_C =
          Maybe VarIdent
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall var.
Maybe VarIdent
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeFunT Maybe VarIdent
forall a. Maybe a
Nothing 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
$
            Maybe VarIdent
-> 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.
Maybe VarIdent
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeFunT Maybe VarIdent
forall a. Maybe a
Nothing (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
    TermT var
tC' <- Term var -> TermT var -> TypeCheck var (TermT var)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
tC TermT var
typeOf_C
    let typeOf_d :: TermT var
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 (Maybe VarIdent
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall var.
Maybe VarIdent
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeFunT Maybe VarIdent
forall a. Maybe a
Nothing (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)
    TermT var
d' <- Term var -> TermT var -> TypeCheck var (TermT var)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
d TermT var
typeOf_d
    TermT var
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'
    TermT var
p' <- Term var -> TermT var -> TypeCheck var (TermT var)
forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
p (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')
    let ret :: TermT var
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 (Maybe VarIdent
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
forall var.
Maybe VarIdent
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeFunT Maybe VarIdent
forall a. Maybe a
Nothing (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'
    TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (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
ret TermT var
tA' TermT var
a' TermT var
tC' TermT var
d' TermT var
x' TermT var
p')

  TypeAsc Term var
term Term var
ty -> do
    TermT var
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
    TermT var
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'
    TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (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
typeAscT TermT var
term' TermT var
ty')

  TypeRestricted Term var
ty [(Term var, Term var)]
rs -> do
    TermT var
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
    [(TermT var, TermT var)]
rs' <- [(Term var, Term var)]
-> ((Term var, Term var)
    -> ReaderT
         (Context var)
         (Except (TypeErrorInScopedContext var))
         (TermT var, TermT var))
-> ReaderT
     (Context var)
     (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)
       (Except (TypeErrorInScopedContext var))
       (TermT var, TermT var))
 -> ReaderT
      (Context var)
      (Except (TypeErrorInScopedContext var))
      [(TermT var, TermT var)])
-> ((Term var, Term var)
    -> ReaderT
         (Context var)
         (Except (TypeErrorInScopedContext var))
         (TermT var, TermT var))
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     [(TermT var, TermT var)]
forall a b. (a -> b) -> a -> b
$ \(Term var
tope, Term var
term) -> do
      TermT var
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
      TermT var
term' <- TermT var -> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope TermT var
tope' (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
term TermT var
ty'
      (TermT var, TermT var)
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (TermT var, TermT var)
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TermT var
tope', TermT var
term')
    [TypeCheck var ()] -> TypeCheck var ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ (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)
l (TermT var, TermT var)
r | (TermT var, TermT var)
l:[(TermT var, TermT var)]
rs'' <- [(TermT var, TermT var)] -> [[(TermT var, TermT var)]]
forall a. [a] -> [[a]]
tails [(TermT var, TermT var)]
rs', (TermT var, TermT var)
r <- [(TermT var, TermT var)]
rs'' ]
    TermT var -> TypeCheck var (TermT var)
forall a.
a
-> ReaderT (Context var) (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
typeRestrictedT TermT var
ty' [(TermT var, TermT var)]
rs')

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
      TermT var
ltype <- TermT var -> TermT var
forall var. TermT var -> TermT var
stripTypeRestrictions (TermT var -> TermT var)
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) (TermT var)
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) (TermT var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
lterm   -- FIXME: why strip?
      TermT var
rtype <- TermT var -> TermT var
forall var. TermT var -> TermT var
stripTypeRestrictions (TermT var -> TermT var)
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) (TermT var)
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) (TermT var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
rterm   -- FIXME: why strip?
      -- FIXME: do we need to unify types here or is it included in unification of terms?
      TermT var -> TermT var -> TypeCheck var ()
forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms TermT var
ltype TermT var
rtype
      TermT var -> TermT var -> TypeCheck var ()
forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms TermT var
lterm TermT var
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

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)
     (Except (TypeErrorInScopedContext var))
     [Maybe ([String], RenderObjectData)]
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     [([String], RenderObjectData)]
forall a b.
(a -> b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (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)
   (Except (TypeErrorInScopedContext var))
   [Maybe ([String], RenderObjectData)]
 -> ReaderT
      (Context var)
      (Except (TypeErrorInScopedContext var))
      [([String], RenderObjectData)])
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     [Maybe ([String], RenderObjectData)]
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     [([String], RenderObjectData)]
forall a b. (a -> b) -> a -> b
$ do
  [([String], TermT var)]
-> (([String], TermT var)
    -> ReaderT
         (Context var)
         (Except (TypeErrorInScopedContext var))
         (Maybe ([String], RenderObjectData)))
-> ReaderT
     (Context var)
     (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)
       (Except (TypeErrorInScopedContext var))
       (Maybe ([String], RenderObjectData)))
 -> ReaderT
      (Context var)
      (Except (TypeErrorInScopedContext var))
      [Maybe ([String], RenderObjectData)])
-> (([String], TermT var)
    -> ReaderT
         (Context var)
         (Except (TypeErrorInScopedContext var))
         (Maybe ([String], RenderObjectData)))
-> ReaderT
     (Context var)
     (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)
         (Except (TypeErrorInScopedContext var))
         (Maybe ([String], RenderObjectData)))
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (Maybe ([String], RenderObjectData))
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (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)
     (Except (TypeErrorInScopedContext var))
     (Maybe ([String], RenderObjectData))
forall a.
a
-> ReaderT (Context var) (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)
         (Except (TypeErrorInScopedContext var))
         (Maybe ([String], RenderObjectData)))
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (Maybe ([String], RenderObjectData))
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        UniverseTopeT{} -> TermT var
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (Maybe ([String], RenderObjectData))
-> ReaderT
     (Context var)
     (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)
   (Except (TypeErrorInScopedContext var))
   (Maybe ([String], RenderObjectData))
 -> ReaderT
      (Context var)
      (Except (TypeErrorInScopedContext var))
      (Maybe ([String], RenderObjectData)))
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (Maybe ([String], RenderObjectData))
-> ReaderT
     (Context var)
     (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)
         (Except (TypeErrorInScopedContext var))
         (Maybe ([String], RenderObjectData)))
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (Maybe ([String], RenderObjectData))
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (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)
     (Except (TypeErrorInScopedContext var))
     (Maybe ([String], RenderObjectData))
forall a.
a
-> ReaderT (Context var) (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)
     (Except (TypeErrorInScopedContext var))
     (Maybe ([String], RenderObjectData))
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ([String], RenderObjectData)
 -> ReaderT
      (Context var)
      (Except (TypeErrorInScopedContext var))
      (Maybe ([String], RenderObjectData)))
-> Maybe ([String], RenderObjectData)
-> ReaderT
     (Context var)
     (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
          [(var, Maybe VarIdent)]
origs <- (Context var -> [(var, Maybe VarIdent)])
-> ReaderT
     (Context var)
     (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
          TermT var
term' <- TermT var -> TypeCheck var (TermT var) -> TypeCheck var (TermT var)
forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope TermT var
tope (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)
whnfT TermT var
term
          String
label <-
            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) (Except (TypeErrorInScopedContext var)) String
forall a.
a
-> ReaderT (Context var) (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) (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) (Except (TypeErrorInScopedContext var)) String
forall var. Eq var => TermT var -> TypeCheck var String
ppTermInContext TermT var
term'
          Maybe ([String], RenderObjectData)
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (Maybe ([String], RenderObjectData))
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ([String], RenderObjectData)
 -> ReaderT
      (Context var)
      (Except (TypeErrorInScopedContext var))
      (Maybe ([String], RenderObjectData)))
-> Maybe ([String], RenderObjectData)
-> ReaderT
     (Context var)
     (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
label
            , renderObjectDataFullLabel :: String
renderObjectDataFullLabel = String
label
            , renderObjectDataColor :: String
renderObjectDataColor =
                case TermT var
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)
     (Except (TypeErrorInScopedContext var))
     [Maybe ([String], RenderObjectData)]
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     [([String], RenderObjectData)]
forall a b.
(a -> b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> ReaderT (Context var) (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)
   (Except (TypeErrorInScopedContext var))
   [Maybe ([String], RenderObjectData)]
 -> ReaderT
      (Context var)
      (Except (TypeErrorInScopedContext var))
      [([String], RenderObjectData)])
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     [Maybe ([String], RenderObjectData)]
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     [([String], RenderObjectData)]
forall a b. (a -> b) -> a -> b
$ do
  let reduceContext :: [TermT 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)
-> ([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 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])
-> ([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 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]])
-> ([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 a b. (a -> b) -> [a] -> [b]
map ([TermT var] -> [TermT var] -> [TermT var]
forall var. Eq var => [TermT var] -> [TermT var] -> [TermT var]
saturateTopes [])
        ([[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. Eq var => [TermT var] -> [[TermT var]]
simplifyLHSwithDisjunctions
  TermT var
contextTopes  <- (Context var -> TermT var)
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) (TermT var)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ([TermT var] -> TermT var
reduceContext ([TermT var] -> TermT var)
-> (Context var -> [TermT var]) -> Context var -> TermT var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context var -> [TermT var]
forall var. Context var -> [TermT var]
localTopesNF)
  TermT var
contextTopes' <- TermT var
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) (TermT var)
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) (TermT var)
forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope (Int -> TermT var -> TermT var -> TermT var
forall var. Int -> TermT var -> TermT var -> TermT var
componentWiseEQT Int
dim (var -> TermT var
forall (t :: * -> * -> *) a. a -> FS t a
Pure var
super) TermT var
x) (ReaderT
   (Context var) (Except (TypeErrorInScopedContext var)) (TermT var)
 -> ReaderT
      (Context var) (Except (TypeErrorInScopedContext var)) (TermT var))
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) (TermT var)
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) (TermT var)
forall a b. (a -> b) -> a -> b
$ (Context var -> TermT var)
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) (TermT var)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ([TermT var] -> TermT var
reduceContext ([TermT var] -> TermT var)
-> (Context var -> [TermT var]) -> Context var -> TermT var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context var -> [TermT var]
forall var. Context var -> [TermT var]
localTopesNF)
  [([String], TermT var)]
-> (([String], TermT var)
    -> ReaderT
         (Context var)
         (Except (TypeErrorInScopedContext var))
         (Maybe ([String], RenderObjectData)))
-> ReaderT
     (Context var)
     (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 (var -> TermT var
forall (t :: * -> * -> *) a. a -> FS t a
Pure var
super)) ((([String], TermT var)
  -> ReaderT
       (Context var)
       (Except (TypeErrorInScopedContext var))
       (Maybe ([String], RenderObjectData)))
 -> ReaderT
      (Context var)
      (Except (TypeErrorInScopedContext var))
      [Maybe ([String], RenderObjectData)])
-> (([String], TermT var)
    -> ReaderT
         (Context var)
         (Except (TypeErrorInScopedContext var))
         (Maybe ([String], RenderObjectData)))
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     [Maybe ([String], RenderObjectData)]
forall a b. (a -> b) -> a -> b
$ \([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)
         (Except (TypeErrorInScopedContext var))
         (Maybe ([String], RenderObjectData)))
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (Maybe ([String], RenderObjectData))
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (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)
     (Except (TypeErrorInScopedContext var))
     (Maybe ([String], RenderObjectData))
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ([String], RenderObjectData)
forall a. Maybe a
Nothing
      Bool
True -> do
        [(var, Maybe VarIdent)]
origs <- (Context var -> [(var, Maybe VarIdent)])
-> ReaderT
     (Context var)
     (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
        TermT var
term <- TermT var
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) (TermT var)
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) (TermT var)
forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope TermT var
tope (TermT var
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT (TermT var -> TermT var -> TermT var -> TermT var
forall var. TermT var -> TermT var -> TermT var -> TermT var
appT TermT var
retType TermT var
f (var -> TermT var
forall (t :: * -> * -> *) a. a -> FS t a
Pure var
super)))
        String
label <- TermT var
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
term ReaderT
  (Context var) (Except (TypeErrorInScopedContext var)) (TermT var)
-> (TermT var
    -> ReaderT
         (Context var) (Except (TypeErrorInScopedContext var)) String)
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) String
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          UniverseTopeT{} -> String
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) String
forall a.
a
-> ReaderT (Context var) (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) (Except (TypeErrorInScopedContext var)) String
forall a.
a
-> ReaderT (Context var) (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) (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) (Except (TypeErrorInScopedContext var)) String
forall var. Eq var => TermT var -> TypeCheck var String
ppTermInContext TermT var
term
        String
color <- 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) (Except (TypeErrorInScopedContext var)) String)
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) String
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Bool
True -> do
            case TermT var
term of
              Pure{} -> String
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) String
forall a.
a
-> ReaderT (Context var) (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) (Except (TypeErrorInScopedContext var)) String
forall a.
a
-> ReaderT (Context var) (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) (Except (TypeErrorInScopedContext var)) String
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return String
"purple"
              TermT var
_ -> String
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) String
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return String
mainColor
          Bool
False -> String
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) String
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return String
"gray"
        Maybe ([String], RenderObjectData)
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (Maybe ([String], RenderObjectData))
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ([String], RenderObjectData)
 -> ReaderT
      (Context var)
      (Except (TypeErrorInScopedContext var))
      (Maybe ([String], RenderObjectData)))
-> Maybe ([String], RenderObjectData)
-> ReaderT
     (Context var)
     (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
label
          , renderObjectDataFullLabel :: String
renderObjectDataFullLabel = String
label
          , renderObjectDataColor :: String
renderObjectDataColor = String
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
  [([String], RenderObjectData)]
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)]
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
  String -> TypeCheck var String
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> TypeCheck var String) -> String -> TypeCheck var String
forall a b. (a -> b) -> a -> b
$ Camera Double
-> Double -> (String -> Maybe RenderObjectData) -> String
forall a.
(Floating a, Show a) =>
Camera a -> a -> (String -> Maybe RenderObjectData) -> String
renderCube Camera Double
forall a. Floating a => Camera a
defaultCamera (if Int
dim Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2 then (Double
forall a. Floating a => a
piDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
7) else Double
0) ((String -> Maybe RenderObjectData) -> String)
-> (String -> Maybe RenderObjectData) -> String
forall a b. (a -> b) -> a -> b
$ \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
  [([String], RenderObjectData)]
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)]
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
  String -> TypeCheck var String
forall a.
a
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> TypeCheck var String) -> String -> TypeCheck var String
forall a b. (a -> b) -> a -> b
$ Camera Double
-> Double -> (String -> Maybe RenderObjectData) -> String
forall a.
(Floating a, Show a) =>
Camera a -> a -> (String -> Maybe RenderObjectData) -> String
renderCube Camera Double
forall a. Floating a => Camera a
defaultCamera (if Int
dim Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2 then (Double
forall a. Floating a => a
piDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
7) else Double
0) ((String -> Maybe RenderObjectData) -> String)
-> (String -> Maybe RenderObjectData) -> String
forall a b. (a -> b) -> a -> b
$ \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
  TermT var
t' <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
t
  TermT var
ty <- TermT var -> TypeCheck var (TermT var)
forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
t'
  case TermT var
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 -> TypeCheck var (Maybe String))
-> TypeCheck var (Maybe String)
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      TypeFunT TypeInfo (TermT var)
_ Maybe VarIdent
fOrig 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
        Maybe VarIdent
-> TermT var
-> TypeCheck (Inc var) (Maybe String)
-> TypeCheck var (Maybe String)
forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
fOrig TermT var
fArg (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
$ 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))
     (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))
     (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) (Except (TypeErrorInScopedContext var)) String)
-> Maybe (TermT var, TermT var) -> TypeCheck 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) (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{} | [var] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [var]
xs -> Maybe VarIdent
-> TermT var
-> TypeCheck (Inc var) (Maybe String)
-> TypeCheck var (Maybe String)
forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope (VarIdent -> Maybe VarIdent
forall a. a -> Maybe a
Just VarIdent
"_") TermT var
t' (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
$ 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 -> TypeCheck var (Maybe String))
-> TypeCheck var (Maybe String)
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        TypeFunT TypeInfo (TermT var)
_ Maybe VarIdent
fOrig 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
          Maybe VarIdent
-> TermT var
-> TypeCheck (Inc var) (Maybe String)
-> TypeCheck var (Maybe String)
forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
fOrig TermT var
fArg (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
$ 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))
     (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))
     (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) (Except (TypeErrorInScopedContext var)) String)
-> Maybe (TermT var, TermT var) -> TypeCheck 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) (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{} | [var] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [var]
xs -> Maybe VarIdent
-> TermT var
-> TypeCheck (Inc var) (Maybe String)
-> TypeCheck var (Maybe String)
forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope (VarIdent -> Maybe VarIdent
forall a. a -> Maybe a
Just VarIdent
"_") TermT var
t' (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
$ 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)
_ Maybe VarIdent
orig 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 -> Maybe VarIdent
-> TermT var
-> TypeCheck (Inc var) (Maybe String)
-> TypeCheck var (Maybe String)
forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig TermT var
arg (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
$ 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)
_ Maybe VarIdent
_orig Maybe (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 -> Maybe VarIdent
-> TermT var
-> TypeCheck (Inc var) (Maybe String)
-> TypeCheck var (Maybe String)
forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig TermT var
arg (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
$ 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)
_ Maybe VarIdent
_orig Maybe (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) (Except (TypeErrorInScopedContext var)) String)
-> Maybe (TermT var, TermT var) -> TypeCheck 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) (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

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)
         (Except (TypeErrorInScopedContext var))
         (Maybe String))
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (Maybe String)
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (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)
         (Except (TypeErrorInScopedContext var))
         (Maybe String))
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (Maybe String)
forall a b.
ReaderT (Context var) (Except (TypeErrorInScopedContext var)) a
-> (a
    -> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b)
-> ReaderT (Context var) (Except (TypeErrorInScopedContext var)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  TypeFunT TypeInfo (TermT var)
_ Maybe VarIdent
orig TermT var
arg Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope Scope (FS (AnnF TypeInfo TermF)) var
ret -> Maybe VarIdent
-> TermT var
-> TypeCheck (Inc var) (Maybe String)
-> ReaderT
     (Context var)
     (Except (TypeErrorInScopedContext var))
     (Maybe String)
forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig TermT var
arg (TypeCheck (Inc var) (Maybe String)
 -> ReaderT
      (Context var)
      (Except (TypeErrorInScopedContext var))
      (Maybe String))
-> TypeCheck (Inc var) (Maybe String)
-> ReaderT
     (Context var)
     (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)
_ Maybe VarIdent
_orig Maybe (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)) (Except (TypeErrorInScopedContext (Inc var))) a
-> (a
    -> ReaderT
         (Context (Inc var))
         (Except (TypeErrorInScopedContext (Inc var)))
         b)
-> ReaderT
     (Context (Inc var)) (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)
_ Maybe VarIdent
fOrig 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
            Maybe VarIdent
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TypeCheck (Inc (Inc var)) (Maybe String)
-> TypeCheck (Inc var) (Maybe String)
forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
fOrig 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)))
     (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)))
     (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))
     (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))
     (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)
     (Except (TypeErrorInScopedContext var))
     (Maybe String)
forall a.
a
-> ReaderT (Context var) (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))
     (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))
     (Except (TypeErrorInScopedContext (Inc var)))
     String
-> ReaderT
     (Context (Inc var))
     (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))
     (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))
     (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
renderObjectDataLabel :: RenderObjectData -> String
renderObjectDataFullLabel :: RenderObjectData -> String
renderObjectDataColor :: 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
renderObjectDataLabel :: RenderObjectData -> String
renderObjectDataFullLabel :: RenderObjectData -> String
renderObjectDataColor :: 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
renderObjectDataLabel :: RenderObjectData -> String
renderObjectDataFullLabel :: RenderObjectData -> String
renderObjectDataColor :: 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
renderObjectDataLabel :: RenderObjectData -> String
renderObjectDataFullLabel :: RenderObjectData -> String
renderObjectDataColor :: 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
  }