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

import           Control.Applicative      ((<|>))
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' forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall e a. Except e a -> Either e a
runExcept (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT TypeCheck var a
tc 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]
  }

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 = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a b. (a, b) -> b
snd [(String, [Decl'])]
cached
  forall a. [Decl'] -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclsPrepared [Decl']
decls 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
    forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, [Decl'])]
cached 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
  [] -> 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]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ([(String
path, [Decl']
decls)], [TypeErrorInScopedContext VarIdent]
errs)
      [TypeErrorInScopedContext VarIdent]
_ -> do
        forall a. [Decl'] -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclsPrepared [Decl']
decls 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
          forall (m :: * -> *) a. Monad m => a -> m a
return ((String
path, [Decl']
decls) 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
  [] -> 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
        forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError TypeErrorInScopedContext VarIdent
err
      [] -> forall a. [Decl'] -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclsPrepared [Decl']
decls forall a b. (a -> b) -> a -> b
$
        ((String
path, [Decl']
decls) forall a. a -> [a] -> [a]
:) 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
  [] -> 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 forall a. Maybe a
Nothing Module
m
    if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TypeErrorInScopedContext VarIdent]
errs
      then
        forall a. [Decl'] -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclsPrepared [Decl']
decls forall a b. (a -> b) -> a -> b
$
          ([Decl']
decls forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Module] -> TypeCheck VarIdent [Decl']
typecheckModules [Module]
ms
      else
        forall (m :: * -> *) a. Monad m => a -> m a
return [Decl']
decls

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

countCommands :: Integral a => [Rzk.Command] -> a
countCommands :: forall a. Integral a => [Command] -> a
countCommands = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. Maybe a
Nothing (Integer
-> [Command]
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
go Integer
1 [Command]
commands) forall a b. (a -> b) -> a -> b
$ -- FIXME: use module name? or anonymous section?
    forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
  where
    totalCommands :: Integer
totalCommands = 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 [] = 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
      forall var a.
Verbosity -> String -> TypeCheck var a -> TypeCheck var a
traceTypeCheck Verbosity
Normal (String
"[ " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Integer
i forall a. Semigroup a => a -> a -> a
<> String
" out of " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Integer
totalCommands forall a. Semigroup a => a -> a -> a
<> String
" ]"
          forall a. Semigroup a => a -> a -> a
<> String
" Unsetting option " forall a. Semigroup a => a -> a -> a
<> String
optionName) forall a b. (a -> b) -> a -> b
$ do
        Command
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
withCommand Command
command forall a b. (a -> b) -> a -> b
$ do
          forall var a. String -> TypeCheck var a -> TypeCheck var a
unsetOption String
optionName forall a b. (a -> b) -> a -> b
$
            Integer
-> [Command]
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
go (Integer
i 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
      forall var a.
Verbosity -> String -> TypeCheck var a -> TypeCheck var a
traceTypeCheck Verbosity
Normal (String
"[ " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Integer
i forall a. Semigroup a => a -> a -> a
<> String
" out of " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Integer
totalCommands forall a. Semigroup a => a -> a -> a
<> String
" ]"
          forall a. Semigroup a => a -> a -> a
<> String
" Setting option " forall a. Semigroup a => a -> a -> a
<> String
optionName forall a. Semigroup a => a -> a -> a
<> String
" = " forall a. Semigroup a => a -> a -> a
<> String
optionValue ) forall a b. (a -> b) -> a -> b
$ do
        Command
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
withCommand Command
command forall a b. (a -> b) -> a -> b
$ do
          forall var a.
String -> String -> TypeCheck var a -> TypeCheck var a
setOption String
optionName String
optionValue forall a b. (a -> b) -> a -> b
$
            Integer
-> [Command]
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
go (Integer
i 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) =
      forall var a.
Verbosity -> String -> TypeCheck var a -> TypeCheck var a
traceTypeCheck Verbosity
Normal (String
"[ " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Integer
i forall a. Semigroup a => a -> a -> a
<> String
" out of " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Integer
totalCommands forall a. Semigroup a => a -> a -> a
<> String
" ]"
          forall a. Semigroup a => a -> a -> a
<> String
" Checking #define " forall a. Semigroup a => a -> a -> a
<> forall a. Print a => a -> String
Rzk.printTree VarIdent' BNFC'Position
name ) forall a b. (a -> b) -> a -> b
$ do
        Command
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
withCommand Command
command forall a b. (a -> b) -> a -> b
$ do
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall var. Eq var => var -> TypeCheck var ()
checkDefinedVar (Maybe String -> VarIdent' BNFC'Position -> VarIdent
varIdentAt Maybe String
path forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VarIdent' BNFC'Position]
vars)
          [ParamDecl]
paramDecls <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall var. Param' BNFC'Position -> TypeCheck var [ParamDecl]
paramToParamDecl [Param' BNFC'Position]
params
          TermT VarIdent
ty' <- 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)) forall var. TermT var
universeT forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT
          TermT VarIdent
term' <- 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' forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT
          let decl :: Decl'
decl = forall var.
var -> TermT var -> Maybe (TermT var) -> Bool -> [var] -> Decl var
Decl (Maybe String -> VarIdent' BNFC'Position -> VarIdent
varIdentAt Maybe String
path VarIdent' BNFC'Position
name) TermT VarIdent
ty' (forall a. a -> Maybe a
Just TermT VarIdent
term') Bool
False (Maybe String -> VarIdent' BNFC'Position -> VarIdent
varIdentAt Maybe String
path forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VarIdent' BNFC'Position]
vars)
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Decl'
decl forall a. a -> [a] -> [a]
:)) forall a b. (a -> b) -> a -> b
$
            forall a. Decl' -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclPrepared Decl'
decl 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
renderBackend :: forall var. Context var -> Maybe RenderBackend
covariance :: forall var. Context var -> Covariance
verbosity :: forall var. Context var -> Verbosity
location :: forall var. Context var -> Maybe LocationInfo
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]
renderBackend :: Maybe RenderBackend
covariance :: Covariance
verbosity :: Verbosity
location :: Maybe LocationInfo
currentCommand :: Maybe Command
actionStack :: [Action VarIdent]
localTopesEntailBottom :: Bool
localTopesNFUnion :: [[TermT VarIdent]]
localTopesNF :: [TermT VarIdent]
localTopes :: [TermT VarIdent]
localScopes :: [ScopeInfo VarIdent]
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
              Maybe String
termSVG <-
                case Maybe RenderBackend
renderBackend of
                  Just RenderBackend
RenderSVG -> forall var. Eq var => TermT var -> TypeCheck var (Maybe String)
renderTermSVG (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 -> forall var a. TypeError var -> TypeCheck var a
issueTypeError forall a b. (a -> b) -> a -> b
$ forall var. String -> TypeError var
TypeErrorOther String
"\"latex\" rendering is not yet supported"
                  Maybe RenderBackend
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
              forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall a. String -> a -> a
trace Maybe String
termSVG forall a b. (a -> b) -> a -> b
$ do
                Integer
-> [Command]
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
go (Integer
i 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) =
      forall var a.
Verbosity -> String -> TypeCheck var a -> TypeCheck var a
traceTypeCheck Verbosity
Normal (String
"[ " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Integer
i forall a. Semigroup a => a -> a -> a
<> String
" out of " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Integer
totalCommands forall a. Semigroup a => a -> a -> a
<> String
" ]"
          forall a. Semigroup a => a -> a -> a
<> String
" Checking #postulate " forall a. Semigroup a => a -> a -> a
<> forall a. Print a => a -> String
Rzk.printTree VarIdent' BNFC'Position
name) forall a b. (a -> b) -> a -> b
$ do
        Command
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
withCommand Command
command forall a b. (a -> b) -> a -> b
$ do
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall var. Eq var => var -> TypeCheck var ()
checkDefinedVar (Maybe String -> VarIdent' BNFC'Position -> VarIdent
varIdentAt Maybe String
path forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VarIdent' BNFC'Position]
vars)
          [ParamDecl]
paramDecls <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall var. Param' BNFC'Position -> TypeCheck var [ParamDecl]
paramToParamDecl [Param' BNFC'Position]
params
          TermT VarIdent
ty' <- 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)) forall var. TermT var
universeT forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT
          let decl :: Decl'
decl = forall var.
var -> TermT var -> Maybe (TermT var) -> Bool -> [var] -> Decl var
Decl (Maybe String -> VarIdent' BNFC'Position -> VarIdent
varIdentAt Maybe String
path VarIdent' BNFC'Position
name) TermT VarIdent
ty' forall a. Maybe a
Nothing Bool
False (Maybe String -> VarIdent' BNFC'Position -> VarIdent
varIdentAt Maybe String
path forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VarIdent' BNFC'Position]
vars)
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Decl'
decl forall a. a -> [a] -> [a]
:)) forall a b. (a -> b) -> a -> b
$
            forall a. Decl' -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclPrepared Decl'
decl forall a b. (a -> b) -> a -> b
$
              Integer
-> [Command]
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
go (Integer
i 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) =
      forall var a.
Verbosity -> String -> TypeCheck var a -> TypeCheck var a
traceTypeCheck Verbosity
Normal (String
"[ " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Integer
i forall a. Semigroup a => a -> a -> a
<> String
" out of " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Integer
totalCommands forall a. Semigroup a => a -> a -> a
<> String
" ]"
          forall a. Semigroup a => a -> a -> a
<> String
" Checking " forall a. Semigroup a => a -> a -> a
<> forall a. Print a => a -> String
Rzk.printTree Term' BNFC'Position
term forall a. Semigroup a => a -> a -> a
<> String
" : " forall a. Semigroup a => a -> a -> a
<> forall a. Print a => a -> String
Rzk.printTree Term' BNFC'Position
ty ) forall a b. (a -> b) -> a -> b
$ do
        Command
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
withCommand Command
command forall a b. (a -> b) -> a -> b
$ do
          TermT VarIdent
ty' <- forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck (Term' BNFC'Position -> Term VarIdent
toTerm' Term' BNFC'Position
ty) forall var. TermT var
universeT forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT
          TermT VarIdent
_term' <- 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 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 (forall a. a -> Term' a -> Command' a
Rzk.CommandComputeWHNF BNFC'Position
loc Term' BNFC'Position
term forall a. a -> [a] -> [a]
: [Command]
moreCommands)

    go  Integer
i (command :: Command
command@(Rzk.CommandComputeNF BNFC'Position
_loc Term' BNFC'Position
term) : [Command]
moreCommands) =
      forall var a.
Verbosity -> String -> TypeCheck var a -> TypeCheck var a
traceTypeCheck Verbosity
Normal (String
"[ " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Integer
i forall a. Semigroup a => a -> a -> a
<> String
" out of " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Integer
totalCommands forall a. Semigroup a => a -> a -> a
<> String
" ]"
          forall a. Semigroup a => a -> a -> a
<> String
" Computing NF for " forall a. Semigroup a => a -> a -> a
<> forall a. Print a => a -> String
Rzk.printTree Term' BNFC'Position
term) forall a b. (a -> b) -> a -> b
$ do
        Command
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
withCommand Command
command forall a b. (a -> b) -> a -> b
$ do
          TermT VarIdent
term' <- forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer (Term' BNFC'Position -> Term VarIdent
toTerm' Term' BNFC'Position
term) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT
          forall var a.
Verbosity -> String -> TypeCheck var a -> TypeCheck var a
traceTypeCheck Verbosity
Normal (String
"  " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
term')) forall a b. (a -> b) -> a -> b
$ do
            Integer
-> [Command]
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
go (Integer
i 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) =
      forall var a.
Verbosity -> String -> TypeCheck var a -> TypeCheck var a
traceTypeCheck Verbosity
Normal (String
"[ " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Integer
i forall a. Semigroup a => a -> a -> a
<> String
" out of " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Integer
totalCommands forall a. Semigroup a => a -> a -> a
<> String
" ]"
          forall a. Semigroup a => a -> a -> a
<> String
" Computing WHNF for " forall a. Semigroup a => a -> a -> a
<> forall a. Print a => a -> String
Rzk.printTree Term' BNFC'Position
term) forall a b. (a -> b) -> a -> b
$ do
        Command
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
withCommand Command
command forall a b. (a -> b) -> a -> b
$ do
          TermT VarIdent
term' <- forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer (Term' BNFC'Position -> Term VarIdent
toTerm' Term' BNFC'Position
term) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT
          forall var a.
Verbosity -> String -> TypeCheck var a -> TypeCheck var a
traceTypeCheck Verbosity
Normal (String
"  " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
term')) forall a b. (a -> b) -> a -> b
$ do
            Integer
-> [Command]
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
go (Integer
i 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) =
      forall var a.
Verbosity -> String -> TypeCheck var a -> TypeCheck var a
traceTypeCheck Verbosity
Normal (String
"[ " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Integer
i forall a. Semigroup a => a -> a -> a
<> String
" out of " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Integer
totalCommands forall a. Semigroup a => a -> a -> a
<> String
" ]"
          forall a. Semigroup a => a -> a -> a
<> String
" Checking #assume " forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [[a]] -> [a]
intercalate String
" " [ forall a. Print a => a -> String
Rzk.printTree VarIdent' BNFC'Position
name | VarIdent' BNFC'Position
name <- [VarIdent' BNFC'Position]
names ] ) forall a b. (a -> b) -> a -> b
$ do
        Command
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
withCommand Command
command forall a b. (a -> b) -> a -> b
$ do
          TermT VarIdent
ty' <- forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck (Term' BNFC'Position -> Term VarIdent
toTerm' Term' BNFC'Position
ty) forall var. TermT var
universeT
          let decls :: [Decl']
decls = [ forall var.
var -> TermT var -> Maybe (TermT var) -> Bool -> [var] -> Decl var
Decl (Maybe String -> VarIdent' BNFC'Position -> VarIdent
varIdentAt Maybe String
path VarIdent' BNFC'Position
name) TermT VarIdent
ty' forall a. Maybe a
Nothing Bool
True [] | VarIdent' BNFC'Position
name <- [VarIdent' BNFC'Position]
names ]
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ([Decl']
decls forall a. Semigroup a => a -> a -> a
<>)) forall a b. (a -> b) -> a -> b
$
            forall a. [Decl'] -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclsPrepared [Decl']
decls forall a b. (a -> b) -> a -> b
$
              Integer
-> [Command]
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
go (Integer
i 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 forall a b. (a -> b) -> a -> b
$ do
        ([Command]
sectionCommands, [Command]
moreCommands') <- 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 (forall a. a -> Maybe a
Just SectionName
name) (Integer
-> [Command]
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
go Integer
i [Command]
sectionCommands) forall a b. (a -> b) -> a -> b
$ do
          Integer
-> [Command]
-> TypeCheck
     VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
go (Integer
i forall a. Num a => a -> a -> a
+ 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 forall a b. (a -> b) -> a -> b
$
        forall var a. TypeError var -> TypeCheck var a
issueTypeError forall a b. (a -> b) -> a -> b
$ forall var. String -> TypeError var
TypeErrorOther forall a b. (a -> b) -> a -> b
$
          String
"unexpected #end " forall a. Semigroup a => a -> a -> a
<> forall a. Print a => a -> String
Rzk.printTree SectionName
endName 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 [] =
  forall var a. TypeError var -> TypeCheck var a
issueTypeError (forall var. String -> TypeError var
TypeErrorOther forall a b. (a -> b) -> a -> b
$ String
"Section " forall a. Semigroup a => a -> a -> a
<> forall a. Print a => a -> String
Rzk.printTree SectionName
name 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) <- forall var.
SectionName -> [Command] -> TypeCheck var ([Command], [Command])
splitSectionCommands SectionName
name' [Command]
moreCommands
  ([Command]
cs3, [Command]
cs4) <- forall var.
SectionName -> [Command] -> TypeCheck var ([Command], [Command])
splitSectionCommands SectionName
name [Command]
cs2
  forall (m :: * -> *) a. Monad m => a -> m a
return ([Command]
cs1 forall a. Semigroup a => a -> a -> a
<> [Command]
cs3, [Command]
cs4)
splitSectionCommands SectionName
name (Rzk.CommandSectionEnd BNFC'Position
_loc SectionName
endName : [Command]
moreCommands) = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Print a => a -> String
Rzk.printTree SectionName
name forall a. Eq a => a -> a -> Bool
/= forall a. Print a => a -> String
Rzk.printTree SectionName
endName) forall a b. (a -> b) -> a -> b
$
    forall var a. TypeError var -> TypeCheck var a
issueTypeError forall a b. (a -> b) -> a -> b
$ forall var. String -> TypeError var
TypeErrorOther forall a b. (a -> b) -> a -> b
$
      String
"unexpected #end " forall a. Semigroup a => a -> a -> a
<> forall a. Print a => a -> String
Rzk.printTree SectionName
endName forall a. Semigroup a => a -> a -> a
<> String
", expecting #end " forall a. Semigroup a => a -> a -> a
<> forall a. Print a => a -> String
Rzk.printTree SectionName
name
  forall (m :: * -> *) a. Monad m => a -> m a
return ([], [Command]
moreCommands)
splitSectionCommands SectionName
name (Command
command : [Command]
moreCommands) = do
  ([Command]
cs1, [Command]
cs2) <- forall var.
SectionName -> [Command] -> TypeCheck var ([Command], [Command])
splitSectionCommands SectionName
name [Command]
moreCommands
  forall (m :: * -> *) a. Monad m => a -> m a
return (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"   -> forall var a. Verbosity -> TypeCheck var a -> TypeCheck var a
localVerbosity Verbosity
Debug
  String
"normal"  -> forall var a. Verbosity -> TypeCheck var a -> TypeCheck var a
localVerbosity Verbosity
Normal
  String
"silent"  -> forall var a. Verbosity -> TypeCheck var a -> TypeCheck var a
localVerbosity Verbosity
Silent
  String
_ -> forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$
    forall var a. TypeError var -> TypeCheck var a
issueTypeError forall a b. (a -> b) -> a -> b
$ forall var. String -> TypeError var
TypeErrorOther String
"unknown verbosity level (use \"debug\", \"normal\", or \"silent\")"
setOption String
"render" = \case
  String
"svg"   -> forall var a.
Maybe RenderBackend -> TypeCheck var a -> TypeCheck var a
localRenderBackend (forall a. a -> Maybe a
Just RenderBackend
RenderSVG)
  String
"latex" -> forall var a.
Maybe RenderBackend -> TypeCheck var a -> TypeCheck var a
localRenderBackend (forall a. a -> Maybe a
Just RenderBackend
RenderLaTeX)
  String
"none"  -> forall var a.
Maybe RenderBackend -> TypeCheck var a -> TypeCheck var a
localRenderBackend forall a. Maybe a
Nothing
  String
_ -> forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$
    forall var a. TypeError var -> TypeCheck var a
issueTypeError forall a b. (a -> b) -> a -> b
$ forall var. String -> TypeError var
TypeErrorOther String
"unknown render backend (use \"svg\", \"latex\", or \"none\")"
setOption String
optionName = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$
  forall var a. TypeError var -> TypeCheck var a
issueTypeError forall a b. (a -> b) -> a -> b
$ forall var. String -> TypeError var
TypeErrorOther (String
"unknown option " forall a. Semigroup a => a -> a -> a
<> 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" = forall var a. Verbosity -> TypeCheck var a -> TypeCheck var a
localVerbosity (forall var. Context var -> Verbosity
verbosity forall var. Context var
emptyContext)
unsetOption String
optionName = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$
  forall var a. TypeError var -> TypeCheck var a
issueTypeError forall a b. (a -> b) -> a -> b
$ forall var. String -> TypeError var
TypeErrorOther (String
"unknown option " forall a. Semigroup a => a -> a -> a
<> 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) = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  [ 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) = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  [ 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) = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  [ 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{} = forall var a. TypeError var -> TypeCheck var a
issueTypeError forall a b. (a -> b) -> a -> b
$
  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 [] = forall a. a -> a
id
addParamDecls (ParamDecl
paramDecl : [ParamDecl]
paramDecls)
  = forall a. a -> ParamDecl' a -> Term' a -> Term' a
Rzk.TypeFun forall a. Maybe a
Nothing ParamDecl
paramDecl 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 []     = forall a. a -> a
id
addParams [Param' BNFC'Position]
params = forall a. a -> [Param' a] -> Term' a -> Term' a
Rzk.Lambda 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 -> 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
<$ :: forall a b. a -> TypeError b -> TypeError a
$c<$ :: forall a b. a -> TypeError b -> TypeError a
fmap :: forall a b. (a -> b) -> TypeError a -> TypeError b
$cfmap :: forall a b. (a -> b) -> TypeError a -> TypeError b
Functor, 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
product :: forall a. Num a => TypeError a -> a
$cproduct :: forall a. Num a => TypeError a -> a
sum :: forall a. Num a => TypeError a -> a
$csum :: forall a. Num a => TypeError a -> a
minimum :: forall a. Ord a => TypeError a -> a
$cminimum :: forall a. Ord a => TypeError a -> a
maximum :: forall a. Ord a => TypeError a -> a
$cmaximum :: forall a. Ord a => TypeError a -> a
elem :: forall a. Eq a => a -> TypeError a -> Bool
$celem :: forall a. Eq a => a -> TypeError a -> Bool
length :: forall a. TypeError a -> Int
$clength :: forall a. TypeError a -> Int
null :: forall a. TypeError a -> Bool
$cnull :: forall a. TypeError a -> Bool
toList :: forall a. TypeError a -> [a]
$ctoList :: forall a. TypeError a -> [a]
foldl1 :: forall a. (a -> a -> a) -> TypeError a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> TypeError a -> a
foldr1 :: forall a. (a -> a -> a) -> TypeError a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> TypeError a -> a
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
$cfoldl :: forall b a. (b -> a -> 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
$cfoldr :: forall a b. (a -> b -> b) -> b -> TypeError a -> b
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
$cfoldMap :: forall m a. Monoid m => (a -> m) -> TypeError a -> m
fold :: forall m. Monoid m => TypeError m -> m
$cfold :: forall m. Monoid m => TypeError m -> m
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 -> 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
<$ :: forall a b. a -> TypeErrorInContext b -> TypeErrorInContext a
$c<$ :: forall a b. a -> TypeErrorInContext b -> TypeErrorInContext a
fmap :: forall a b.
(a -> b) -> TypeErrorInContext a -> TypeErrorInContext b
$cfmap :: forall a b.
(a -> b) -> TypeErrorInContext a -> TypeErrorInContext b
Functor, 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
product :: forall a. Num a => TypeErrorInContext a -> a
$cproduct :: forall a. Num a => TypeErrorInContext a -> a
sum :: forall a. Num a => TypeErrorInContext a -> a
$csum :: forall a. Num a => TypeErrorInContext a -> a
minimum :: forall a. Ord a => TypeErrorInContext a -> a
$cminimum :: forall a. Ord a => TypeErrorInContext a -> a
maximum :: forall a. Ord a => TypeErrorInContext a -> a
$cmaximum :: forall a. Ord a => TypeErrorInContext a -> a
elem :: forall a. Eq a => a -> TypeErrorInContext a -> Bool
$celem :: forall a. Eq a => a -> TypeErrorInContext a -> Bool
length :: forall a. TypeErrorInContext a -> Int
$clength :: forall a. TypeErrorInContext a -> Int
null :: forall a. TypeErrorInContext a -> Bool
$cnull :: forall a. TypeErrorInContext a -> Bool
toList :: forall a. TypeErrorInContext a -> [a]
$ctoList :: forall a. TypeErrorInContext a -> [a]
foldl1 :: forall a. (a -> a -> a) -> TypeErrorInContext a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> TypeErrorInContext a -> a
foldr1 :: forall a. (a -> a -> a) -> TypeErrorInContext a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> TypeErrorInContext a -> a
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
$cfoldl :: forall b a. (b -> a -> 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
$cfoldr :: forall a b. (a -> b -> b) -> b -> TypeErrorInContext a -> b
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
$cfoldMap :: forall m a. Monoid m => (a -> m) -> TypeErrorInContext a -> m
fold :: forall m. Monoid m => TypeErrorInContext m -> m
$cfold :: forall m. Monoid m => TypeErrorInContext m -> m
Foldable)

data TypeErrorInScopedContext var
  = PlainTypeError (TypeErrorInContext var)
  | ScopedTypeError (Maybe VarIdent) (TypeErrorInScopedContext (Inc var))
  deriving (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
<$ :: forall a b.
a -> TypeErrorInScopedContext b -> TypeErrorInScopedContext a
$c<$ :: forall a b.
a -> TypeErrorInScopedContext b -> TypeErrorInScopedContext a
fmap :: forall a b.
(a -> b)
-> TypeErrorInScopedContext a -> TypeErrorInScopedContext b
$cfmap :: forall a b.
(a -> b)
-> TypeErrorInScopedContext a -> TypeErrorInScopedContext b
Functor, 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
product :: forall a. Num a => TypeErrorInScopedContext a -> a
$cproduct :: forall a. Num a => TypeErrorInScopedContext a -> a
sum :: forall a. Num a => TypeErrorInScopedContext a -> a
$csum :: forall a. Num a => TypeErrorInScopedContext a -> a
minimum :: forall a. Ord a => TypeErrorInScopedContext a -> a
$cminimum :: forall a. Ord a => TypeErrorInScopedContext a -> a
maximum :: forall a. Ord a => TypeErrorInScopedContext a -> a
$cmaximum :: forall a. Ord a => TypeErrorInScopedContext a -> a
elem :: forall a. Eq a => a -> TypeErrorInScopedContext a -> Bool
$celem :: forall a. Eq a => a -> TypeErrorInScopedContext a -> Bool
length :: forall a. TypeErrorInScopedContext a -> Int
$clength :: forall a. TypeErrorInScopedContext a -> Int
null :: forall a. TypeErrorInScopedContext a -> Bool
$cnull :: forall a. TypeErrorInScopedContext a -> Bool
toList :: forall a. TypeErrorInScopedContext a -> [a]
$ctoList :: forall a. TypeErrorInScopedContext a -> [a]
foldl1 :: forall a. (a -> a -> a) -> TypeErrorInScopedContext a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> TypeErrorInScopedContext a -> a
foldr1 :: forall a. (a -> a -> a) -> TypeErrorInScopedContext a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> TypeErrorInScopedContext a -> a
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
$cfoldl :: forall b a. (b -> a -> 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
$cfoldr :: forall a b. (a -> b -> b) -> b -> TypeErrorInScopedContext a -> b
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
$cfoldMap :: forall m a. Monoid m => (a -> m) -> TypeErrorInScopedContext a -> m
fold :: forall m. Monoid m => TypeErrorInScopedContext m -> m
$cfold :: forall m. Monoid m => TypeErrorInScopedContext m -> m
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
"  " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (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
"  " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
actual)
    , String
"for term"
    , String
"  " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (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
"  " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
expected)
    , String
"with term"
    , String
"  " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (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
"  " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
ty)
    , String
"for term"
    , String
"  " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (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
"  " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Term VarIdent
term
    , String
"when typechecking against a non-function type"
    , String
"  " forall a. Semigroup a => a -> a -> a
<> 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
"  " forall a. Semigroup a => a -> a -> a
<> 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
"  " forall a. Semigroup a => a -> a -> a
<> 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
"  " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Term VarIdent
term
    , String
"when typechecking against a type that is not an identity type"
    , String
"  " forall a. Semigroup a => a -> a -> a
<> 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
"  " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
ty)
    , String
"for term"
    , String
"  " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (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  " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
f) 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
"  " forall a. Semigroup a => a -> a -> a
<> 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
"  " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Term VarIdent
term
    ]
  TypeErrorUndefined VarIdent
var -> OutputDirection -> [String] -> String
block OutputDirection
TopDown
    [ String
"undefined variable: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (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
"  " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (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)"
    , forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" (forall a b. (a -> b) -> [a] -> [b]
map (String
"  " forall a. Semigroup a => a -> a -> a
<>) (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [TermT VarIdent]
topes))
    , forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" (forall a b. (a -> b) -> [a] -> [b]
map (String
"  " forall a. Semigroup a => a -> a -> a
<>) (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show (forall var. Eq var => [TermT var] -> [TermT var]
generateTopesForPoints (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
"  " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
expected)
    , String
"but got"
    , String
"  " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (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
"  " forall a. Semigroup a => a -> a -> a
<> 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
"  " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (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
"  " forall a. Semigroup a => a -> a -> a
<> VarIdent -> String
ppVarIdentWithLocation VarIdent
lastName
    , String
"previous top-level definitions found at"
    , forall a. [a] -> [[a]] -> [a]
intercalate String
"\n"
      [ 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
"  " forall a. Semigroup a => a -> a -> a
<> forall a. Print a => a -> String
Rzk.printTree (VarIdent -> VarIdent' RzkPosition
getVarIdent VarIdent
name) forall a. Semigroup a => a -> a -> a
<> String
" : " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (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
"  " forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [[a]] -> [a]
intercalate String
" " (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Print a => a -> String
Rzk.printTree forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarIdent -> VarIdent' RzkPosition
getVarIdent) [VarIdent]
vars)
    , String
"declared as used in definition of"
    , String
"  " forall a. Semigroup a => a -> a -> a
<> 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
"  " forall a. Semigroup a => a -> a -> a
<> forall a. Print a => a -> String
Rzk.printTree (VarIdent -> VarIdent' RzkPosition
getVarIdent VarIdent
a) forall a. Semigroup a => a -> a -> a
<> String
" : " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (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
"  " forall a. Semigroup a => a -> a -> a
<> 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
typeErrorContext :: Context VarIdent
typeErrorError :: TypeError VarIdent
typeErrorContext :: forall var. TypeErrorInContext var -> Context var
typeErrorError :: forall var. TypeErrorInContext var -> TypeError var
..} = 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 -> forall {t}. Maybe VarIdent -> ((VarIdent, [VarIdent]) -> t) -> t
withFresh Maybe VarIdent
orig forall a b. (a -> b) -> a -> b
$ \(VarIdent
x, [VarIdent]
xs) ->
    OutputDirection
-> [VarIdent]
-> [VarIdent]
-> TypeErrorInScopedContext VarIdent
-> String
ppTypeErrorInScopedContextWith' OutputDirection
dir (VarIdent
xforall a. a -> [a] -> [a]
:[VarIdent]
used) [VarIdent]
xs forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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]
_    -> forall a. String -> a
panicImpossible String
"not enough fresh variables"
    withFresh (Just VarIdent
z) (VarIdent, [VarIdent]) -> t
f = (VarIdent, [VarIdent]) -> t
f (VarIdent
z', forall a. (a -> Bool) -> [a] -> [a]
filter (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 forall a. Eq a => [a] -> [a] -> [a]
\\ [VarIdent]
vars) TypeErrorInScopedContext VarIdent
err
  where
    vars :: [VarIdent]
vars = forall a. Eq a => [a] -> [a]
nub (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap 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
  forall a. String -> a -> a
trace (String
"Warning: " forall a. Semigroup a => a -> a -> a
<> String
message) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. Monad m => a -> m a
return ()

issueTypeError :: TypeError var -> TypeCheck var a
issueTypeError :: forall var a. TypeError var -> TypeCheck var a
issueTypeError TypeError var
err = do
  Context var
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ forall var. TypeErrorInContext var -> TypeErrorInScopedContext var
PlainTypeError forall a b. (a -> b) -> a -> b
$ TypeErrorInContext
    { typeErrorError :: TypeError var
typeErrorError = TypeError var
err
    , typeErrorContext :: Context var
typeErrorContext = Context var
context
    }

panicImpossible :: String -> a
panicImpossible :: forall a. String -> a
panicImpossible String
msg = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
  [ String
"PANIC! Impossible happened (" forall a. Semigroup a => a -> a -> a
<> String
msg 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 -> 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
<$ :: forall a b. a -> Action b -> Action a
$c<$ :: forall a b. a -> Action b -> Action a
fmap :: forall a b. (a -> b) -> Action a -> Action b
$cfmap :: forall a b. (a -> b) -> Action a -> Action b
Functor, 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
product :: forall a. Num a => Action a -> a
$cproduct :: forall a. Num a => Action a -> a
sum :: forall a. Num a => Action a -> a
$csum :: forall a. Num a => Action a -> a
minimum :: forall a. Ord a => Action a -> a
$cminimum :: forall a. Ord a => Action a -> a
maximum :: forall a. Ord a => Action a -> a
$cmaximum :: forall a. Ord a => Action a -> a
elem :: forall a. Eq a => a -> Action a -> Bool
$celem :: forall a. Eq a => a -> Action a -> Bool
length :: forall a. Action a -> Int
$clength :: forall a. Action a -> Int
null :: forall a. Action a -> Bool
$cnull :: forall a. Action a -> Bool
toList :: forall a. Action a -> [a]
$ctoList :: forall a. Action a -> [a]
foldl1 :: forall a. (a -> a -> a) -> Action a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Action a -> a
foldr1 :: forall a. (a -> a -> a) -> Action a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Action a -> a
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
$cfoldl :: forall b a. (b -> a -> 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
$cfoldr :: forall a b. (a -> b -> b) -> b -> Action a -> b
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
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Action a -> m
fold :: forall m. Monoid m => Action m -> m
$cfold :: forall m. Monoid m => Action m -> m
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 <- forall var. Eq var => TermT var -> TypeCheck var [var]
freeVarsT_ TermT var
term
  let mapping :: [(var, VarIdent)]
mapping = 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 = forall a. a -> Maybe a -> a
fromMaybe VarIdent
"_" forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup var
var [(var, Maybe VarIdent)]
origs) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup var
var [(var, VarIdent)]
mapping
  [(var, Maybe VarIdent)]
origs <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall var. Context var -> [(var, Maybe VarIdent)]
varOrigs
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Show a => a -> String
show (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 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Action var
action)
  where
    vars :: [var]
vars = forall a. Eq a => [a] -> [a]
nub (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall (f :: * -> *) a. Applicative f => a -> f a
pure Action var
action)
    mapping :: [(var, VarIdent)]
mapping = forall a b. [a] -> [b] -> [(a, b)]
zip [var]
vars [VarIdent]
defaultVarIdents
    toRzkVarIdent :: var -> VarIdent
toRzkVarIdent var
var = forall a. a -> Maybe a -> a
fromMaybe VarIdent
"_" forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup var
var [(var, Maybe VarIdent)]
origs) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. Int -> a -> [a]
replicate (Int
2 forall a. Num a => a -> a -> a
* Int
n) Char
' ' forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
  ActionTypeCheck Term VarIdent
term TermT VarIdent
ty ->
    [ String
"typechecking"
    , String
"  " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Term VarIdent
term
    , String
"against type"
    , String
"  " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (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
"  " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (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
"  " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
actual)
    , String
"for term"
    , String
"  " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (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
"  " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show TermT VarIdent
expected
    , String
"with term"
    , String
"  " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show TermT VarIdent
actual ]

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

  ActionContextEntailedBy [TermT VarIdent]
ctxTopes TermT VarIdent
term ->
    [ String
"checking if local context"
    , forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" (forall a b. (a -> b) -> [a] -> [b]
map ((String
"  " forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
"  " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (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"
    , forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" (forall a b. (a -> b) -> [a] -> [b]
map ((String
"  " forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
"  " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (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"
    , forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" (forall a b. (a -> b) -> [a] -> [b]
map ((String
"  " forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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"
    , forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" (forall a b. (a -> b) -> [a] -> [b]
map ((String
"  " forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
"  " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show TermT VarIdent
term ]

  ActionNF TermT VarIdent
term ->
    [ String
"computing normal form for term"
    , String
"  " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (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
"  " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
ltope)
    , String
"  |-> " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
lterm)
    , String
"and"
    , String
"  " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT VarIdent
rtope)
    , String
"  |-> " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (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 " forall a. Semigroup a => a -> a -> a
<> 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 = forall a. String -> a -> a
trace (String
"[debug]\n" 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 = forall a. Int -> Action VarIdent -> a -> a
traceAction' Int
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b
unsafeCoerce

data LocationInfo = LocationInfo
  { LocationInfo -> Maybe String
locationFilePath :: Maybe FilePath
  , LocationInfo -> Maybe Int
locationLine     :: Maybe Int
  }

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

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

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

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 -> 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
<$ :: forall a b. a -> ScopeInfo b -> ScopeInfo a
$c<$ :: forall a b. a -> ScopeInfo b -> ScopeInfo a
fmap :: forall a b. (a -> b) -> ScopeInfo a -> ScopeInfo b
$cfmap :: forall a b. (a -> b) -> ScopeInfo a -> ScopeInfo b
Functor, 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
product :: forall a. Num a => ScopeInfo a -> a
$cproduct :: forall a. Num a => ScopeInfo a -> a
sum :: forall a. Num a => ScopeInfo a -> a
$csum :: forall a. Num a => ScopeInfo a -> a
minimum :: forall a. Ord a => ScopeInfo a -> a
$cminimum :: forall a. Ord a => ScopeInfo a -> a
maximum :: forall a. Ord a => ScopeInfo a -> a
$cmaximum :: forall a. Ord a => ScopeInfo a -> a
elem :: forall a. Eq a => a -> ScopeInfo a -> Bool
$celem :: forall a. Eq a => a -> ScopeInfo a -> Bool
length :: forall a. ScopeInfo a -> Int
$clength :: forall a. ScopeInfo a -> Int
null :: forall a. ScopeInfo a -> Bool
$cnull :: forall a. ScopeInfo a -> Bool
toList :: forall a. ScopeInfo a -> [a]
$ctoList :: forall a. ScopeInfo a -> [a]
foldl1 :: forall a. (a -> a -> a) -> ScopeInfo a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> ScopeInfo a -> a
foldr1 :: forall a. (a -> a -> a) -> ScopeInfo a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> ScopeInfo a -> a
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
$cfoldl :: forall b a. (b -> a -> 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
$cfoldr :: forall a b. (a -> b -> b) -> b -> ScopeInfo a -> b
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
$cfoldMap :: forall m a. Monoid m => (a -> m) -> ScopeInfo a -> m
fold :: forall m. Monoid m => ScopeInfo m -> m
$cfold :: forall m. Monoid m => ScopeInfo m -> m
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
scopeVars :: [(var, VarInfo var)]
scopeName :: Maybe SectionName
scopeVars :: forall var. ScopeInfo var -> [(var, VarInfo var)]
scopeName :: forall var. ScopeInfo var -> Maybe SectionName
..} = ScopeInfo
  { scopeVars :: [(var, VarInfo var)]
scopeVars = (var
var, VarInfo var
info) 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]
  } deriving (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
<$ :: forall a b. a -> VarInfo b -> VarInfo a
$c<$ :: forall a b. a -> VarInfo b -> VarInfo a
fmap :: forall a b. (a -> b) -> VarInfo a -> VarInfo b
$cfmap :: forall a b. (a -> b) -> VarInfo a -> VarInfo b
Functor, 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
product :: forall a. Num a => VarInfo a -> a
$cproduct :: forall a. Num a => VarInfo a -> a
sum :: forall a. Num a => VarInfo a -> a
$csum :: forall a. Num a => VarInfo a -> a
minimum :: forall a. Ord a => VarInfo a -> a
$cminimum :: forall a. Ord a => VarInfo a -> a
maximum :: forall a. Ord a => VarInfo a -> a
$cmaximum :: forall a. Ord a => VarInfo a -> a
elem :: forall a. Eq a => a -> VarInfo a -> Bool
$celem :: forall a. Eq a => a -> VarInfo a -> Bool
length :: forall a. VarInfo a -> Int
$clength :: forall a. VarInfo a -> Int
null :: forall var. VarInfo var -> Bool
$cnull :: forall var. VarInfo var -> Bool
toList :: forall var. VarInfo var -> [var]
$ctoList :: forall var. VarInfo var -> [var]
foldl1 :: forall a. (a -> a -> a) -> VarInfo a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> VarInfo a -> a
foldr1 :: forall a. (a -> a -> a) -> VarInfo a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> VarInfo a -> a
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
$cfoldl :: forall b a. (b -> a -> 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
$cfoldr :: forall a b. (a -> b -> b) -> b -> VarInfo a -> b
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
$cfoldMap :: forall m a. Monoid m => (a -> m) -> VarInfo a -> m
fold :: forall m. Monoid m => VarInfo m -> m
$cfold :: forall m. Monoid m => VarInfo m -> m
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 -> 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
<$ :: forall a b. a -> Context b -> Context a
$c<$ :: forall a b. a -> Context b -> Context a
fmap :: forall a b. (a -> b) -> Context a -> Context b
$cfmap :: forall a b. (a -> b) -> Context a -> Context b
Functor, 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
product :: forall a. Num a => Context a -> a
$cproduct :: forall a. Num a => Context a -> a
sum :: forall a. Num a => Context a -> a
$csum :: forall a. Num a => Context a -> a
minimum :: forall a. Ord a => Context a -> a
$cminimum :: forall a. Ord a => Context a -> a
maximum :: forall a. Ord a => Context a -> a
$cmaximum :: forall a. Ord a => Context a -> a
elem :: forall a. Eq a => a -> Context a -> Bool
$celem :: forall a. Eq a => a -> Context a -> Bool
length :: forall a. Context a -> Int
$clength :: forall a. Context a -> Int
null :: forall var. Context var -> Bool
$cnull :: forall var. Context var -> Bool
toList :: forall a. Context a -> [a]
$ctoList :: forall a. Context a -> [a]
foldl1 :: forall a. (a -> a -> a) -> Context a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Context a -> a
foldr1 :: forall a. (a -> a -> a) -> Context a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Context a -> a
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
$cfoldl :: forall b a. (b -> a -> 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
$cfoldr :: forall a b. (a -> b -> b) -> b -> Context a -> b
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
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Context a -> m
fold :: forall m. Monoid m => Context m -> m
$cfold :: forall m. Monoid m => Context m -> m
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
renderBackend :: Maybe RenderBackend
covariance :: Covariance
verbosity :: Verbosity
location :: Maybe LocationInfo
currentCommand :: Maybe Command
actionStack :: [Action var]
localTopesEntailBottom :: Bool
localTopesNFUnion :: [[TermT var]]
localTopesNF :: [TermT var]
localTopes :: [TermT var]
localScopes :: [ScopeInfo var]
renderBackend :: forall var. Context var -> Maybe RenderBackend
covariance :: forall var. Context var -> Covariance
verbosity :: forall var. Context var -> Verbosity
location :: forall var. Context var -> Maybe LocationInfo
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]
..} = Context
  { localScopes :: [ScopeInfo var]
localScopes =
      case [ScopeInfo var]
localScopes of
        []             -> [forall var.
Maybe SectionName -> [(var, VarInfo var)] -> ScopeInfo var
ScopeInfo forall a. Maybe a
Nothing [(var
var, VarInfo var
info)]]
        ScopeInfo var
scope : [ScopeInfo var]
scopes -> forall var. var -> VarInfo var -> ScopeInfo var -> ScopeInfo var
addVarToScope var
var VarInfo var
info ScopeInfo var
scope forall a. a -> [a] -> [a]
: [ScopeInfo var]
scopes
  , Bool
[[TermT var]]
[TermT var]
[Action var]
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
renderBackend :: Maybe RenderBackend
covariance :: Covariance
verbosity :: Verbosity
location :: Maybe LocationInfo
currentCommand :: Maybe Command
actionStack :: [Action var]
localTopesEntailBottom :: Bool
localTopesNFUnion :: [[TermT var]]
localTopesNF :: [TermT var]
localTopes :: [TermT var]
renderBackend :: Maybe RenderBackend
covariance :: Covariance
verbosity :: Verbosity
location :: Maybe LocationInfo
currentCommand :: Maybe Command
actionStack :: [Action var]
localTopesEntailBottom :: Bool
localTopesNFUnion :: [[TermT var]]
localTopesNF :: [TermT var]
localTopes :: [TermT var]
.. }

emptyContext :: Context var
emptyContext :: forall var. Context var
emptyContext = Context
  { localScopes :: [ScopeInfo var]
localScopes = [forall var.
Maybe SectionName -> [(var, VarInfo var)] -> ScopeInfo var
ScopeInfo forall a. Maybe a
Nothing []]
  , localTopes :: [TermT var]
localTopes = [forall var. TermT var
topeTopT]
  , localTopesNF :: [TermT var]
localTopesNF = [forall var. TermT var
topeTopT]
  , localTopesNFUnion :: [[TermT var]]
localTopesNFUnion = [[forall var. TermT var
topeTopT]]
  , localTopesEntailBottom :: Bool
localTopesEntailBottom = Bool
False
  , actionStack :: [Action var]
actionStack = []
  , currentCommand :: Maybe Command
currentCommand = forall a. Maybe a
Nothing
  , location :: Maybe LocationInfo
location = forall a. Maybe a
Nothing
  , verbosity :: Verbosity
verbosity = Verbosity
Normal
  , covariance :: Covariance
covariance = Covariance
Covariant
  , renderBackend :: Maybe RenderBackend
renderBackend = forall a. Maybe a
Nothing
  }

askCurrentScope :: TypeCheck var (ScopeInfo var)
askCurrentScope :: forall var. TypeCheck var (ScopeInfo var)
askCurrentScope = forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall var. Context var -> [ScopeInfo var]
localScopes forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  []              -> forall a. String -> a
panicImpossible String
"no current scope available"
  ScopeInfo var
scope : [ScopeInfo var]
_scopes -> 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
renderBackend :: Maybe RenderBackend
covariance :: Covariance
verbosity :: Verbosity
location :: Maybe LocationInfo
currentCommand :: Maybe Command
actionStack :: [Action var]
localTopesEntailBottom :: Bool
localTopesNFUnion :: [[TermT var]]
localTopesNF :: [TermT var]
localTopes :: [TermT var]
localScopes :: [ScopeInfo var]
renderBackend :: forall var. Context var -> Maybe RenderBackend
covariance :: forall var. Context var -> Covariance
verbosity :: forall var. Context var -> Verbosity
location :: forall var. Context var -> Maybe LocationInfo
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]
..} = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap 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 = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall var. VarInfo var -> TermT var
varType) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall var. VarInfo var -> Maybe (TermT var)
varValue) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall var. Context var -> [(var, VarInfo var)]
varInfos

varOrigs :: Context var -> [(var, Maybe VarIdent)]
varOrigs :: forall var. Context var -> [(var, Maybe VarIdent)]
varOrigs = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall var. VarInfo var -> Maybe VarIdent
varOrig) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null [err]
errs
    then forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ([Decl']
decls forall a. Semigroup a => a -> a -> a
<>)
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [Decl'] -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclsPrepared [Decl']
decls TypeCheck VarIdent ([Decl'], [err])
next
    else 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 =
  forall err.
TypeCheck VarIdent ([Decl'], [err])
-> TypeCheck VarIdent ([Decl'], [err])
-> TypeCheck VarIdent ([Decl'], [err])
withPartialDecls forall a b. (a -> b) -> a -> b
$ forall a.
Maybe SectionName -> TypeCheck VarIdent a -> TypeCheck VarIdent a
startSection Maybe SectionName
name forall a b. (a -> b) -> a -> b
$ do
    ([Decl']
decls, [TypeErrorInScopedContext VarIdent]
errs) <- TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent])
sectionBody
    forall a. [Decl'] -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclsPrepared [Decl']
decls forall a b. (a -> b) -> a -> b
$
      forall var a.
Eq var =>
Action var -> TypeCheck var a -> TypeCheck var a
performing (forall var. Maybe SectionName -> Action var
ActionCloseSection Maybe SectionName
name) forall a b. (a -> b) -> a -> b
$ do
        (\ [Decl']
decls' -> ([Decl']
decls', [TypeErrorInScopedContext VarIdent]
errs)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TypeErrorInScopedContext VarIdent] -> TypeCheck VarIdent [Decl']
endSection [TypeErrorInScopedContext VarIdent]
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 = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local 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
renderBackend :: Maybe RenderBackend
covariance :: Covariance
verbosity :: Verbosity
location :: Maybe LocationInfo
currentCommand :: Maybe Command
actionStack :: [Action VarIdent]
localTopesEntailBottom :: Bool
localTopesNFUnion :: [[TermT VarIdent]]
localTopesNF :: [TermT VarIdent]
localTopes :: [TermT VarIdent]
localScopes :: [ScopeInfo VarIdent]
renderBackend :: forall var. Context var -> Maybe RenderBackend
covariance :: forall var. Context var -> Covariance
verbosity :: forall var. Context var -> Verbosity
location :: forall var. Context var -> Maybe LocationInfo
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]
..} -> Context
  { localScopes :: [ScopeInfo VarIdent]
localScopes = ScopeInfo { scopeName :: Maybe SectionName
scopeName = Maybe SectionName
name, scopeVars :: [(VarIdent, VarInfo VarIdent)]
scopeVars = [] } forall a. a -> [a] -> [a]
: [ScopeInfo VarIdent]
localScopes
  , Bool
[[TermT VarIdent]]
[TermT VarIdent]
[Action VarIdent]
Maybe Command
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
renderBackend :: Maybe RenderBackend
covariance :: Covariance
verbosity :: Verbosity
location :: Maybe LocationInfo
currentCommand :: Maybe Command
actionStack :: [Action VarIdent]
localTopesEntailBottom :: Bool
localTopesNFUnion :: [[TermT VarIdent]]
localTopesNF :: [TermT VarIdent]
localTopes :: [TermT VarIdent]
renderBackend :: Maybe RenderBackend
covariance :: Covariance
verbosity :: Verbosity
location :: Maybe LocationInfo
currentCommand :: Maybe Command
actionStack :: [Action VarIdent]
localTopesEntailBottom :: Bool
localTopesNFUnion :: [[TermT VarIdent]]
localTopesNF :: [TermT VarIdent]
localTopes :: [TermT VarIdent]
.. }

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

scopeToDecls :: Eq var => [TypeErrorInScopedContext VarIdent] -> ScopeInfo var -> TypeCheck var [Decl var]
scopeToDecls :: forall var.
Eq var =>
[TypeErrorInScopedContext VarIdent]
-> ScopeInfo var -> TypeCheck var [Decl var]
scopeToDecls [TypeErrorInScopedContext VarIdent]
errs ScopeInfo{[(var, VarInfo var)]
Maybe SectionName
scopeVars :: [(var, VarInfo var)]
scopeName :: Maybe SectionName
scopeVars :: forall var. ScopeInfo var -> [(var, VarInfo var)]
scopeName :: forall var. ScopeInfo var -> Maybe SectionName
..} = do
  [Decl var]
decls <- forall var.
Eq var =>
[TypeErrorInScopedContext VarIdent]
-> [(var, VarInfo var)]
-> [(var, VarInfo var)]
-> TypeCheck var [Decl var]
collectScopeDecls [TypeErrorInScopedContext VarIdent]
errs [] [(var, VarInfo var)]
scopeVars
  -- only issue unused variable errors if there were no errors prior in the section
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TypeErrorInScopedContext VarIdent]
errs) forall a b. (a -> b) -> a -> b
$ do
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Decl var]
decls forall a b. (a -> b) -> a -> b
$ \Decl{var
Bool
[var]
Maybe (TermT var)
TermT var
declUsedVars :: [var]
declIsAssumption :: Bool
declValue :: Maybe (TermT var)
declType :: TermT var
declName :: var
declUsedVars :: forall var. Decl var -> [var]
declIsAssumption :: forall var. Decl var -> Bool
declValue :: forall var. Decl var -> Maybe (TermT var)
declType :: forall var. Decl var -> TermT var
declName :: forall var. Decl var -> var
..} -> do
      let unusedUsedVars :: [var]
unusedUsedVars = [var]
declUsedVars forall a. Eq a => [a] -> [a] -> [a]
`intersect` forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(var, VarInfo var)]
scopeVars
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [var]
unusedUsedVars)) forall a b. (a -> b) -> a -> b
$
        forall var a. TypeError var -> TypeCheck var a
issueTypeError forall a b. (a -> b) -> a -> b
$ forall var. [var] -> var -> TypeError var
TypeErrorUnusedUsedVariables [var]
unusedUsedVars var
declName
  forall (m :: * -> *) a. Monad m => a -> m a
return [Decl var]
decls

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
TermT var
varDeclaredAssumptions :: [var]
varIsAssumption :: Bool
varOrig :: Maybe VarIdent
varValue :: Maybe (TermT var)
varType :: TermT var
varDeclaredAssumptions :: forall var. VarInfo var -> [var]
varIsAssumption :: forall var. VarInfo var -> Bool
varOrig :: forall var. VarInfo var -> Maybe VarIdent
varValue :: forall var. VarInfo var -> Maybe (TermT var)
varType :: forall var. VarInfo var -> TermT var
..}) TermT var
term =
  TermT var
term forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    var
y | var
y forall a. Eq a => a -> a -> Bool
== var
declName -> forall var. TermT var -> TermT var -> TermT var -> TermT var
appT TermT var
varType (forall (t :: * -> * -> *) a. a -> FS t a
Pure var
declName) (forall (t :: * -> * -> *) a. a -> FS t a
Pure var
a)
      | Bool
otherwise     -> 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
TermT var
varDeclaredAssumptions :: [var]
varIsAssumption :: Bool
varOrig :: Maybe VarIdent
varValue :: Maybe (TermT var)
varType :: TermT var
varDeclaredAssumptions :: forall var. VarInfo var -> [var]
varIsAssumption :: forall var. VarInfo var -> Bool
varOrig :: forall var. VarInfo var -> Maybe VarIdent
varValue :: forall var. VarInfo var -> Maybe (TermT var)
varType :: forall var. VarInfo var -> TermT var
..}
  | Bool
varIsAssumption = VarInfo{Bool
[var]
Maybe (TermT var)
Maybe VarIdent
TermT var
varDeclaredAssumptions :: [var]
varIsAssumption :: Bool
varOrig :: Maybe VarIdent
varValue :: Maybe (TermT var)
varType :: TermT var
varDeclaredAssumptions :: [var]
varIsAssumption :: Bool
varOrig :: Maybe VarIdent
varValue :: Maybe (TermT var)
varType :: TermT var
..}
  | Bool
otherwise = VarInfo
      { varType :: TermT var
varType = 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 = forall var.
Eq var =>
var -> (var, VarInfo var) -> TermT var -> TermT var
insertExplicitAssumptionFor var
a (var, VarInfo var)
decl 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
      }

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)
_ [] = 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 <- forall var. Eq var => TermT var -> TypeCheck var [var]
freeVarsT_ (forall var. VarInfo var -> TermT var
varType VarInfo var
xInfo)
  [var]
varsInBody <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall var. Eq var => TermT var -> TypeCheck var [var]
freeVarsT_ (forall var. VarInfo var -> Maybe (TermT var)
varValue VarInfo var
xInfo)
  let xFreeVars :: [var]
xFreeVars = [var]
varsInBody forall a. Semigroup a => a -> a -> a
<> [var]
varsInType
  let hasAssumption :: Bool
hasAssumption = var
a forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [var]
xFreeVars
  TermT var
xType <- forall var. Eq var => var -> TypeCheck var (TermT var)
typeOfVar var
x
  Maybe (TermT var)
xValue <- forall var. Eq var => var -> TypeCheck var (Maybe (TermT var))
valueOfVar var
x
  let assumptionInType :: Bool
assumptionInType = var
a forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a. Term a -> [a]
freeVars (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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a. Term a -> [a]
freeVars forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped) Maybe (TermT var)
xValue
      implicitAssumption :: Bool
implicitAssumption = forall (t :: * -> *). Foldable t => t Bool -> Bool
and
        [ Bool
hasAssumption
        , Bool -> Bool
not (Bool
assumptionInType Bool -> Bool -> Bool
|| Bool
assumptionInBody)
        , var
a forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` forall var. VarInfo var -> [var]
varDeclaredAssumptions VarInfo var
xInfo ]
  if Bool
hasAssumption
     then do
       forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
implicitAssumption forall a b. (a -> b) -> a -> b
$ do
         forall var a. TypeError var -> TypeCheck var a
issueTypeError forall a b. (a -> b) -> a -> b
$ forall var. (var, TermT var) -> var -> TypeError var
TypeErrorImplicitAssumption (var
a, forall var. VarInfo var -> TermT var
varType VarInfo var
aInfo) var
x
       (Bool
_used, [(var, VarInfo var)]
xs'') <- 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'
       forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True {- USED -}, (var
x, VarInfo var
xInfo') forall a. a -> [a] -> [a]
: [(var, VarInfo var)]
xs'')
     else do
       (Bool
used, [(var, VarInfo var)]
xs'') <- 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
       forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
used, (var
x, VarInfo var
xInfo) forall a. a -> [a] -> [a]
: [(var, VarInfo var)]
xs'')
  where
    xType' :: TermT var
xType' = forall var.
Maybe VarIdent
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeFunT (forall var. VarInfo var -> Maybe VarIdent
varOrig VarInfo var
aInfo) (forall var. VarInfo var -> TermT var
varType VarInfo var
aInfo) forall a. Maybe a
Nothing (forall a (f :: * -> *). (Eq a, Functor f) => a -> f a -> f (Inc a)
abstract var
a (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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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' (forall var. VarInfo var -> Maybe VarIdent
varOrig VarInfo var
aInfo) forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (f :: * -> *). (Eq a, Functor f) => a -> f a -> f (Inc a)
abstract var
a) (forall var. VarInfo var -> Maybe (TermT var)
varValue VarInfo var
xInfo)
      , varIsAssumption :: Bool
varIsAssumption = forall var. VarInfo var -> Bool
varIsAssumption VarInfo var
xInfo
      , varOrig :: Maybe VarIdent
varOrig = forall var. VarInfo var -> Maybe VarIdent
varOrig VarInfo var
xInfo
      , varDeclaredAssumptions :: [var]
varDeclaredAssumptions = forall var. VarInfo var -> [var]
varDeclaredAssumptions VarInfo var
xInfo forall a. Eq a => [a] -> [a] -> [a]
\\ [var
a]
      }
    xs' :: [(var, VarInfo var)]
xs' = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 VarIdent] -> [(var, VarInfo var)] -> [(var, VarInfo var)] -> TypeCheck var [Decl var]
collectScopeDecls :: forall var.
Eq var =>
[TypeErrorInScopedContext VarIdent]
-> [(var, VarInfo var)]
-> [(var, VarInfo var)]
-> TypeCheck var [Decl var]
collectScopeDecls [TypeErrorInScopedContext VarIdent]
errs [(var, VarInfo var)]
recentVars (decl :: (var, VarInfo var)
decl@(var
var, VarInfo{Bool
[var]
Maybe (TermT var)
Maybe VarIdent
TermT var
varDeclaredAssumptions :: [var]
varIsAssumption :: Bool
varOrig :: Maybe VarIdent
varValue :: Maybe (TermT var)
varType :: TermT var
varDeclaredAssumptions :: forall var. VarInfo var -> [var]
varIsAssumption :: forall var. VarInfo var -> Bool
varOrig :: forall var. VarInfo var -> Maybe VarIdent
varValue :: forall var. VarInfo var -> Maybe (TermT var)
varType :: forall var. VarInfo var -> TermT var
..}) : [(var, VarInfo var)]
vars)
  | Bool
varIsAssumption = do
      (Bool
used, [(var, VarInfo var)]
recentVars') <- 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
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TypeErrorInScopedContext VarIdent]
errs) forall a b. (a -> b) -> a -> b
$ do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
used) forall a b. (a -> b) -> a -> b
$ do
          forall var a. TypeError var -> TypeCheck var a
issueTypeError forall a b. (a -> b) -> a -> b
$ forall var. var -> TermT var -> TypeError var
TypeErrorUnusedVariable var
var TermT var
varType
      forall var.
Eq var =>
[TypeErrorInScopedContext VarIdent]
-> [(var, VarInfo var)]
-> [(var, VarInfo var)]
-> TypeCheck var [Decl var]
collectScopeDecls [TypeErrorInScopedContext VarIdent]
errs [(var, VarInfo var)]
recentVars' [(var, VarInfo var)]
vars
  | Bool
otherwise = do
      forall var.
Eq var =>
[TypeErrorInScopedContext VarIdent]
-> [(var, VarInfo var)]
-> [(var, VarInfo var)]
-> TypeCheck var [Decl var]
collectScopeDecls [TypeErrorInScopedContext VarIdent]
errs ((var, VarInfo var)
decl forall a. a -> [a] -> [a]
: [(var, VarInfo var)]
recentVars) [(var, VarInfo var)]
vars
collectScopeDecls [TypeErrorInScopedContext VarIdent]
_ [(var, VarInfo var)]
recentVars [] = forall (m :: * -> *) a. Monad m => a -> m a
return (forall {var}. (var, VarInfo var) -> Decl var
toDecl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(var, VarInfo var)]
recentVars)
  where
    toDecl :: (var, VarInfo var) -> Decl var
toDecl (var
var, VarInfo{Bool
[var]
Maybe (TermT var)
Maybe VarIdent
TermT var
varDeclaredAssumptions :: [var]
varIsAssumption :: Bool
varOrig :: Maybe VarIdent
varValue :: Maybe (TermT var)
varType :: TermT var
varDeclaredAssumptions :: forall var. VarInfo var -> [var]
varIsAssumption :: forall var. VarInfo var -> Bool
varOrig :: forall var. VarInfo var -> Maybe VarIdent
varValue :: forall var. VarInfo var -> Maybe (TermT var)
varType :: forall var. VarInfo var -> TermT var
..}) = 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
      }

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
TermT var
varDeclaredAssumptions :: [var]
varIsAssumption :: Bool
varOrig :: Maybe VarIdent
varValue :: Maybe (TermT var)
varType :: TermT var
varDeclaredAssumptions :: forall var. VarInfo var -> [var]
varIsAssumption :: forall var. VarInfo var -> Bool
varOrig :: forall var. VarInfo var -> Maybe VarIdent
varValue :: forall var. VarInfo var -> Maybe (TermT var)
varType :: forall var. VarInfo var -> TermT var
..}) Decl{var
Bool
[var]
Maybe (TermT var)
TermT var
declUsedVars :: [var]
declIsAssumption :: Bool
declValue :: Maybe (TermT var)
declType :: TermT var
declName :: var
declUsedVars :: forall var. Decl var -> [var]
declIsAssumption :: forall var. Decl var -> Bool
declValue :: forall var. Decl var -> Maybe (TermT var)
declType :: forall var. Decl var -> TermT var
declName :: forall var. Decl var -> var
..} = Decl
  { declName :: var
declName = var
declName
  , declType :: TermT var
declType = 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 forall a. Maybe a
Nothing (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 -> 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 forall a. Maybe a
Nothing (forall a (f :: * -> *). (Eq a, Functor f) => a -> f a -> f (Inc a)
abstract var
var TermT var
body)) 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
  }
  where
    newDeclType :: TermT var
newDeclType = 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 forall a. Maybe a
Nothing (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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OutputDirection -> OutputDirection -> Bool
$c/= :: OutputDirection -> OutputDirection -> Bool
== :: OutputDirection -> OutputDirection -> Bool
$c== :: OutputDirection -> OutputDirection -> Bool
Eq)

block :: OutputDirection -> [String] -> String
block :: OutputDirection -> [String] -> String
block OutputDirection
TopDown  = forall a. [a] -> [[a]] -> [a]
intercalate String
"\n"
block OutputDirection
BottomUp = forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a b. (a -> b) -> a -> b
$
  String
name forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map String -> String
indent [String]
lines_
  where
    indent :: String -> String
indent = forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a -> b) -> [a] -> [b]
map (String
"  " forall a. [a] -> [a] -> [a]
++)) 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
renderBackend :: Maybe RenderBackend
covariance :: Covariance
verbosity :: Verbosity
location :: Maybe LocationInfo
currentCommand :: Maybe Command
actionStack :: [Action VarIdent]
localTopesEntailBottom :: Bool
localTopesNFUnion :: [[TermT VarIdent]]
localTopesNF :: [TermT VarIdent]
localTopes :: [TermT VarIdent]
localScopes :: [ScopeInfo VarIdent]
renderBackend :: forall var. Context var -> Maybe RenderBackend
covariance :: forall var. Context var -> Covariance
verbosity :: forall var. Context var -> Verbosity
location :: forall var. Context var -> Maybe LocationInfo
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]
..} = OutputDirection -> [String] -> String
block OutputDirection
dir forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
dropWhile forall (t :: * -> *) a. Foldable t => t a -> Bool
null
  [ OutputDirection -> [String] -> String
block OutputDirection
TopDown
    [ case Maybe LocationInfo
location of
        Maybe LocationInfo
_ | OutputDirection
dir forall a. Eq a => a -> a -> Bool
== OutputDirection
TopDown -> String
"" -- FIXME
        Just (LocationInfo (Just String
path) (Just Int
lineNo)) ->
          String
path forall a. Semigroup a => a -> a -> a
<> String
" (line " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
lineNo forall a. Semigroup a => a -> a -> a
<> String
"):"
        Just (LocationInfo (Just String
path) Maybe Int
_) ->
          String
path 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 " forall a. Semigroup a => a -> a -> a
<> 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 " forall a. Semigroup a => a -> a -> a
<> 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    " forall a. Semigroup a => a -> a -> a
<> forall a. Print a => a -> String
Rzk.printTree Term' BNFC'Position
term forall a. Semigroup a => a -> a -> a
<> String
" : " forall a. Semigroup a => a -> a -> a
<> 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    " forall a. Semigroup a => a -> a -> a
<> 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    " forall a. Semigroup a => a -> a -> a
<> 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    " forall a. Semigroup a => a -> a -> a
<> 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 " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show String
optionName
        Just command :: Command
command@Rzk.CommandUnsetOption{} ->
          String
"  Error occurred when trying to unset option\n    " forall a. Semigroup a => a -> a -> a
<> forall a. Print a => a -> String
Rzk.printTree Command
command
        Just command :: Command
command@Rzk.CommandAssume{} ->
          String
"  Error occurred when checking assumption\n    " forall a. Semigroup a => a -> a -> a
<> 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 " forall a. Semigroup a => a -> a -> a
<> 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 " forall a. Semigroup a => a -> a -> a
<> forall a. Print a => a -> String
Rzk.printTree SectionName
name
        Maybe Command
Nothing -> String
"  Error occurred outside of any command!"
    ]
  , String
""
  , case forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= 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
"  " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (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 " 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
      [ forall a. Show a => a -> String
show (forall (t :: * -> * -> *) a. a -> FS t a
Pure VarIdent
x :: Term') forall a. Semigroup a => a -> a -> a
<> String
" : " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (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) <- forall a. [a] -> [a]
reverse (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 = forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a b. (a -> b) -> a -> b
$ \Context var
ctx ->
  forall a. (a -> Bool) -> [a] -> [a]
filter (VarIdent
name forall a. Eq a => a -> a -> Bool
==) (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a b. (a, b) -> b
snd (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
  forall var. VarIdent -> TypeCheck var [VarIdent]
doesShadowName VarIdent
name forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    []         -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [VarIdent]
collisions -> forall var a. TypeError var -> TypeCheck var a
issueTypeError forall a b. (a -> b) -> a -> b
$
      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
  forall var. VarIdent -> TypeCheck var [VarIdent]
doesShadowName VarIdent
name forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    [] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [VarIdent]
collisions -> forall var. String -> TypeCheck var ()
issueWarning forall a b. (a -> b) -> a -> b
$
      forall a. Print a => a -> String
Rzk.printTree (VarIdent -> VarIdent' RzkPosition
getVarIdent VarIdent
name) forall a. Semigroup a => a -> a -> a
<> String
" shadows an existing definition:"
      forall a. Semigroup a => a -> a -> a
<> [String] -> String
unlines
        [ String
"  " forall a. Semigroup a => a -> a -> a
<> VarIdent -> String
ppVarIdentWithLocation VarIdent
name
        , String
"previous top-level definitions found at"
        , forall a. [a] -> [[a]] -> [a]
intercalate String
"\n"
          [ 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 = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local 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
renderBackend :: Maybe RenderBackend
covariance :: Covariance
verbosity :: Verbosity
location :: Maybe LocationInfo
currentCommand :: Maybe Command
actionStack :: [Action var]
localTopesEntailBottom :: Bool
localTopesNFUnion :: [[TermT var]]
localTopesNF :: [TermT var]
localTopes :: [TermT var]
localScopes :: [ScopeInfo var]
renderBackend :: forall var. Context var -> Maybe RenderBackend
covariance :: forall var. Context var -> Covariance
verbosity :: forall var. Context var -> Verbosity
location :: forall var. Context var -> Maybe LocationInfo
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]
..} -> Context { location :: Maybe LocationInfo
location = 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]
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]
.. }

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

localDecls :: [Decl VarIdent] -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDecls :: forall a. [Decl'] -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDecls []             = forall a. a -> a
id
localDecls (Decl'
decl : [Decl']
decls) = forall a. Decl' -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDecl Decl'
decl forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 [] = forall a. a -> a
id
localDeclsPrepared (Decl'
decl : [Decl']
decls) = forall a. Decl' -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclPrepared Decl'
decl forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) TypeCheck VarIdent a
tc = do
  TermT VarIdent
ty' <- forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT VarIdent
ty
  Maybe (TermT VarIdent)
term' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT Maybe (TermT VarIdent)
term
  forall a. Decl' -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclPrepared (forall var.
var -> TermT var -> Maybe (TermT var) -> Bool -> [var] -> Decl var
Decl VarIdent
x TermT VarIdent
ty' Maybe (TermT VarIdent)
term' Bool
isAssumption [VarIdent]
vars) 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) TypeCheck VarIdent a
tc = do
  forall var. VarIdent -> TypeCheck var ()
checkTopLevelDuplicate VarIdent
x
  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  = 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 = forall a. a -> Maybe a
Just VarIdent
x
      , varIsAssumption :: Bool
varIsAssumption = Bool
isAssumption
      , varDeclaredAssumptions :: [VarIdent]
varDeclaredAssumptions = [VarIdent]
vars
      }

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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall var. Context var -> [(var, TermT var)]
varTypes
  let typeOfVar' :: var -> TermT var
typeOfVar' var
x =
        case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup var
x [(var, TermT var)]
types of
          Maybe (TermT var)
Nothing -> forall a. String -> a
panicImpossible String
"undefined variable"
          Just TermT var
ty -> TermT var
ty
  forall (m :: * -> *) a. Monad m => a -> m a
return (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 = forall a. String -> a -> a
trace (String
"start [" forall a. Semigroup a => a -> a -> a
<> String
tag forall a. Semigroup a => a -> a -> a
<> String
"]") forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  (\a
x -> forall a. String -> a -> a
trace (String
"finish [" forall a. Semigroup a => a -> a -> a
<> String
tag forall a. Semigroup a => a -> a -> a
<> String
"] with " forall a. Semigroup a => a -> a -> a
<> 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 = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall var. Eq var => [TermT var] -> TermT var -> Bool
`solveRHS` TermT var
tope) forall a b. (a -> b) -> a -> b
$
  forall var. Eq var => [TermT var] -> [TermT var] -> [TermT var]
saturateTopes (forall var. Eq var => TermT var -> [TermT var]
allTopePoints TermT var
tope) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    forall var. Eq var => [TermT var] -> [[TermT var]]
simplifyLHSwithDisjunctions [TermT var]
topes'
  where
    topes' :: [TermT var]
topes' = forall var. Eq var => [TermT var] -> [TermT var]
nubTermT ([TermT var]
topes forall a. Semigroup a => a -> a -> a
<> forall var. Eq var => [TermT var] -> [TermT var]
generateTopesForPoints (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'    = forall var. Eq var => [TermT var] -> [TermT var]
nubTermT [TermT var]
topes -- (topes <> genTopes)
      topes'' :: [[TermT var]]
topes''   = forall var. Eq var => [TermT var] -> [[TermT var]]
simplifyLHSwithDisjunctions [TermT var]
topes'
      topes''' :: [[TermT var]]
topes'''  = forall var. Eq var => [TermT var] -> [TermT var] -> [TermT var]
saturateTopes (forall var. Eq var => TermT var -> [TermT var]
allTopePoints TermT var
tope) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[TermT var]]
topes''
  [String]
prettyTopes <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall var. Eq var => TermT var -> TypeCheck var String
ppTermInContext (forall var. Eq var => [TermT var] -> [TermT var] -> [TermT var]
saturateTopes (forall var. Eq var => TermT var -> [TermT var]
allTopePoints TermT var
tope) (forall var. Eq var => [TermT var] -> [TermT var]
simplifyLHS [TermT var]
topes'))
  String
prettyTope <- forall var. Eq var => TermT var -> TypeCheck var String
ppTermInContext TermT var
tope
  forall var a.
Verbosity -> String -> TypeCheck var a -> TypeCheck var a
traceTypeCheck Verbosity
Debug
    (String
"entail " forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
prettyTopes forall a. Semigroup a => a -> a -> a
<> String
" |- " forall a. Semigroup a => a -> a -> a
<> String
prettyTope) forall a b. (a -> b) -> a -> b
$
      forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (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' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall var. Eq var => TermT var -> TypeCheck var String
ppTermInContext [TermT var]
topes
  String
tope' <- forall var. Eq var => TermT var -> TypeCheck var String
ppTermInContext TermT var
tope
  Bool
result <- forall a. String -> a -> a
trace (String
"entail " forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
topes' forall a. Semigroup a => a -> a -> a
<> String
" |- " forall a. Semigroup a => a -> a -> a
<> String
tope') forall a b. (a -> b) -> a -> b
$
        [TermT var]
topes forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
`entailM` TermT var
tope
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. String -> a -> a
trace (String
"  " forall a. Semigroup a => a -> a -> a
<> 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 forall a. a -> [a] -> [a]
: forall var. Eq var => [TermT var] -> [TermT var]
nubTermT (forall a. (a -> Bool) -> [a] -> [a]
filter (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 = forall a. (a -> [a] -> Bool) -> ([a] -> [a] -> [a]) -> [a] -> [a]
saturateWith
  (\TermT var
tope [TermT var]
ts -> TermT var
tope forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TermT var]
ts)
  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
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
new = [a]
lastNew
      | Bool
otherwise = [a]
lastNew forall a. Semigroup a => a -> a -> a
<> [a] -> [a] -> [a]
go [a]
new [a]
xs'
      where
        xs' :: [a]
xs' = [a]
lastNew forall a. Semigroup a => a -> a -> a
<> [a]
xs
        new :: [a]
new = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> [a] -> Bool
`elem'` [a]
xs')) ([a] -> [a]
nub' 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 forall a. a -> [a] -> [a]
: [a] -> [a]
nub' (forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not 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
  | forall var. TermT var
topeBottomT forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TermT var]
newTopes = []
  | forall var. TermT var -> TermT var -> TermT var
topeEQT forall var. TermT var
cube2_0T forall var. TermT var
cube2_1T forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TermT var]
newTopes = [forall var. TermT var
topeBottomT]
  | forall (t :: * -> *) a. Foldable t => t a -> Int
length [TermT var]
oldTopes forall a. Ord a => a -> a -> Bool
> Int
100 = []    -- FIXME
  | Bool
otherwise = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [  -- symmetry EQ
        [ 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)
      , [ 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' <- forall a. [a] -> [[a]]
tails [TermT var]
newTopes
        , TopeEQT TypeInfo (TermT var)
_ty TermT var
y' TermT var
z <- [TermT var]
newTopes' forall a. Semigroup a => a -> a -> a
<> [TermT var]
oldTopes
        , TermT var
y forall a. Eq a => a -> a -> Bool
== TermT var
y' ]
        -- transitivity EQ (2)
      , [ 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' <- forall a. [a] -> [[a]]
tails [TermT var]
newTopes
        , TopeEQT TypeInfo (TermT var)
_ty TermT var
x TermT var
y' <- [TermT var]
newTopes' forall a. Semigroup a => a -> a -> a
<> [TermT var]
oldTopes
        , TermT var
y forall a. Eq a => a -> a -> Bool
== TermT var
y' ]

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

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

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

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

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

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

        -- FIXME: consequence of LEM for LEQ and antisymmetry for LEQ
      , [ 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
      , [ 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 = forall var. Eq var => [TermT var] -> [TermT var]
nubTermT forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [ forall var. TermT var -> TermT var -> TermT var
topeOrT (forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
x TermT var
y) (forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
y TermT var
x)
    | TermT var
x : [TermT var]
points' <- forall a. [a] -> [[a]]
tails (forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [forall var. TermT var
cube2_0T, forall var. TermT var
cube2_1T]) [TermT var]
points)
    , TermT var
y <- [TermT var]
points'
    , TermT var
x 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 = forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [ (TermT var
x, TermT var
y)
          | TermT var
x : [TermT var]
points' <- forall a. [a] -> [[a]]
tails (forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [forall var. TermT var
cube2_0T, forall var. TermT var
cube2_1T]) [TermT var]
points)
          , TermT var
y <- [TermT var]
points'
          , TermT var
x forall a. Eq a => a -> a -> Bool
/= TermT var
y ]
        ]
  [[TermT var]]
topes <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(TermT var, TermT var)]
pairs forall a b. (a -> b) -> a -> b
$ \(TermT var
x, TermT var
y) -> do
    TermT var
xType <- forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
x
    TermT var
yType <- forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
y
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if (TermT var
xType forall a. Eq a => a -> a -> Bool
== forall var. TermT var
cube2T) Bool -> Bool -> Bool
&& (TermT var
yType forall a. Eq a => a -> a -> Bool
== forall var. TermT var
cube2T)
      then [forall var. TermT var -> TermT var -> TermT var
topeOrT (forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
x TermT var
y) (forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
y TermT var
x)]
      else []
  forall (m :: * -> *) a. Monad m => a -> m a
return (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 = forall var. Eq var => [TermT var] -> [TermT var]
nubTermT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall var. TermT var -> [TermT var]
subPoints forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall var. Eq var => [TermT var] -> [TermT var]
nubTermT forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 -> forall var. TermT var -> [TermT var]
topePoints TermT var
l forall a. Semigroup a => a -> a -> a
<> forall var. TermT var -> [TermT var]
topePoints TermT var
r
  TopeOrT  TypeInfo (TermT var)
_ TermT var
l TermT var
r -> forall var. TermT var -> [TermT var]
topePoints TermT var
l forall a. Semigroup a => a -> a -> a
<> 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 forall a. a -> [a] -> [a]
: forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap 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
infoNF :: forall term. TypeInfo term -> Maybe term
infoWHNF :: forall term. TypeInfo term -> Maybe term
infoType :: forall term. TypeInfo term -> term
infoNF :: Maybe (TermT var)
infoWHNF :: Maybe (TermT var)
infoType :: TermT var
..} 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 = forall a b. (a -> b) -> [a] -> [b]
map forall var. Eq var => [TermT var] -> [TermT var]
nubTermT forall a b. (a -> b) -> a -> b
$
  case [TermT var]
topes of
    [] -> [[]]
    TopeTopT{} : [TermT var]
topes' -> forall var. Eq var => [TermT var] -> [[TermT var]]
simplifyLHSwithDisjunctions [TermT var]
topes'
    TopeBottomT{} : [TermT var]
_  -> [[forall var. TermT var
topeBottomT]]
    TopeAndT TypeInfo (TermT var)
_ TermT var
l TermT var
r : [TermT var]
topes' -> forall var. Eq var => [TermT var] -> [[TermT var]]
simplifyLHSwithDisjunctions (TermT var
l forall a. a -> [a] -> [a]
: TermT var
r 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' -> forall var. Eq var => [TermT var] -> [[TermT var]]
simplifyLHSwithDisjunctions (TermT var
l forall a. a -> [a] -> [a]
: [TermT var]
topes') forall a. Semigroup a => a -> a -> a
<> forall var. Eq var => [TermT var] -> [[TermT var]]
simplifyLHSwithDisjunctions (TermT var
r 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' ->
      forall var. Eq var => [TermT var] -> [[TermT var]]
simplifyLHSwithDisjunctions (forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
x TermT var
x' forall a. a -> [a] -> [a]
: forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
y TermT var
y' forall a. a -> [a] -> [a]
: [TermT var]
topes')
    TermT var
t : [TermT var]
topes' -> forall a b. (a -> b) -> [a] -> [b]
map (TermT var
t forall a. a -> [a] -> [a]
:) (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 = forall var. Eq var => [TermT var] -> [TermT var]
nubTermT forall a b. (a -> b) -> a -> b
$
  case [TermT var]
topes of
    [] -> []
    TopeTopT{} : [TermT var]
topes' -> forall var. Eq var => [TermT var] -> [TermT var]
simplifyLHS [TermT var]
topes'
    TopeBottomT{} : [TermT var]
_  -> [forall var. TermT var
topeBottomT]
    TopeAndT TypeInfo (TermT var)
_ TermT var
l TermT var
r : [TermT var]
topes' -> forall var. Eq var => [TermT var] -> [TermT var]
simplifyLHS (TermT var
l forall a. a -> [a] -> [a]
: TermT var
r 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' ->
      forall var. Eq var => [TermT var] -> [TermT var]
simplifyLHS (forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
x TermT var
x' forall a. a -> [a] -> [a]
: forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
y TermT var
y' forall a. a -> [a] -> [a]
: [TermT var]
topes')
    TermT var
t : [TermT var]
topes' -> TermT var
t forall a. a -> [a] -> [a]
: 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
_ | forall var. TermT var
topeBottomT forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TermT var]
topes -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    TopeTopT{}     -> 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') ->
      forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
solveRHSM [TermT var]
topes forall a b. (a -> b) -> a -> b
$ forall var. TermT var -> TermT var -> TermT var
topeAndT
        (forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
x TermT var
x')
        (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 ->
      forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
solveRHSM [TermT var]
topes forall a b. (a -> b) -> a -> b
$ forall var. TermT var -> TermT var -> TermT var
topeAndT
        (forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
x (forall var. TermT var -> TermT var -> TermT var
firstT TermT var
cubeI TermT var
r))
        (forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
y (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) ->
      forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
solveRHSM [TermT var]
topes forall a b. (a -> b) -> a -> b
$ forall var. TermT var -> TermT var -> TermT var
topeAndT
        (forall var. TermT var -> TermT var -> TermT var
topeEQT (forall var. TermT var -> TermT var -> TermT var
firstT TermT var
cubeI TermT var
l) TermT var
x)
        (forall var. TermT var -> TermT var -> TermT var
topeEQT (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
      | forall (t :: * -> *). Foldable t => t Bool -> Bool
or
          [ TermT var
l forall a. Eq a => a -> a -> Bool
== TermT var
r
          , TermT var
tope forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TermT var]
topes
          , forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
r TermT var
l forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TermT var]
topes
          ] -> 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 forall a. Eq a => a -> a -> Bool
== TermT var
r -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      | forall var. Eq var => [TermT var] -> TermT var -> Bool
solveRHS [TermT var]
topes (forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
l TermT var
r) -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      | forall var. Eq var => [TermT var] -> TermT var -> Bool
solveRHS [TermT var]
topes (forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
l forall var. TermT var
cube2_0T) -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      | forall var. Eq var => [TermT var] -> TermT var -> Bool
solveRHS [TermT var]
topes (forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
r forall var. TermT var
cube2_1T) -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    TopeAndT TypeInfo (TermT var)
_ TermT var
l TermT var
r -> Bool -> Bool -> Bool
(&&)
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
solveRHSM [TermT var]
topes TermT var
l
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
solveRHSM [TermT var]
topes TermT var
r
    TermT var
_ | TermT var
tope forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TermT var]
topes -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    TopeOrT  TypeInfo (TermT var)
_ TermT var
l TermT var
r -> do
      Bool
l' <- forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
solveRHSM [TermT var]
topes TermT var
l
      Bool
r' <- 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 forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        else do
          [TermT var]
lems <- forall var. Eq var => [TermT var] -> TypeCheck var [TermT var]
generateTopesForPointsM (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, forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (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'' <- forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
solveRHSM (forall var. Eq var => [TermT var] -> [TermT var] -> [TermT var]
saturateTopes [] (TermT var
t1 forall a. a -> [a] -> [a]
: [TermT var]
topes)) TermT var
tope
              Bool
r'' <- forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
solveRHSM (forall var. Eq var => [TermT var] -> [TermT var] -> [TermT var]
saturateTopes [] (TermT var
t2 forall a. a -> [a] -> [a]
: [TermT var]
topes)) TermT var
tope
              forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
l'' Bool -> Bool -> Bool
&& Bool
r'')
            [TermT var]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    TermT var
_ -> 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
_ | forall var. TermT var
topeBottomT 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')
      | forall var. Eq var => [TermT var] -> TermT var -> Bool
solveRHS [TermT var]
topes (forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
x TermT var
x') Bool -> Bool -> Bool
&& forall var. Eq var => [TermT var] -> TermT var -> Bool
solveRHS [TermT var]
topes (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
      | forall var. Eq var => [TermT var] -> TermT var -> Bool
solveRHS [TermT var]
topes (forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
x (forall var. TermT var -> TermT var -> TermT var
firstT TermT var
cubeI TermT var
r)) Bool -> Bool -> Bool
&& forall var. Eq var => [TermT var] -> TermT var -> Bool
solveRHS [TermT var]
topes (forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
y (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)
      | forall var. Eq var => [TermT var] -> TermT var -> Bool
solveRHS [TermT var]
topes (forall var. TermT var -> TermT var -> TermT var
topeEQT (forall var. TermT var -> TermT var -> TermT var
firstT TermT var
cubeI TermT var
l) TermT var
x) Bool -> Bool -> Bool
&& forall var. Eq var => [TermT var] -> TermT var -> Bool
solveRHS [TermT var]
topes (forall var. TermT var -> TermT var -> TermT var
topeEQT (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 -> forall (t :: * -> *). Foldable t => t Bool -> Bool
or
      [ TermT var
l forall a. Eq a => a -> a -> Bool
== TermT var
r
      , TermT var
tope forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TermT var]
topes
      , forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
r TermT var
l 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 forall a. Eq a => a -> a -> Bool
== TermT var
r -> Bool
True
      | forall var. Eq var => [TermT var] -> TermT var -> Bool
solveRHS [TermT var]
topes (forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
l TermT var
r) -> Bool
True
      | forall var. Eq var => [TermT var] -> TermT var -> Bool
solveRHS [TermT var]
topes (forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
l forall var. TermT var
cube2_0T) -> Bool
True
      | forall var. Eq var => [TermT var] -> TermT var -> Bool
solveRHS [TermT var]
topes (forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
r forall var. TermT var
cube2_1T) -> Bool
True
    -- TopeBottomT{}  -> solveLHS topes tope
    TopeAndT TypeInfo (TermT var)
_ TermT var
l TermT var
r -> forall var. Eq var => [TermT var] -> TermT var -> Bool
solveRHS [TermT var]
topes TermT var
l Bool -> Bool -> 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 -> forall var. Eq var => [TermT var] -> TermT var -> Bool
solveRHS [TermT var]
topes TermT var
l Bool -> Bool -> Bool
|| forall var. Eq var => [TermT var] -> TermT var -> Bool
solveRHS [TermT var]
topes TermT var
r
    TermT var
_ -> TermT var
tope 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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall var. Context var -> [TermT var]
localTopes
  forall var a.
Eq var =>
Action var -> TypeCheck var a -> TypeCheck var a
performing (forall var. [TermT var] -> TermT var -> Action var
ActionContextEntails [TermT var]
ctxTopes TermT var
tope) forall a b. (a -> b) -> a -> b
$ do
    [TermT var]
topes' <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall var. Context var -> [TermT var]
localTopesNF
    TermT var
tope' <- forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
tope
    [TermT var]
topes' 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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall var. Context var -> [TermT var]
localTopes
  forall var a.
Eq var =>
Action var -> TypeCheck var a -> TypeCheck var a
performing (forall var. [TermT var] -> TermT var -> Action var
ActionContextEntailedBy [TermT var]
ctxTopes TermT var
tope) forall a b. (a -> b) -> a -> b
$ do
    [TermT var]
contextTopes <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall var. Context var -> [TermT var]
localTopesNF
    TermT var
restrictionTope <- forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
tope
    let contextTopesRHS :: TermT var
contextTopesRHS = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall var. TermT var -> TermT var -> TermT var
topeAndT forall var. TermT var
topeTopT [TermT var]
contextTopes
    [TermT var
restrictionTope] 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' <- forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
l
  TermT var
r' <- forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
r
  [TermT var
l'] 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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall var. Context var -> [TermT var]
localTopes
  forall var a.
Eq var =>
Action var -> TypeCheck var a -> TypeCheck var a
performing (forall var. [TermT var] -> TermT var -> Action var
ActionContextEntailedBy [TermT var]
ctxTopes TermT var
tope) forall a b. (a -> b) -> a -> b
$ do
    [TermT var]
contextTopes <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall var. Context var -> [TermT var]
localTopesNF
    TermT var
restrictionTope <- forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
tope
    let contextTopesRHS :: TermT var
contextTopesRHS = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall var. TermT var -> TermT var -> TermT var
topeOrT forall var. TermT var
topeBottomT [TermT var]
contextTopes
    [TermT var
restrictionTope] forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
`entailM` TermT var
contextTopesRHS forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
False -> forall var a. TypeError var -> TypeCheck var a
issueTypeError forall a b. (a -> b) -> a -> b
$ forall var. [TermT var] -> TermT var -> TypeError var
TypeErrorTopeNotSatisfied [TermT var
restrictionTope] TermT var
contextTopesRHS
      Bool
True -> 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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall var. Context var -> [TermT var]
localTopes
  forall var a.
Eq var =>
Action var -> TypeCheck var a -> TypeCheck var a
performing (forall var. [TermT var] -> TermT var -> Action var
ActionContextEntails [TermT var]
ctxTopes TermT var
tope) forall a b. (a -> b) -> a -> b
$ do
    Bool
topeIsEntailed <- forall var. Eq var => TermT var -> TypeCheck var Bool
checkTope TermT var
tope
    [TermT var]
topes' <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall var. Context var -> [TermT var]
localTopesNF
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
topeIsEntailed forall a b. (a -> b) -> a -> b
$
      forall var a. TypeError var -> TypeCheck var a
issueTypeError forall a b. (a -> b) -> a -> b
$ 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 = forall var a.
Eq var =>
Action var -> TypeCheck var a -> TypeCheck var a
performing (forall var. TermT var -> TermT var -> Action var
ActionUnifyTerms TermT var
expected TermT var
actual) forall a b. (a -> b) -> a -> b
$ do
  TermT var
expected' <- forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
expected
  TermT var
actual' <- forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
actual
  Bool -> Bool -> Bool
(&&)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TermT var
expected'] forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
`entailM` TermT var
actual'
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [TermT var
actual'] 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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall var. Context var -> [TermT var]
localTopes
  forall var a.
Eq var =>
Action var -> TypeCheck var a -> TypeCheck var a
performing (forall var. [TermT var] -> [TermT var] -> Action var
ActionContextEquiv [TermT var]
ctxTopes [TermT var]
topes) forall a b. (a -> b) -> a -> b
$ do
    [TermT var]
contextTopes <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall var. Context var -> [TermT var]
localTopesNF
    [TermT var]
recTopes <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope [TermT var]
topes
    let contextTopesRHS :: TermT var
contextTopesRHS = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall var. TermT var -> TermT var -> TermT var
topeOrT forall var. TermT var
topeBottomT [TermT var]
contextTopes
        recTopesRHS :: TermT var
recTopesRHS     = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall var. TermT var -> TermT var -> TermT var
topeOrT forall var. TermT var
topeBottomT [TermT var]
recTopes
    [TermT var]
contextTopes forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
`entailM` TermT var
recTopesRHS forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
False -> forall var a. TypeError var -> TypeCheck var a
issueTypeError forall a b. (a -> b) -> a -> b
$ forall var. [TermT var] -> TermT var -> TypeError var
TypeErrorTopeNotSatisfied [TermT var]
contextTopes TermT var
recTopesRHS
      Bool
True -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [TermT var]
recTopes forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
`entailM` TermT var
contextTopesRHS forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
False -> forall var a. TypeError var -> TypeCheck var a
issueTypeError forall a b. (a -> b) -> a -> b
$ forall var. [TermT var] -> TermT var -> TypeError var
TypeErrorTopeNotSatisfied [TermT var]
recTopes TermT var
contextTopesRHS
      Bool
True -> 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 = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local 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
renderBackend :: Maybe RenderBackend
covariance :: Covariance
verbosity :: Verbosity
location :: Maybe LocationInfo
currentCommand :: Maybe Command
actionStack :: [Action var]
localTopesEntailBottom :: Bool
localTopesNFUnion :: [[TermT var]]
localTopesNF :: [TermT var]
localTopes :: [TermT var]
localScopes :: [ScopeInfo var]
renderBackend :: forall var. Context var -> Maybe RenderBackend
covariance :: forall var. Context var -> Covariance
verbosity :: forall var. Context var -> Verbosity
location :: forall var. Context var -> Maybe LocationInfo
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]
..} -> 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
renderBackend :: Maybe RenderBackend
verbosity :: Verbosity
location :: Maybe LocationInfo
currentCommand :: Maybe Command
actionStack :: [Action var]
localTopesEntailBottom :: Bool
localTopesNFUnion :: [[TermT var]]
localTopesNF :: [TermT var]
localTopes :: [TermT var]
localScopes :: [ScopeInfo var]
renderBackend :: Maybe RenderBackend
verbosity :: Verbosity
location :: Maybe LocationInfo
currentCommand :: Maybe Command
actionStack :: [Action var]
localTopesEntailBottom :: Bool
localTopesNFUnion :: [[TermT var]]
localTopesNF :: [TermT var]
localTopes :: [TermT var]
localScopes :: [ScopeInfo var]
.. }
    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 =
  forall var. var -> VarInfo var -> Context var -> Context var
addVarInCurrentScope forall var. Inc var
Z VarInfo
    { varType :: TermT (Inc var)
varType   = forall var. var -> Inc var
S forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
ty
    , varValue :: Maybe (TermT (Inc var))
varValue  = forall a. Maybe a
Nothing
    , varOrig :: Maybe VarIdent
varOrig   = Maybe VarIdent
orig
    , varIsAssumption :: Bool
varIsAssumption = Bool
False
    , varDeclaredAssumptions :: [Inc var]
varDeclaredAssumptions = []
    }
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall var. var -> Inc var
S

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

    TypeSigmaT TypeInfo (TermT var)
_ty Maybe VarIdent
_orig TermT var
a Scope (FS (AnnF TypeInfo TermF)) var
b -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
      forall var. TermT var -> TermT var -> TermT var -> TermT var
pairT TermT var
ty
        (forall var. TermT var -> TermT var -> TermT var
firstT TermT var
a TermT var
term)
        (forall var. TermT var -> TermT var -> TermT var
secondT (forall var.
TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
substituteT (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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
      forall var. TermT var -> TermT var -> TermT var -> TermT var
pairT TermT var
ty
        (forall var. TermT var -> TermT var -> TermT var
firstT TermT var
a TermT var
term)
        (forall var. TermT var -> TermT var -> TermT var
secondT TermT var
b TermT var
term)

    TermT var
_ -> 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{}    -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  UniverseT{}     -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

  UniverseCubeT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  CubeProductT{}  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  CubeUnitT{}     -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  CubeUnitStarT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  Cube2T{}        -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  Cube2_0T{}      -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  Cube2_1T{}      -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

  TermT var
t               -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
t forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  UniverseT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

  UniverseCubeT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  UniverseTopeT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

  CubeProductT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  CubeUnitT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  CubeUnitStarT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  Cube2T{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  Cube2_0T{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  Cube2_1T{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

  TopeTopT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  TopeBottomT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  TopeAndT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  TopeOrT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  TopeEQT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  TopeLEQT{} -> 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
    forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig TermT var
param forall a b. (a -> b) -> a -> b
$ forall var. Eq var => TermT var -> TypeCheck var Bool
inTopeLayer Scope (FS (AnnF TypeInfo TermF)) var
ret

  TermT var
t -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOfUncomputed TermT var
t forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        go ((TermT var
tope, a
term') : [(TermT var, a)]
rs') = do
          forall var. Eq var => TermT var -> TypeCheck var Bool
checkTope TermT var
tope forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Bool
True  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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'
    forall {var} {a}.
Eq var =>
[(TermT var, a)]
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) (Maybe a)
go [(TermT var, TermT var)]
rs
  TermT var
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 = forall var a.
Eq var =>
Action var -> TypeCheck var a -> TypeCheck var a
performing (forall var. TermT var -> Action var
ActionWHNF TermT var
tt) 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' <- forall term. TypeInfo term -> Maybe term
infoWHNF TypeInfo (TermT var)
info -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt'

  -- universe constants
  UniverseT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  UniverseCubeT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  UniverseTopeT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt

  -- cube layer (except vars, pairs, and applications)
  CubeProductT{} -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
tt
  CubeUnitT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  CubeUnitStarT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  Cube2T{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  Cube2_0T{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  Cube2_1T{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt

  -- tope layer (except vars, pairs of points, and applications)
  TopeTopT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  TopeBottomT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  TopeAndT{} -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
tt
  TopeOrT{} -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
tt
  TopeEQT{} -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
tt
  TopeLEQT{} -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
tt

  -- type layer terms that should not be evaluated further
  LambdaT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  PairT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  ReflT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  TypeFunT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  TypeSigmaT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  TypeIdT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  RecBottomT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  TypeUnitT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  UnitT{} -> 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' -> 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
_ -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
tt forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    UniverseCubeT{} -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
tt
    UniverseTopeT{} -> 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{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
typeOf_tt forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      UniverseCubeT{} -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
tt

      -- now we are in the type layer
      TermT var
_ -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall var. TermT var -> TermT var
termIsWHNF forall a b. (a -> b) -> a -> b
$ do
        -- check if we are in the empty context
        Bool
inBottom <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall var. Context var -> Bool
localTopesEntailBottom
        if Bool
inBottom
           then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall var. TermT var
recBottomT -- if so, reduce to recBOT
           else forall var.
Eq var =>
TermT var -> TypeCheck var (Maybe (TermT var))
tryRestriction TermT var
typeOf_tt forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just TermT var
tt' -> 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) ->
                forall var. Eq var => var -> TypeCheck var (Maybe (TermT var))
valueOfVar var
var forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  Maybe (TermT var)
Nothing   -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
t
                  Just TermT var
term -> 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 ->
                forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
f 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 ->
                    forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT (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' -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
f' 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
                      forall var. TermT var -> TermT var -> TermT var
topeAndT
                        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
f' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
x)
                        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT (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{} <- forall term. TypeInfo term -> term
infoType TypeInfo (TermT var)
info -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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' = forall var.
TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
substituteT TermT var
x Scope (FS (AnnF TypeInfo TermF)) var
ret
                          forall var.
Eq var =>
TermT var -> TypeCheck var (Maybe (TermT var))
tryRestriction TermT var
ret' forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case -- FIXME: to many unnecessary checks?
                            Maybe (TermT var)
Nothing  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 :: TermT var
infoType = TermT var
ret' } TermT var
f' TermT var
x)
                            Just TermT var
tt' -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
tt'
                    TermT var
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 ->
                forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
t forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  PairT TypeInfo (TermT var)
_ TermT var
l TermT var
_r -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
l
                  TermT var
t'           -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 ->
                forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
t forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  PairT TypeInfo (TermT var)
_ TermT var
_l TermT var
r -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
r
                  TermT var
t'           -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 ->
                forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  ReflT{} -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
d
                  TermT var
p'      -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
                    go ((TermT var
tope, a
tt') : [(TermT var, a)]
rs') = do
                      forall var. Eq var => TermT var -> TypeCheck var Bool
checkTope TermT var
tope forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                        Bool
True  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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'
                forall {var} {a}.
Eq var =>
[(TermT var, a)]
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) (Maybe a)
go [(TermT var, TermT var)]
rs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  Just TermT var
tt' -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
tt'
                  Maybe (TermT var)
Nothing
                    | [TermT var
tt'] <- forall var. Eq var => [TermT var] -> [TermT var]
nubTermT (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(TermT var, TermT var)]
rs) -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
tt'
                    | Bool
otherwise -> 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' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(TermT var
tope, TermT var
term) -> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
tope forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
term) [(TermT var, TermT var)]
rs
                case forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
/= forall var. TermT var
topeBottomT) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(TermT var, TermT var)]
rs' of
                  []   -> 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'' -> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
type_ forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 = forall var a.
Eq var =>
Action var -> TypeCheck var a -> TypeCheck var a
performing (forall var. TermT var -> Action var
ActionNF TermT var
tt) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall var. TermT var -> TermT var
termIsNF forall a b. (a -> b) -> a -> b
$ case TermT var
tt of
  Pure var
var ->
    forall var. Eq var => var -> TypeCheck var (Maybe (TermT var))
valueOfVar var
var forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (TermT var)
Nothing   -> forall (m :: * -> *) a. Monad m => a -> m a
return TermT var
tt
      Just TermT var
term -> 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' <- forall term. TypeInfo term -> Maybe term
infoNF TypeInfo (TermT var)
info -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt'

  -- universe constants
  UniverseT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  UniverseCubeT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  UniverseTopeT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt

  -- cube layer constants
  CubeUnitT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  CubeUnitStarT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  Cube2T{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  Cube2_0T{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  Cube2_1T{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt

  -- type layer constants
  TypeUnitT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  UnitT{} -> 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 -> forall var. TermT var -> TermT var -> TermT var
cubeProductT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
l forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
r

  -- tope layer constants
  TopeTopT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  TopeBottomT{} -> 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 ->
    forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
l forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      TopeBottomT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall var. TermT var
topeBottomT
      TermT var
l' -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
r forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        TopeBottomT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall var. TermT var
topeBottomT
        TermT var
r'            -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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' <- forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
l
    TermT var
r' <- 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
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
r'
      (TermT var
_, TopeBottomT{}) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
l'
      (TermT var, TermT var)
_                  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 -> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
l forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 -> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
l forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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' -> 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 -> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
l forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 ->
    forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
f 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 ->
        forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope (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' -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOfUncomputed TermT var
f' 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
          forall var. TermT var -> TermT var -> TermT var
topeAndT
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (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' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
x)
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope (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
_ -> 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' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
x

  FirstT TypeInfo (TermT var)
ty TermT var
t ->
    forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
t 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
x
      TermT var
t'             -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 ->
    forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
t 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
y
      TermT var
t'             -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 <- forall term. TypeInfo term -> term
infoType TypeInfo (TermT var)
ty ->
        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 (forall a. a -> Maybe a
Just (TermT var
param, Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig TermT var
param (forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope Scope (FS (AnnF TypeInfo TermF)) var
body)
  LambdaT{} -> forall a. String -> a
panicImpossible String
"lambda with a non-function type in the tope layer"

  TypeFunT{} -> forall a. String -> a
panicImpossible String
"exposed function type in the tope layer"
  TypeSigmaT{} -> forall a. String -> a
panicImpossible String
"dependent sum type in the tope layer"
  TypeIdT{} -> forall a. String -> a
panicImpossible String
"identity type in the tope layer"
  ReflT{} -> forall a. String -> a
panicImpossible String
"refl in the tope layer"
  IdJT{} -> forall a. String -> a
panicImpossible String
"idJ eliminator in the tope layer"
  TypeRestrictedT{} -> forall a. String -> a
panicImpossible String
"extension types in the tope layer"

  RecOrT{} -> forall a. String -> a
panicImpossible String
"recOR in the tope layer"
  RecBottomT{} -> 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 = forall var a.
Eq var =>
Action var -> TypeCheck var a -> TypeCheck var a
performing (forall var. TermT var -> Action var
ActionNF TermT var
tt) forall a b. (a -> b) -> a -> b
$ case TermT var
tt of
  -- universe constants
  UniverseT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  UniverseCubeT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  UniverseTopeT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt

  -- cube layer constants
  CubeUnitT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  CubeUnitStarT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  Cube2T{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  Cube2_0T{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  Cube2_1T{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt

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

  -- tope layer constants
  TopeTopT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  TopeBottomT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt

  -- tope layer with computation
  TopeAndT{} -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
tt
  TopeOrT{} -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
tt
  TopeEQT{} -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
tt
  TopeLEQT{} -> 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 forall a. Maybe a
Nothing)
  RecBottomT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  TypeUnitT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
  UnitT{} -> 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' -> 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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall var. Context var -> Bool
localTopesEntailBottom
    if Bool
inBottom
       then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall var. TermT var
recBottomT -- if so, reduce to recBOT
       else forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
tt forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall var.
Eq var =>
TermT var -> TypeCheck var (Maybe (TermT var))
tryRestriction forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just TermT var
tt' -> 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) ->
            forall var. Eq var => var -> TypeCheck var (Maybe (TermT var))
valueOfVar var
var forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Maybe (TermT var)
Nothing   -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
t
              Just TermT var
term -> 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' <- forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
param
            forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig TermT var
param' forall a b. (a -> b) -> a -> b
$ do
              Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope
              forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope' forall a b. (a -> b) -> a -> b
$
                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' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 ->
            forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
f 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 ->
                forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT (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' -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
f' 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
                  forall var. TermT var -> TermT var -> TermT var
topeAndT
                    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
f' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
x)
                    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT (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
_ -> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
f' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 forall var. TermT var -> TermT var
stripTypeRestrictions (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' <- forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
param
                forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig TermT var
param' forall a b. (a -> b) -> a -> b
$ do
                  Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope
                  forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope' forall a b. (a -> b) -> a -> b
$
                    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 (forall a. a -> Maybe a
Just (TermT var
param', Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope')) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT Scope (FS (AnnF TypeInfo TermF)) var
body
              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' <- forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
a
            forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig TermT var
a' forall a b. (a -> b) -> a -> b
$ do
              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' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 -> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
l forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
r
          FirstT TypeInfo (TermT var)
ty TermT var
t ->
            forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
t forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              PairT TypeInfo (TermT var)
_ TermT var
l TermT var
_r -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
l
              TermT var
t'           -> forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a -> FS (AnnF ann TermF) a
FirstT TypeInfo (TermT var)
ty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
t'
          SecondT TypeInfo (TermT var)
ty TermT var
t ->
            forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
t forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              PairT TypeInfo (TermT var)
_ TermT var
_l TermT var
r -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
r
              TermT var
t'           -> forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a)
-> FS (AnnF ann TermF) a -> FS (AnnF ann TermF) a
SecondT TypeInfo (TermT var)
ty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 -> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 ->
            forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              ReflT{} -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
d
              TermT var
p' -> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
tA forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
tC forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
d forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
                go ((TermT var
tope, a
tt') : [(TermT var, a)]
rs') = do
                  forall var. Eq var => TermT var -> TypeCheck var Bool
checkTope TermT var
tope forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    Bool
True  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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'
            forall {var} {a}.
Eq var =>
[(TermT var, a)]
-> ReaderT
     (Context var) (Except (TypeErrorInScopedContext var)) (Maybe a)
go [(TermT var, TermT var)]
rs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Just TermT var
tt' -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
tt'
              Maybe (TermT var)
Nothing
                | [TermT var
tt'] <- forall var. Eq var => [TermT var] -> [TermT var]
nubTermT (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(TermT var, TermT var)]
rs) -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
tt'
                | Bool
otherwise -> 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' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(TermT var, TermT var)]
rs forall a b. (a -> b) -> a -> b
$ \(TermT var
tope, TermT var
term) -> do
              forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
tope forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                TopeBottomT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
                TermT var
tope' -> do
                  TermT var
term' <- forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope TermT var
tope' forall a b. (a -> b) -> a -> b
$
                    forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
term
                  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (TermT var
tope', TermT var
term'))
            case forall a. [Maybe a] -> [a]
catMaybes [Maybe (TermT var, TermT var)]
rs' of
              []   -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
type_
              [(TermT var, TermT var)]
rs'' -> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT TermT var
type_ forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure [(TermT var, TermT var)]
rs''

checkDefinedVar :: Eq var => var -> TypeCheck var ()
checkDefinedVar :: forall var. Eq var => var -> TypeCheck var ()
checkDefinedVar var
x = forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup var
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall var. Context var -> [(var, VarInfo var)]
varInfos) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Maybe (VarInfo var)
Nothing  -> forall var a. TypeError var -> TypeCheck var a
issueTypeError forall a b. (a -> b) -> a -> b
$ forall var. var -> TypeError var
TypeErrorUndefined var
x
  Just VarInfo var
_ty -> 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 = forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup var
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall var. Context var -> [(var, Maybe (TermT var))]
varValues) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Maybe (Maybe (TermT var))
Nothing -> forall var a. TypeError var -> TypeCheck var a
issueTypeError forall a b. (a -> b) -> a -> b
$ forall var. var -> TypeError var
TypeErrorUndefined var
x
  Just Maybe (TermT var)
ty -> 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 = forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup var
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall var. Context var -> [(var, TermT var)]
varTypes) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Maybe (TermT var)
Nothing -> forall var a. TypeError var -> TypeCheck var a
issueTypeError forall a b. (a -> b) -> a -> b
$ forall var. var -> TypeError var
TypeErrorUndefined var
x
  Just TermT var
ty -> 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                     -> forall var. Eq var => var -> TypeCheck var (TermT var)
typeOfVar var
x
  Free (AnnF TypeInfo{Maybe (TermT var)
TermT var
infoNF :: Maybe (TermT var)
infoWHNF :: Maybe (TermT var)
infoType :: 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)
_) -> 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 = forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOfUncomputed TermT var
t forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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
(&&)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TermT var
l] forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
`entailM` TermT var
r
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [TermT var
r] forall var.
Eq var =>
[TermT var] -> TermT var -> TypeCheck var Bool
`entailM` TermT var
l
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
equiv forall a b. (a -> b) -> a -> b
$
    forall var a. TypeError var -> TypeCheck var a
issueTypeError (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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall var. Context var -> [[TermT var]]
localTopesNFUnion
  case [[TermT var]]
topeSubContexts of
    [] -> forall a. String -> a
panicImpossible String
"empty set of alternative contexts"
    [[TermT var]
_] -> TypeCheck var ()
handleSingle
    [TermT var]
_:[TermT var]
_:[[TermT var]]
_ -> do
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[TermT var]]
topeSubContexts forall a b. (a -> b) -> a -> b
$ \[TermT var]
topes' -> do
        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
renderBackend :: Maybe RenderBackend
covariance :: Covariance
verbosity :: Verbosity
location :: Maybe LocationInfo
currentCommand :: Maybe Command
actionStack :: [Action var]
localTopesEntailBottom :: Bool
localTopesNFUnion :: [[TermT var]]
localTopesNF :: [TermT var]
localTopes :: [TermT var]
localScopes :: [ScopeInfo var]
renderBackend :: forall var. Context var -> Maybe RenderBackend
covariance :: forall var. Context var -> Covariance
verbosity :: forall var. Context var -> Verbosity
location :: forall var. Context var -> Maybe LocationInfo
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]
..} -> 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
renderBackend :: Maybe RenderBackend
covariance :: Covariance
verbosity :: Verbosity
location :: Maybe LocationInfo
currentCommand :: Maybe Command
actionStack :: [Action var]
localTopesEntailBottom :: Bool
localScopes :: [ScopeInfo var]
renderBackend :: Maybe RenderBackend
covariance :: Covariance
verbosity :: Verbosity
location :: Maybe LocationInfo
currentCommand :: Maybe Command
actionStack :: [Action var]
localTopesEntailBottom :: Bool
localScopes :: [ScopeInfo 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 = ReaderT (Context var) (Except (TypeErrorInScopedContext var)) ()
performUnification forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \TypeErrorInScopedContext var
typeError -> do
  forall var.
TypeCheck var () -> TypeCheck var () -> TypeCheck var ()
inAllSubContexts (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError TypeErrorInScopedContext var
typeError) ReaderT (Context var) (Except (TypeErrorInScopedContext var)) ()
performUnification
  where
    performUnification :: ReaderT (Context var) (Except (TypeErrorInScopedContext var)) ()
performUnification = 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 forall a. Eq a => a -> a -> Bool
== TermT var
actual = 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
  forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify forall a. Maybe a
Nothing TermT var
f TermT var
g
  forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify forall a. Maybe a
Nothing TermT var
x TermT var
y
unifyViaDecompose TermT var
_ TermT var
_ = forall var a. TypeError var -> TypeCheck var a
issueTypeError (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 = forall var a.
Eq var =>
Action var -> TypeCheck var a -> TypeCheck var a
performing Action var
action forall a b. (a -> b) -> a -> b
$
  forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyViaDecompose TermT var
expected TermT var
actual 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 <- forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
expected
    TermT var
actualVal <- forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
actual
    (TermT var
expected', TermT var
actual') <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall var. Context var -> Covariance
covariance forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Covariance
Covariant     -> 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 -> forall a b. (a, b) -> (b, a)
swap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TermT var
expected' forall a. Eq a => a -> a -> Bool
== TermT var
actual') forall a b. (a -> b) -> a -> b
$ do  -- NOTE: this gives a small, but noticeable speedup
      case TermT var
actual' of
        RecBottomT{} -> 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 -> forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ forall a b. (a -> b) -> a -> b
$
              forall var.
Eq var =>
(TermT var, TermT var)
-> (TermT var, TermT var) -> TypeCheck var ()
checkCoherence forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TermT var, TermT var)]
rs forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [(TermT var, TermT var)]
rs'
            TermT var
_ -> do
              forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(TermT var, TermT var)]
rs' forall a b. (a -> b) -> a -> b
$ \(TermT var
tope, TermT var
term) ->
                forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope TermT var
tope forall a b. (a -> b) -> a -> b
$
                  forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms TermT var
expected' TermT var
term
        TermT var
_ -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
expected' forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          UniverseCubeT{} -> forall var. Eq var => TermT var -> TypeCheck var ()
contextEntails (forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
expected' TermT var
actual')
          TermT var
_ -> do
            let def :: TypeCheck var ()
def = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TermT var
expected' forall a. Eq a => a -> a -> Bool
== TermT var
actual') forall {a}. TypeCheck var a
err
                err :: TypeCheck var a
err =
                  case Maybe (TermT var)
mterm of
                    Maybe (TermT var)
Nothing   -> forall var a. TypeError var -> TypeCheck var a
issueTypeError (forall var. TermT var -> TermT var -> TypeError var
TypeErrorUnifyTerms TermT var
expected' TermT var
actual')
                    Just TermT var
term -> forall var a. TypeError var -> TypeCheck var a
issueTypeError (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 = forall var. var -> Inc var
S forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
expected'
                      actualS :: FS (AnnF TypeInfo TermF) (Inc var)
actualS = forall var. var -> Inc var
S 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   -> forall var a. TypeError var -> TypeCheck var a
issueTypeError (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 -> forall var a. TypeError var -> TypeCheck var a
issueTypeError (forall var. TermT var -> TermT var -> TermT var -> TypeError var
TypeErrorUnify (forall var. var -> Inc var
S 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{} -> 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
                    forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms TermT var
l TermT var
l'
                    forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms TermT var
r TermT var
r'
                  TermT 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
                    forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms TermT var
l TermT var
l'
                    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
_ -> 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' -> forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms TermT var
t TermT var
t'
                  TermT 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' -> forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms TermT var
t TermT var
t'
                  TermT var
_               -> forall {a}. TypeCheck var a
err

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

              RecBottomT{} -> 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
                    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(TermT var, TermT var)]
rs forall a b. (a -> b) -> a -> b
$ \(TermT var
tope, TermT var
term) ->
                      forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope TermT var
tope forall a b. (a -> b) -> a -> b
$
                        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
                    forall var a. TypeCheck var a -> TypeCheck var a
switchVariance forall a b. (a -> b) -> a -> b
$  -- unifying in the negative position!
                      forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms TermT var
cube TermT var
cube' -- FIXME: unifyCubes
                    forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig' TermT var
cube 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
                          FS (AnnF TypeInfo TermF) (Inc var)
topeNF <- 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' <- forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) (Inc var)
tope'
                          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)      -> 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)    -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) (Inc var)
tope forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
`unifyTopes` forall var. TermT var
topeTopT)
                        (Maybe (FS (AnnF TypeInfo TermF) (Inc var))
Nothing, Just FS (AnnF TypeInfo TermF) (Inc var)
tope)    -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfT FS (AnnF TypeInfo TermF) (Inc var)
tope forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTopes forall var. TermT var
topeTopT
                      case Maybe (TermT var)
mterm of
                        Maybe (TermT var)
Nothing -> 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 -> forall var.
Eq var =>
TermT var -> TermT var -> TermT var -> TypeCheck var ()
unifyTypes (forall var. TermT var -> TermT var -> TermT var -> TermT var
appT FS (AnnF TypeInfo TermF) (Inc var)
ret' (forall var. var -> Inc var
S forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
term) (forall (t :: * -> * -> *) a. a -> FS t a
Pure forall var. Inc var
Z)) FS (AnnF TypeInfo TermF) (Inc var)
ret FS (AnnF TypeInfo TermF) (Inc var)
ret'
                  TermT 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
                    forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify forall a. Maybe a
Nothing TermT var
a TermT var
a'
                    forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig' TermT var
a forall a b. (a -> b) -> a -> b
$ forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify forall a. Maybe a
Nothing FS (AnnF TypeInfo TermF) (Inc var)
b FS (AnnF TypeInfo TermF) (Inc var)
b'
                  TermT 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?
                    forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify forall a. Maybe a
Nothing TermT var
x TermT var
x'
                    forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify forall a. Maybe a
Nothing TermT var
y TermT var
y'
                  TermT 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
                    forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify forall a. Maybe a
Nothing TermT var
f TermT var
f'
                    forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify forall a. Maybe a
Nothing TermT var
x TermT var
x'
                  TermT 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 forall var. TermT var -> TermT var
stripTypeRestrictions (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 forall var. TermT var -> TermT var
stripTypeRestrictions (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
                            forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify forall a. Maybe a
Nothing TermT var
param TermT var
param'
                            forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig' TermT var
param 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
                                  forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify forall a. Maybe a
Nothing FS (AnnF TypeInfo TermF) (Inc var)
tope FS (AnnF TypeInfo TermF) (Inc var)
tope'
                                  forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope FS (AnnF TypeInfo TermF) (Inc var)
tope forall a b. (a -> b) -> a -> b
$ forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify 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
                                  forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify 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)))
_ -> forall {a}. TypeCheck (Inc var) a
errS
                          TermT var
_ -> forall {a}. TypeCheck var a
err
                      TermT var
_ -> forall {a}. TypeCheck var a
err
                  TermT 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 <- 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' <- forall term. TypeInfo term -> term
infoType TypeInfo (TermT var)
ty' -> do
                    -- unify Nothing tA tA' -- TODO: do we need this check?
                    forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify forall a. Maybe a
Nothing TermT var
x TermT var
x'
                    forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify forall a. Maybe a
Nothing TermT var
y TermT var
y'
                  TermT var
_ -> forall {a}. TypeCheck var a
err
              ReflT{} -> 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
                    forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify forall a. Maybe a
Nothing TermT var
a TermT var
a'
                    forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify forall a. Maybe a
Nothing TermT var
b TermT var
b'
                    forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify forall a. Maybe a
Nothing TermT var
c TermT var
c'
                    forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify forall a. Maybe a
Nothing TermT var
d TermT var
d'
                    forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify forall a. Maybe a
Nothing TermT var
e TermT var
e'
                    forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify forall a. Maybe a
Nothing TermT var
f TermT var
f'
                  TermT var
_ -> forall {a}. TypeCheck var a
err

              TypeAscT{} -> 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
                    forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify Maybe (TermT var)
mterm TermT var
ty TermT var
ty'
                    forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
                      [ forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope TermT var
tope forall a b. (a -> b) -> a -> b
$ do
                          -- FIXME: can do less entails checks?
                          forall var. Eq var => TermT var -> TypeCheck var ()
contextEntails (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall var. TermT var -> TermT var -> TermT var
topeOrT forall var. TermT var
topeBottomT (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(TermT var, TermT var)]
rs')) -- expected is less specified than actual
                          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(TermT var, TermT var)]
rs' forall a b. (a -> b) -> a -> b
$ \(TermT var
tope', TermT var
term') -> do
                            forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope TermT var
tope' forall a b. (a -> b) -> a -> b
$
                              forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify forall a. Maybe a
Nothing TermT var
term TermT var
term'
                      | (TermT var
tope, TermT var
term) <- [(TermT var, TermT var)]
rs
                      ]
                  TermT 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   -> forall var. TermT var -> TermT var -> Action var
ActionUnifyTerms TermT var
expected TermT var
actual
               Just TermT var
term -> 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 = forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall var.
Eq var =>
Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var ()
unify 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
renderBackend :: Maybe RenderBackend
covariance :: Covariance
verbosity :: Verbosity
location :: Maybe LocationInfo
currentCommand :: Maybe Command
actionStack :: [Action var]
localTopesEntailBottom :: Bool
localTopesNFUnion :: [[TermT var]]
localTopesNF :: [TermT var]
localTopes :: [TermT var]
localScopes :: [ScopeInfo var]
renderBackend :: forall var. Context var -> Maybe RenderBackend
covariance :: forall var. Context var -> Covariance
verbosity :: forall var. Context var -> Verbosity
location :: forall var. Context var -> Maybe LocationInfo
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]
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
  TermT var
tope' <- 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 forall a. Eq a => a -> a -> Bool
== TermT var
y -> forall a b. a -> b -> a
const TypeCheck var a
tc          -- no new information added!
        TermT var
_ | TermT var
tope' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TermT var]
localTopes -> forall a b. a -> b -> a
const TypeCheck var a
tc     -- no new information added!
          | Bool
otherwise -> forall a. a -> a
id
  TypeCheck var a -> TypeCheck var a
refine forall a b. (a -> b) -> a -> b
$ do
    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
renderBackend :: Maybe RenderBackend
covariance :: Covariance
verbosity :: Verbosity
location :: Maybe LocationInfo
currentCommand :: Maybe Command
actionStack :: [Action var]
localTopesEntailBottom :: Bool
localTopesNFUnion :: [[TermT var]]
localTopesNF :: [TermT var]
localTopes :: [TermT var]
localScopes :: [ScopeInfo var]
renderBackend :: forall var. Context var -> Maybe RenderBackend
covariance :: forall var. Context var -> Covariance
verbosity :: forall var. Context var -> Verbosity
location :: forall var. Context var -> Maybe LocationInfo
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]
..} = Context
      { localTopes :: [TermT var]
localTopes = TermT var
tope forall a. a -> [a] -> [a]
: [TermT var]
localTopes
      , localTopesNF :: [TermT var]
localTopesNF = TermT var
tope' forall a. a -> [a] -> [a]
: [TermT var]
localTopesNF
      , localTopesNFUnion :: [[TermT var]]
localTopesNFUnion = forall a b. (a -> b) -> [a] -> [b]
map forall var. Eq var => [TermT var] -> [TermT var]
nubTermT
          [ [TermT var]
new forall a. Semigroup a => a -> a -> a
<> [TermT var]
old
          | [TermT var]
new <- 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
renderBackend :: Maybe RenderBackend
covariance :: Covariance
verbosity :: Verbosity
location :: Maybe LocationInfo
currentCommand :: Maybe Command
actionStack :: [Action var]
localScopes :: [ScopeInfo var]
renderBackend :: Maybe RenderBackend
covariance :: Covariance
verbosity :: Verbosity
location :: Maybe LocationInfo
currentCommand :: Maybe Command
actionStack :: [Action var]
localScopes :: [ScopeInfo var]
.. }
      where
        entailsBottom :: Bool
entailsBottom = (TermT var
tope' forall a. a -> [a] -> [a]
: [TermT var]
localTopes') forall var. Eq var => [TermT var] -> TermT var -> Bool
`entail` forall var. TermT var
topeBottomT

universeT :: TermT var
universeT :: forall var. TermT var
universeT = forall a. (a -> a) -> a -> [a]
iterate forall var. TermT var -> TermT var
f (forall a. String -> a
panicImpossible String
msg) forall a. [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 = 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 = forall a. a -> Maybe a
Just forall var. TermT var
universeT
      , infoWHNF :: Maybe (TermT a)
infoWHNF = forall a. a -> Maybe a
Just forall var. TermT var
universeT }

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

topeT :: TermT var
topeT :: forall var. TermT var
topeT = forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a) -> FS (AnnF ann TermF) a
UniverseTopeT TypeInfo
  { infoType :: TermT var
infoType = forall var. TermT var
universeT
  , infoNF :: Maybe (TermT var)
infoNF = forall a. a -> Maybe a
Just forall var. TermT var
topeT
  , infoWHNF :: Maybe (TermT var)
infoWHNF = forall a. a -> Maybe a
Just 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 = 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 forall {var}. TypeInfo (TermT var)
info TermT var
l TermT var
r
  where
    info :: TypeInfo (TermT var)
info = TypeInfo
      { infoType :: TermT var
infoType = forall var. TermT var
topeT
      , infoNF :: Maybe (TermT var)
infoNF = forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF = 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 = 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 forall {var}. TypeInfo (TermT var)
info TermT var
l TermT var
r
  where
    info :: TypeInfo (TermT var)
info = TypeInfo
      { infoType :: TermT var
infoType = forall var. TermT var
topeT
      , infoNF :: Maybe (TermT var)
infoNF = forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF = 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 = 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 forall {var}. TypeInfo (TermT var)
info TermT var
l TermT var
r
  where
    info :: TypeInfo (TermT var)
info = TypeInfo
      { infoType :: TermT var
infoType = forall var. TermT var
topeT
      , infoNF :: Maybe (TermT var)
infoNF = forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF = 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 = 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 forall {var}. TypeInfo (TermT var)
info TermT var
l TermT var
r
  where
    info :: TypeInfo (TermT var)
info = TypeInfo
      { infoType :: TermT var
infoType = forall var. TermT var
topeT
      , infoNF :: Maybe (TermT var)
infoNF = forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF = 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 = 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 forall {var}. TypeInfo (TermT var)
info TermT var
l TermT var
r
    info :: TypeInfo (TermT var)
info = TypeInfo
      { infoType :: TermT var
infoType  = forall var. TermT var
cubeT
      , infoNF :: Maybe (TermT var)
infoNF    = forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF  = forall a. Maybe a
Nothing
      }

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

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

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

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

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

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

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

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

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

recBottomT :: TermT var
recBottomT :: forall var. TermT var
recBottomT = forall {ann :: * -> *} {a}.
ann (FS (AnnF ann TermF) a) -> FS (AnnF ann TermF) a
RecBottomT TypeInfo
  { infoType :: TermT var
infoType = forall var. TermT var
recBottomT
  , infoNF :: Maybe (TermT var)
infoNF = forall a. a -> Maybe a
Just forall var. TermT var
recBottomT
  , infoWHNF :: Maybe (TermT var)
infoWHNF = forall a. a -> Maybe a
Just 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 = 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 forall {var}. TypeInfo (TermT var)
info TermT var
ty [(TermT var, TermT var)]
rs
    info :: TypeInfo (TermT var)
info = TypeInfo
      { infoType :: TermT var
infoType  = forall var. TermT var
universeT
      , infoNF :: Maybe (TermT var)
infoNF    = forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF  = 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 = 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    = forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF  = 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 = 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    = forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF  = 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 = 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    = forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF  = 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 = 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    = forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF  = 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 = 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    = forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF  = 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 = 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    = forall a. a -> Maybe a
Just (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 forall a. Maybe a
Nothing)
      , infoWHNF :: Maybe (TermT var)
infoWHNF  = forall a. a -> Maybe a
Just (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 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 = 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  = forall var. TermT var
universeT
      , infoNF :: Maybe (TermT var)
infoNF    = forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF  = 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 = 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  = forall var. TermT var
universeT
      , infoNF :: Maybe (TermT var)
infoNF    = forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF  = 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 = 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    = forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF  = 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 = 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  = forall var. TermT var
universeT
      , infoNF :: Maybe (TermT var)
infoNF    = forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF  = 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 = 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    = forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF  = 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 = 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    = forall a. Maybe a
Nothing
      , infoWHNF :: Maybe (TermT var)
infoWHNF  = 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 = forall var a.
Eq var =>
Action var -> TypeCheck var a -> TypeCheck var a
performing (forall var. Term var -> TermT var -> Action var
ActionTypeCheck Term var
term TermT var
ty) forall a b. (a -> b) -> a -> b
$ do
  forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
ty forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case

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

    TypeRestrictedT TypeInfo (TermT var)
_ty TermT var
ty' [(TermT var, TermT var)]
rs -> do
      TermT var
term' <- forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
term TermT var
ty'
      forall var. Eq var => TermT var -> TypeCheck var ()
contextEntailedBy (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall var. TermT var -> TermT var -> TermT var
topeOrT forall var. TermT var
topeBottomT (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(TermT var, TermT var)]
rs))
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(TermT var, TermT var)]
rs forall a b. (a -> b) -> a -> b
$ \(TermT var
tope, TermT var
rterm) -> do
        forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope TermT var
tope forall a b. (a -> b) -> a -> b
$
          forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms TermT var
rterm TermT var
term'
      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 -> 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 <- forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
param
                  forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
paramType 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
                      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall var. VarIdent -> TypeCheck var ()
checkNameShadowing Maybe VarIdent
orig
                      forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig TermT var
cube forall a b. (a -> b) -> a -> b
$ do
                        let tope' :: Scope (FS (AnnF TypeInfo TermF)) var
tope' = forall var. TermT var -> TermT var -> TermT var -> TermT var
appT forall var. TermT var
topeT (forall var. var -> Inc var
S forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
paramType) (forall (t :: * -> * -> *) a. a -> FS t a
Pure forall var. Inc var
Z)  -- eta expand ty'
                        forall (m :: * -> *) a. Monad m => a -> m a
return (TermT var
cube, forall a. a -> Maybe a
Just Scope (FS (AnnF TypeInfo TermF)) var
tope')
                    TermT var
_kind -> forall (m :: * -> *) a. Monad m => a -> m a
return (TermT var
paramType, forall a. Maybe a
Nothing)
                forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms TermT var
param' TermT var
paramType
                forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall var. VarIdent -> TypeCheck var ()
checkNameShadowing Maybe VarIdent
orig
                forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig TermT var
param' forall a b. (a -> b) -> a -> b
$ do
                  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms (forall a. a -> Maybe a -> a
fromMaybe 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'' <- forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
param forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
param'
                forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms TermT var
param' TermT var
param''
                forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall var. VarIdent -> TypeCheck var ()
checkNameShadowing Maybe VarIdent
orig
                forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig TermT var
param' forall a b. (a -> b) -> a -> b
$ do
                  Scope (FS (AnnF TypeInfo TermF)) var
mtope'' <- forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck (forall a. a -> Maybe a -> a
fromMaybe forall {a}. FS TermF a
TopeTop Maybe (Scope (FS TermF) var)
mtope) forall var. TermT var
topeT
                  forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms (forall a. a -> Maybe a -> a
fromMaybe forall var. TermT var
topeTopT Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope') Scope (FS (AnnF TypeInfo TermF)) var
mtope''

            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall var. VarIdent -> TypeCheck var ()
checkNameShadowing Maybe VarIdent
orig
            forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig TermT var
param' forall a b. (a -> b) -> a -> b
$ do
              forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope' forall a b. (a -> b) -> a -> b
$ do
                Scope (FS (AnnF TypeInfo TermF)) var
body' <- 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
                forall (m :: * -> *) a. Monad m => a -> m a
return (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 (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
_ -> forall var a. TypeError var -> TypeCheck var a
issueTypeError forall a b. (a -> b) -> a -> b
$ 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' <- forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
l TermT var
a
            TermT var
r' <- forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
r TermT var
b
            forall (m :: * -> *) a. Monad m => a -> m a
return (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' <- forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
l TermT var
a
            TermT var
r' <- forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
r (forall var.
TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
substituteT TermT var
l' Scope (FS (AnnF TypeInfo TermF)) var
b)
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall var. TermT var -> TermT var -> TermT var -> TermT var
pairT TermT var
ty' TermT var
l' TermT var
r')
          TermT var
_ -> forall var a. TypeError var -> TypeCheck var a
issueTypeError forall a b. (a -> b) -> a -> b
$ 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 <- forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
y
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (Term var, Maybe (Term var))
mx forall a b. (a -> b) -> a -> b
$ \(Term var
x, Maybe (Term var)
mxty) -> do
              forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (Term var)
mxty forall a b. (a -> b) -> a -> b
$ \Term var
xty -> do
                TermT var
xty' <- forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
xty forall var. TermT var
universeT
                forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms TermT var
tA TermT var
xty'
              TermT var
x' <- forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
x TermT var
tA
              forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms TermT var
x' TermT var
y
              forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms TermT var
x' TermT var
z
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing Maybe (Term var, Maybe (Term var))
mx) forall a b. (a -> b) -> a -> b
$
              forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms TermT var
y TermT var
z
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall var.
TermT var -> Maybe (TermT var, Maybe (TermT var)) -> TermT var
reflT TermT var
ty' (forall a. a -> Maybe a
Just (TermT var
y, forall a. a -> Maybe a
Just TermT var
tA)))
          TermT var
_ -> forall var a. TypeError var -> TypeCheck var a
issueTypeError forall a b. (a -> b) -> a -> b
$ 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' <- forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
term
        TermT var
inferredType <- forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
term'
        forall var.
Eq var =>
TermT var -> TermT var -> TermT var -> TypeCheck var ()
unifyTypes TermT var
term' TermT var
ty' TermT var
inferredType
        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' <- forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
term
  TermT var
ty <- forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
term'
  TermT var
kind <- forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
ty
  forall var.
Eq var =>
TermT var -> TermT var -> TermT var -> TypeCheck var ()
unifyTypes TermT var
ty TermT var
expectedKind TermT var
kind
  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 = forall var a.
Eq var =>
Action var -> TypeCheck var a -> TypeCheck var a
performing (forall var. Term var -> Action var
ActionInfer Term var
tt) forall a b. (a -> b) -> a -> b
$ case Term var
tt of
  Pure var
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (t :: * -> * -> *) a. a -> FS t a
Pure var
x)

  Term var
Universe     -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall var. TermT var
universeT
  Term var
UniverseCube -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall var. TermT var
cubeT
  Term var
UniverseTope -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall var. TermT var
topeT

  Term var
CubeUnit      -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall var. TermT var
cubeUnitT
  Term var
CubeUnitStar  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall var. TermT var
cubeUnitStarT

  Term var
Cube2 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall var. TermT var
cube2T
  Term var
Cube2_0 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall var. TermT var
cube2_0T
  Term var
Cube2_1 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall var. TermT var
cube2_1T

  CubeProduct Term var
l Term var
r -> do
    TermT var
l' <- forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
l forall var. TermT var
cubeT
    TermT var
r' <- forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
r forall var. TermT var
cubeT
    forall (m :: * -> *) a. Monad m => a -> m a
return (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' <- forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
l
    TermT var
r' <- forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
r
    TermT var
lt <- forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
l'
    TermT var
rt <- forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
r'
    forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
lt forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      UniverseCubeT{} -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall var. TermT var -> TermT var -> TermT var -> TermT var
pairT (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!
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall var. TermT var -> TermT var -> TermT var -> TermT var
pairT (forall var.
Maybe VarIdent
-> TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
typeSigmaT forall a. Maybe a
Nothing TermT var
lt (forall var. var -> Inc var
S 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' <- forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
t
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall var. TermT var -> TermT var
stripTypeRestrictions (forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
t') forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      RecBottomT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall var. TermT var
recBottomT -- FIXME: is this ok?
      TypeSigmaT TypeInfo (TermT var)
_ty Maybe VarIdent
_orig TermT var
lt FS (AnnF TypeInfo TermF) (Inc var)
_rt ->
        forall (m :: * -> *) a. Monad m => a -> m a
return (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 ->
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall var. TermT var -> TermT var -> TermT var
firstT TermT var
l TermT var
t')
      TermT var
ty -> forall var a. TypeError var -> TypeCheck var a
issueTypeError forall a b. (a -> b) -> a -> b
$ forall var. TermT var -> TermT var -> TypeError var
TypeErrorNotPair TermT var
t' TermT var
ty

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

  Term var
TypeUnit -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall var. TermT var
typeUnitT
  Term var
Unit -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall var. TermT var
unitT

  Term var
TopeTop -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall var. TermT var
topeTopT
  Term var
TopeBottom -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall var. TermT var
topeBottomT

  TopeEQ Term var
l Term var
r -> do
    TermT var
l' <- forall var.
Eq var =>
TermT var -> Term var -> TypeCheck var (TermT var)
inferAs forall var. TermT var
cubeT Term var
l
    TermT var
lt <- forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
l'
    TermT var
r' <- forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
r TermT var
lt
    forall (m :: * -> *) a. Monad m => a -> m a
return (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' <- forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
l forall var. TermT var
cube2T
    TermT var
r' <- forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
r forall var. TermT var
cube2T
    forall (m :: * -> *) a. Monad m => a -> m a
return (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' <- forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
l forall var. TermT var
topeT
    TermT var
r' <- forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
r forall var. TermT var
topeT
    forall (m :: * -> *) a. Monad m => a -> m a
return (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' <- forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
l forall var. TermT var
topeT
    TermT var
r' <- forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
r forall var. TermT var
topeT
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall var. TermT var -> TermT var -> TermT var
topeOrT TermT var
l' TermT var
r')

  Term var
RecBottom -> do
    forall var. Eq var => TermT var -> TypeCheck var ()
contextEntails forall var. TermT var
topeBottomT
    forall (m :: * -> *) a. Monad m => a -> m a
return forall var. TermT var
recBottomT

  RecOr [(Term var, Term var)]
rs -> do
    [(TermT var, (TermT var, TermT var))]
ttts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Term var, Term var)]
rs forall a b. (a -> b) -> a -> b
$ \(Term var
tope, Term var
term) -> do
      TermT var
tope' <- forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
tope forall var. TermT var
topeT
      forall var. Eq var => TermT var -> TypeCheck var ()
contextEntailedBy TermT var
tope'
      forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope TermT var
tope' forall a b. (a -> b) -> a -> b
$ do
        TermT var
term' <- forall var.
Eq var =>
TermT var -> Term var -> TypeCheck var (TermT var)
inferAs forall var. TermT var
universeT Term var
term
        TermT var
ty <- forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
term'
        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' = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst) [(TermT var, (TermT var, TermT var))]
ttts
        ts :: [(TermT var, TermT var)]
ts  = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd) [(TermT var, (TermT var, TermT var))]
ttts
    forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ 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'' <- forall a. [a] -> [[a]]
tails [(TermT var, TermT var)]
rs', (TermT var, TermT var)
r <- [(TermT var, TermT var)]
rs'' ]
    forall var. Eq var => [TermT var] -> TypeCheck var ()
contextEquiv (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(TermT var, (TermT var, TermT var))]
ttts)
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall var. TermT var -> [(TermT var, TermT var)] -> TermT var
recOrT (forall var. TermT var -> [(TermT var, TermT var)] -> TermT var
recOrT 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' <- forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
a
    forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
a' 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{} ->
            forall var a. TypeError var -> TypeCheck var a
issueTypeError forall a b. (a -> b) -> a -> b
$ forall var. String -> TypeError var
TypeErrorOther String
"tope params are illegal"
          TermT var
_ -> do
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall var. VarIdent -> TypeCheck var ()
checkNameShadowing Maybe VarIdent
orig
            FS (AnnF TypeInfo TermF) (Inc var)
b' <- forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig TermT var
a' forall a b. (a -> b) -> a -> b
$ forall var.
Eq var =>
TermT var -> Term var -> TypeCheck var (TermT var)
inferAs forall var. TermT var
universeT Scope (FS TermF) var
b
            forall (m :: * -> *) a. Monad m => a -> m a
return (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' forall a. Maybe a
Nothing FS (AnnF TypeInfo TermF) (Inc var)
b')
      -- an argument can be a cube
      UniverseCubeT{} -> do
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall var. VarIdent -> TypeCheck var ()
checkNameShadowing Maybe VarIdent
orig
        FS (AnnF TypeInfo TermF) (Inc var)
b' <- forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig TermT var
a' forall a b. (a -> b) -> a -> b
$ forall var.
Eq var =>
TermT var -> Term var -> TypeCheck var (TermT var)
inferAs forall var. TermT var
universeT Scope (FS TermF) var
b
        forall (m :: * -> *) a. Monad m => a -> m a
return (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' forall a. Maybe a
Nothing FS (AnnF TypeInfo TermF) (Inc var)
b')
      -- an argument can be a shape
      TypeFunT TypeInfo (TermT var)
_ty Maybe VarIdent
_orig TermT var
cube Maybe (FS (AnnF TypeInfo TermF) (Inc var))
mtope UniverseTopeT{} -> do
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall var. VarIdent -> TypeCheck var ()
checkNameShadowing Maybe VarIdent
orig
        forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig TermT var
cube forall a b. (a -> b) -> a -> b
$ do
          let tope' :: FS (AnnF TypeInfo TermF) (Inc var)
tope' = forall var. TermT var -> TermT var -> TermT var -> TermT var
appT forall var. TermT var
topeT (forall var. var -> Inc var
S forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
a') (forall (t :: * -> * -> *) a. a -> FS t a
Pure forall var. Inc var
Z)  -- eta expand a'
          forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope FS (AnnF TypeInfo TermF) (Inc var)
tope' forall a b. (a -> b) -> a -> b
$ do
            FS (AnnF TypeInfo TermF) (Inc var)
b' <- forall var.
Eq var =>
TermT var -> Term var -> TypeCheck var (TermT var)
inferAs forall var. TermT var
universeT Scope (FS TermF) var
b
            case Maybe (FS (AnnF TypeInfo TermF) (Inc var))
mtope of
              Maybe (FS (AnnF TypeInfo TermF) (Inc var))
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (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 (forall a. a -> Maybe a
Just FS (AnnF TypeInfo TermF) (Inc var)
tope') FS (AnnF TypeInfo TermF) (Inc var)
b')
              Just FS (AnnF TypeInfo TermF) (Inc var)
tope'' -> forall (m :: * -> *) a. Monad m => a -> m a
return (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 (forall a. a -> Maybe a
Just (forall var. TermT var -> TermT var -> TermT var
topeAndT FS (AnnF TypeInfo TermF) (Inc var)
tope'' FS (AnnF TypeInfo TermF) (Inc var)
tope')) FS (AnnF TypeInfo TermF) (Inc var)
b')
      TermT var
ty -> forall var a. TypeError var -> TypeCheck var a
issueTypeError forall a b. (a -> b) -> a -> b
$ 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' <- forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
cube forall var. TermT var
cubeT
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall var. VarIdent -> TypeCheck var ()
checkNameShadowing Maybe VarIdent
orig
    forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig TermT var
cube' forall a b. (a -> b) -> a -> b
$ do
      FS (AnnF TypeInfo TermF) (Inc var)
tope' <- forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Scope (FS TermF) var
tope forall var. TermT var
topeT
      forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope FS (AnnF TypeInfo TermF) (Inc var)
tope' forall a b. (a -> b) -> a -> b
$ do
        FS (AnnF TypeInfo TermF) (Inc var)
ret' <- forall var.
Eq var =>
TermT var -> Term var -> TypeCheck var (TermT var)
inferAs forall var. TermT var
universeT Scope (FS TermF) var
ret
        forall (m :: * -> *) a. Monad m => a -> m a
return (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' (forall a. a -> Maybe a
Just FS (AnnF TypeInfo TermF) (Inc var)
tope') FS (AnnF TypeInfo TermF) (Inc var)
ret')

  TypeSigma Maybe VarIdent
orig Term var
a Scope (FS TermF) var
b -> do
    TermT var
a' <- forall var.
Eq var =>
TermT var -> Term var -> TypeCheck var (TermT var)
inferAs forall var. TermT var
universeT Term var
a  -- FIXME: separate universe of universes from universe of types
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall var. VarIdent -> TypeCheck var ()
checkNameShadowing Maybe VarIdent
orig
    FS (AnnF TypeInfo TermF) (Inc var)
b' <- forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig TermT var
a' forall a b. (a -> b) -> a -> b
$ forall var.
Eq var =>
TermT var -> Term var -> TypeCheck var (TermT var)
inferAs forall var. TermT var
universeT Scope (FS TermF) var
b
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall var.
Maybe VarIdent
-> TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
typeSigmaT Maybe VarIdent
orig TermT var
a' FS (AnnF TypeInfo TermF) (Inc var)
b')

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

  App Term var
f Term var
x -> do
    TermT var
f' <- forall var.
Eq var =>
TermT var -> Term var -> TypeCheck var (TermT var)
inferAs forall var. TermT var
universeT Term var
f
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall var. TermT var -> TermT var
stripTypeRestrictions (forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
f') forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      RecBottomT{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall var. TermT var
recBottomT -- FIXME: is this ok?
      TypeFunT TypeInfo (TermT var)
_ty Maybe VarIdent
_orig TermT var
a Maybe (FS (AnnF TypeInfo TermF) (Inc var))
mtope FS (AnnF TypeInfo TermF) (Inc var)
b -> do
        TermT var
x' <- forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
x TermT var
a
        let result :: TermT var
result = forall var. TermT var -> TermT var -> TermT var -> TermT var
appT (forall var.
TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
substituteT TermT var
x' FS (AnnF TypeInfo TermF) (Inc var)
b) TermT var
f' TermT var
x'
        case FS (AnnF TypeInfo TermF) (Inc var)
b of
          UniverseTopeT{} -> do
            case Maybe (FS (AnnF TypeInfo TermF) (Inc var))
mtope of
              Maybe (FS (AnnF TypeInfo TermF) (Inc var))
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return TermT var
result
              Just FS (AnnF TypeInfo TermF) (Inc var)
tope -> do
                forall (m :: * -> *) a. Monad m => a -> m a
return (forall var. TermT var -> TermT var -> TermT var
topeAndT (forall var.
TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
substituteT TermT var
x' FS (AnnF TypeInfo TermF) (Inc var)
tope) TermT var
result)
          FS (AnnF TypeInfo TermF) (Inc var)
_               -> do
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall var. Eq var => TermT var -> TypeCheck var ()
contextEntails forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall var.
TermT var -> Scope (FS (AnnF TypeInfo TermF)) var -> TermT var
substituteT TermT var
x') Maybe (FS (AnnF TypeInfo TermF) (Inc var))
mtope   -- FIXME: need to check?
            forall (m :: * -> *) a. Monad m => a -> m a
return TermT var
result
      TermT var
ty -> forall var a. TypeError var -> TypeCheck var a
issueTypeError forall a b. (a -> b) -> a -> b
$ 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
    forall var a. TypeError var -> TypeCheck var a
issueTypeError forall a b. (a -> b) -> a -> b
$ 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' <- forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
ty
    Maybe (FS (AnnF TypeInfo TermF) (Inc var))
mtope <- forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
ty' 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{} ->
            forall var a. TypeError var -> TypeCheck var a
issueTypeError forall a b. (a -> b) -> a -> b
$ forall var. String -> TypeError var
TypeErrorOther String
"tope params are illegal"
          TermT var
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      -- an argument can be a cube
      UniverseCubeT{} -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      -- an argument can be a shape
      TypeFunT TypeInfo (TermT var)
_ty Maybe VarIdent
_orig TermT var
cube Maybe (FS (AnnF TypeInfo TermF) (Inc var))
_mtope UniverseTopeT{} -> do
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall var. VarIdent -> TypeCheck var ()
checkNameShadowing Maybe VarIdent
orig
        forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig TermT var
cube forall a b. (a -> b) -> a -> b
$ do
          let tope' :: FS (AnnF TypeInfo TermF) (Inc var)
tope' = forall var. TermT var -> TermT var -> TermT var -> TermT var
appT forall var. TermT var
topeT (forall var. var -> Inc var
S forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
ty') (forall (t :: * -> * -> *) a. a -> FS t a
Pure forall var. Inc var
Z)  -- eta expand ty'
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just FS (AnnF TypeInfo TermF) (Inc var)
tope')
      TermT var
kind -> forall var a. TypeError var -> TypeCheck var a
issueTypeError forall a b. (a -> b) -> a -> b
$ forall var. Term var -> TermT var -> TypeError var
TypeErrorInvalidArgumentType Term var
ty TermT var
kind
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall var. VarIdent -> TypeCheck var ()
checkNameShadowing Maybe VarIdent
orig
    forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig TermT var
ty' forall a b. (a -> b) -> a -> b
$ do
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope Maybe (FS (AnnF TypeInfo TermF) (Inc var))
mtope forall a b. (a -> b) -> a -> b
$ do
        FS (AnnF TypeInfo TermF) (Inc var)
body' <- forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Scope (FS TermF) var
body
        FS (AnnF TypeInfo TermF) (Inc var)
ret <- forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf FS (AnnF TypeInfo TermF) (Inc var)
body'
        forall (m :: * -> *) a. Monad m => a -> m a
return (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 (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 (FS (AnnF TypeInfo TermF) (Inc var))
mtope FS (AnnF TypeInfo TermF) (Inc var)
ret) Maybe VarIdent
orig (forall a. a -> Maybe a
Just (TermT var
ty', Maybe (FS (AnnF TypeInfo TermF) (Inc var))
mtope)) FS (AnnF TypeInfo TermF) (Inc 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' <- forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
cube forall var. TermT var
cubeT
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall var. VarIdent -> TypeCheck var ()
checkNameShadowing Maybe VarIdent
orig
    forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig TermT var
cube' forall a b. (a -> b) -> a -> b
$ do
      FS (AnnF TypeInfo TermF) (Inc var)
tope' <- forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Scope (FS TermF) var
tope
      FS (AnnF TypeInfo TermF) (Inc var)
body' <- forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope FS (AnnF TypeInfo TermF) (Inc var)
tope' forall a b. (a -> b) -> a -> b
$ forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Scope (FS TermF) var
body
      FS (AnnF TypeInfo TermF) (Inc var)
ret <- forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf FS (AnnF TypeInfo TermF) (Inc var)
body'
      forall (m :: * -> *) a. Monad m => a -> m a
return (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 (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' (forall a. a -> Maybe a
Just FS (AnnF TypeInfo TermF) (Inc var)
tope') FS (AnnF TypeInfo TermF) (Inc var)
ret) Maybe VarIdent
orig (forall a. a -> Maybe a
Just (TermT var
cube', forall a. a -> Maybe a
Just FS (AnnF TypeInfo TermF) (Inc var)
tope')) FS (AnnF TypeInfo TermF) (Inc var)
body')

  Refl Maybe (Term var, Maybe (Term var))
Nothing -> forall var a. TypeError var -> TypeCheck var a
issueTypeError forall a b. (a -> b) -> a -> b
$ forall var. Term var -> TypeError var
TypeErrorCannotInferBareRefl Term var
tt
  Refl (Just (Term var
x, Maybe (Term var)
Nothing)) -> do
    TermT var
x' <- forall var.
Eq var =>
TermT var -> Term var -> TypeCheck var (TermT var)
inferAs forall var. TermT var
universeT Term var
x
    TermT var
ty <- forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
x'
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall var.
TermT var -> Maybe (TermT var, Maybe (TermT var)) -> TermT var
reflT (forall var.
TermT var -> Maybe (TermT var) -> TermT var -> TermT var
typeIdT TermT var
x' (forall a. a -> Maybe a
Just TermT var
ty) TermT var
x') (forall a. a -> Maybe a
Just (TermT var
x', forall a. a -> Maybe a
Just TermT var
ty)))
  Refl (Just (Term var
x, Just Term var
ty)) -> do
    TermT var
ty' <- forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
ty forall var. TermT var
universeT
    TermT var
x' <- forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
x TermT var
ty'
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall var.
TermT var -> Maybe (TermT var, Maybe (TermT var)) -> TermT var
reflT (forall var.
TermT var -> Maybe (TermT var) -> TermT var -> TermT var
typeIdT TermT var
x' (forall a. a -> Maybe a
Just TermT var
ty') TermT var
x') (forall a. a -> Maybe a
Just (TermT var
x', 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' <- forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
tA forall var. TermT var
universeT
    TermT var
a' <- 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 =
          forall var.
Maybe VarIdent
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeFunT forall a. Maybe a
Nothing TermT var
tA' forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$
            forall var.
Maybe VarIdent
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeFunT forall a. Maybe a
Nothing (forall var.
TermT var -> Maybe (TermT var) -> TermT var -> TermT var
typeIdT (forall var. var -> Inc var
S forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
a') (forall a. a -> Maybe a
Just (forall var. var -> Inc var
S forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
tA')) (forall (t :: * -> * -> *) a. a -> FS t a
Pure forall var. Inc var
Z)) forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$
              forall var. TermT var
universeT
    TermT var
tC' <- 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 =
          forall var. TermT var -> TermT var -> TermT var -> TermT var
appT forall var. TermT var
universeT
            (forall var. TermT var -> TermT var -> TermT var -> TermT var
appT (forall var.
Maybe VarIdent
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeFunT forall a. Maybe a
Nothing (forall var.
TermT var -> Maybe (TermT var) -> TermT var -> TermT var
typeIdT TermT var
a' (forall a. a -> Maybe a
Just TermT var
tA') TermT var
a') forall a. Maybe a
Nothing forall var. TermT var
universeT)
              TermT var
tC' TermT var
a')
            (forall var.
TermT var -> Maybe (TermT var, Maybe (TermT var)) -> TermT var
reflT (forall var.
TermT var -> Maybe (TermT var) -> TermT var -> TermT var
typeIdT TermT var
a' (forall a. a -> Maybe a
Just TermT var
tA') TermT var
a') forall a. Maybe a
Nothing)
    TermT var
d' <- forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
d TermT var
typeOf_d
    TermT var
x' <- forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
x TermT var
tA'
    TermT var
p' <- forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
p (forall var.
TermT var -> Maybe (TermT var) -> TermT var -> TermT var
typeIdT TermT var
a' (forall a. a -> Maybe a
Just TermT var
tA') TermT var
x')
    let ret :: TermT var
ret =
          forall var. TermT var -> TermT var -> TermT var -> TermT var
appT forall var. TermT var
universeT
            (forall var. TermT var -> TermT var -> TermT var -> TermT var
appT (forall var.
Maybe VarIdent
-> TermT var
-> Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
-> Scope (FS (AnnF TypeInfo TermF)) var
-> TermT var
typeFunT forall a. Maybe a
Nothing (forall var.
TermT var -> Maybe (TermT var) -> TermT var -> TermT var
typeIdT TermT var
a' (forall a. a -> Maybe a
Just TermT var
tA') TermT var
x') forall a. Maybe a
Nothing forall var. TermT var
universeT)
              TermT var
tC' TermT var
x')
            TermT var
p'
    forall (m :: * -> *) a. Monad m => a -> m a
return (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' <- forall var.
Eq var =>
TermT var -> Term var -> TypeCheck var (TermT var)
inferAs forall var. TermT var
universeT Term var
ty
    TermT var
term' <- forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
term TermT var
ty'
    forall (m :: * -> *) a. Monad m => a -> m a
return (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' <- forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
ty forall var. TermT var
universeT
    [(TermT var, TermT var)]
rs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Term var, Term var)]
rs forall a b. (a -> b) -> a -> b
$ \(Term var
tope, Term var
term) -> do
      TermT var
tope' <- forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
tope forall var. TermT var
topeT
      TermT var
term' <- forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope TermT var
tope' forall a b. (a -> b) -> a -> b
$ forall var.
Eq var =>
Term var -> TermT var -> TypeCheck var (TermT var)
typecheck Term var
term TermT var
ty'
      forall (m :: * -> *) a. Monad m => a -> m a
return (TermT var
tope', TermT var
term')
    forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ 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'' <- forall a. [a] -> [[a]]
tails [(TermT var, TermT var)]
rs', (TermT var, TermT var)
r <- [(TermT var, TermT var)]
rs'' ]
    forall (m :: * -> *) a. Monad m => a -> m a
return (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) =
  forall var a.
Eq var =>
Action var -> TypeCheck var a -> TypeCheck var a
performing (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)) forall a b. (a -> b) -> a -> b
$ do
    forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope (forall var. TermT var -> TermT var -> TermT var
topeAndT TermT var
ltope TermT var
rtope) forall a b. (a -> b) -> a -> b
$ do
      TermT var
ltype <- forall var. TermT var -> TermT var
stripTypeRestrictions forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
lterm   -- FIXME: why strip?
      TermT var
rtype <- forall var. TermT var -> TermT var
stripTypeRestrictions forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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?
      forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms TermT var
ltype TermT var
rtype
      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 = forall var a.
TypeCheck var a -> Either (TypeErrorInScopedContext var) a
defaultTypeCheck (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 = forall a. TypeCheck VarIdent a -> a
unsafeTypeCheck' (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 forall var a.
TypeCheck var a -> Either (TypeErrorInScopedContext var) a
defaultTypeCheck TypeCheck VarIdent a
tc of
    Left TypeErrorInScopedContext VarIdent
err     -> forall a. HasCallStack => String -> a
error 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   = forall var. TermT var
cube2T
cube2powerT Int
dim = forall var. TermT var -> TermT var -> TermT var
cubeProductT (forall var. Int -> TermT var
cube2powerT (Int
dim forall a. Num a => a -> a -> a
- Int
1)) forall var. TermT var
cube2T

splits :: [a] -> [([a], [a])]
splits :: forall a. [a] -> [([a], [a])]
splits [] = [([], [])]
splits (a
x:[a]
xs) = ([], a
xforall a. a -> [a] -> [a]
:[a]
xs) forall a. a -> [a] -> [a]
: [ (a
x forall a. a -> [a] -> [a]
: [a]
before, [a]
after) | ([a]
before, [a]
after) <- 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 = forall {a} {var}. [([a], TermT var)] -> ([[a]], TermT var)
combine forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM 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", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t forall var. TermT var
cube2_0T), (a
"1", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t forall var. TermT var
cube2_1T)]
    combine :: [([a], TermT var)] -> ([[a]], TermT var)
combine [([a], TermT var)]
xs = ([forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [([a], TermT var)]
xs)], forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall var. TermT var -> TermT var -> TermT var
topeAndT (forall a b. (a -> b) -> [a] -> [b]
map 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", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t forall var. TermT var
cube2_0T)
  , (String -> [String]
words String
"1", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t forall var. TermT var
cube2_1T)
  , (String -> [String]
words String
"0 1", forall var. TermT var
topeTopT) ]
-- 2-dim
subTopes2 Int
2 TermT var
ts =
  -- vertices
  [ (String -> [String]
words String
"00", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t forall var. TermT var
cube2_0T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
s forall var. TermT var
cube2_0T)
  , (String -> [String]
words String
"01", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t forall var. TermT var
cube2_0T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
s forall var. TermT var
cube2_1T)
  , (String -> [String]
words String
"10", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t forall var. TermT var
cube2_1T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
s forall var. TermT var
cube2_0T)
  , (String -> [String]
words String
"11", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t forall var. TermT var
cube2_1T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
s forall var. TermT var
cube2_1T)
  -- edges and the diagonal
  , (String -> [String]
words String
"00 01", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t forall var. TermT var
cube2_0T)
  , (String -> [String]
words String
"10 11", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t forall var. TermT var
cube2_1T)
  , (String -> [String]
words String
"00 10", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
s forall var. TermT var
cube2_0T)
  , (String -> [String]
words String
"01 11", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
s forall var. TermT var
cube2_1T)
  , (String -> [String]
words String
"00 11", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
s TermT var
t)
  -- triangles
  , (String -> [String]
words String
"00 01 11", forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t TermT var
s)
  , (String -> [String]
words String
"00 10 11", forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
s TermT var
t)
  ]
  where
    t :: TermT var
t = forall var. TermT var -> TermT var -> TermT var
firstT forall var. TermT var
cube2T TermT var
ts
    s :: TermT var
s = forall var. TermT var -> TermT var -> TermT var
secondT forall var. TermT var
cube2T TermT var
ts
-- 3-dim
subTopes2 Int
3 TermT var
t =
  -- vertices
  [ (String -> [String]
words String
"000", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 forall var. TermT var
cube2_0T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 forall var. TermT var
cube2_0T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 forall var. TermT var
cube2_0T)
  , (String -> [String]
words String
"001", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 forall var. TermT var
cube2_0T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 forall var. TermT var
cube2_0T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 forall var. TermT var
cube2_1T)
  , (String -> [String]
words String
"010", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 forall var. TermT var
cube2_0T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 forall var. TermT var
cube2_1T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 forall var. TermT var
cube2_0T)
  , (String -> [String]
words String
"011", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 forall var. TermT var
cube2_0T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 forall var. TermT var
cube2_1T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 forall var. TermT var
cube2_1T)
  , (String -> [String]
words String
"100", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 forall var. TermT var
cube2_1T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 forall var. TermT var
cube2_0T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 forall var. TermT var
cube2_0T)
  , (String -> [String]
words String
"101", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 forall var. TermT var
cube2_1T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 forall var. TermT var
cube2_0T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 forall var. TermT var
cube2_1T)
  , (String -> [String]
words String
"110", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 forall var. TermT var
cube2_1T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 forall var. TermT var
cube2_1T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 forall var. TermT var
cube2_0T)
  , (String -> [String]
words String
"111", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 forall var. TermT var
cube2_1T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 forall var. TermT var
cube2_1T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 forall var. TermT var
cube2_1T)
  -- edges
  , (String -> [String]
words String
"000 001", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 forall var. TermT var
cube2_0T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 forall var. TermT var
cube2_0T)
  , (String -> [String]
words String
"010 011", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 forall var. TermT var
cube2_0T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 forall var. TermT var
cube2_1T)
  , (String -> [String]
words String
"000 010", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 forall var. TermT var
cube2_0T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 forall var. TermT var
cube2_0T)
  , (String -> [String]
words String
"001 011", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 forall var. TermT var
cube2_0T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 forall var. TermT var
cube2_1T)
  , (String -> [String]
words String
"100 101", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 forall var. TermT var
cube2_1T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 forall var. TermT var
cube2_0T)
  , (String -> [String]
words String
"110 111", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 forall var. TermT var
cube2_1T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 forall var. TermT var
cube2_1T)
  , (String -> [String]
words String
"100 110", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 forall var. TermT var
cube2_1T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 forall var. TermT var
cube2_0T)
  , (String -> [String]
words String
"101 111", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 forall var. TermT var
cube2_1T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 forall var. TermT var
cube2_1T)
  , (String -> [String]
words String
"000 100", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 forall var. TermT var
cube2_0T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 forall var. TermT var
cube2_0T)
  , (String -> [String]
words String
"001 101", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 forall var. TermT var
cube2_0T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 forall var. TermT var
cube2_1T)
  , (String -> [String]
words String
"010 110", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 forall var. TermT var
cube2_1T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 forall var. TermT var
cube2_0T)
  , (String -> [String]
words String
"011 111", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 forall var. TermT var
cube2_1T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 forall var. TermT var
cube2_1T)
  -- face diagonals
  , (String -> [String]
words String
"000 011", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 forall var. TermT var
cube2_0T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 TermT var
t3)
  , (String -> [String]
words String
"100 111", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 forall var. TermT var
cube2_1T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 TermT var
t3)
  , (String -> [String]
words String
"000 101", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 forall var. TermT var
cube2_0T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
t3)
  , (String -> [String]
words String
"010 111", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 forall var. TermT var
cube2_1T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
t3)
  , (String -> [String]
words String
"000 110", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 forall var. TermT var
cube2_0T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
t2)
  , (String -> [String]
words String
"001 111", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 forall var. TermT var
cube2_1T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
t2)
  -- the long diagonal
  , (String -> [String]
words String
"000 111", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 TermT var
t2 forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 TermT var
t1)
  -- face triangles
  , (String -> [String]
words String
"000 001 011", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 forall var. TermT var
cube2_0T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t2 TermT var
t3)
  , (String -> [String]
words String
"000 010 011", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 forall var. TermT var
cube2_0T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t3 TermT var
t2)
  , (String -> [String]
words String
"100 101 111", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 forall var. TermT var
cube2_1T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t2 TermT var
t3)
  , (String -> [String]
words String
"100 110 111", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 forall var. TermT var
cube2_1T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t3 TermT var
t2)
  , (String -> [String]
words String
"000 001 101", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 forall var. TermT var
cube2_0T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t1 TermT var
t3)
  , (String -> [String]
words String
"000 100 101", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 forall var. TermT var
cube2_0T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t3 TermT var
t1)
  , (String -> [String]
words String
"010 011 111", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 forall var. TermT var
cube2_1T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t1 TermT var
t3)
  , (String -> [String]
words String
"010 110 111", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 forall var. TermT var
cube2_1T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t3 TermT var
t1)
  , (String -> [String]
words String
"000 010 110", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 forall var. TermT var
cube2_0T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t1 TermT var
t2)
  , (String -> [String]
words String
"000 100 110", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 forall var. TermT var
cube2_0T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t2 TermT var
t1)
  , (String -> [String]
words String
"001 011 111", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 forall var. TermT var
cube2_1T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t1 TermT var
t2)
  , (String -> [String]
words String
"001 101 111", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t3 forall var. TermT var
cube2_1T forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t2 TermT var
t1)
  -- diagonal triangles
  , (String -> [String]
words String
"000 001 111", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
t2 forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t2 TermT var
t3)
  , (String -> [String]
words String
"000 010 111", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
t3 forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t1 TermT var
t2)
  , (String -> [String]
words String
"000 100 111", forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 TermT var
t3 forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t2 TermT var
t1)
  , (String -> [String]
words String
"000 011 111", forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t1 TermT var
t2 forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t2 TermT var
t3)
  , (String -> [String]
words String
"000 101 111", forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t2 TermT var
t1 forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
t3)
  , (String -> [String]
words String
"000 110 111", forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t3 TermT var
t1 forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t1 TermT var
t2)
  -- tetrahedra
  , (String -> [String]
words String
"000 001 011 111", forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t1 TermT var
t2 forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t2 TermT var
t3)
  , (String -> [String]
words String
"000 010 011 111", forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t1 TermT var
t3 forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t3 TermT var
t2)
  , (String -> [String]
words String
"000 001 101 111", forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t2 TermT var
t1 forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t1 TermT var
t3)
  , (String -> [String]
words String
"000 100 101 111", forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t2 TermT var
t3 forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t3 TermT var
t1)
  , (String -> [String]
words String
"000 010 110 111", forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t3 TermT var
t1 forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t1 TermT var
t2)
  , (String -> [String]
words String
"000 100 110 111", forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t3 TermT var
t2 forall var. TermT var -> TermT var -> TermT var
`topeAndT` forall var. TermT var -> TermT var -> TermT var
topeLEQT TermT var
t2 TermT var
t1)
  ]
  where
    t1 :: TermT var
t1 = forall var. TermT var -> TermT var -> TermT var
firstT  forall var. TermT var
cube2T (forall var. TermT var -> TermT var -> TermT var
firstT (forall var. Int -> TermT var
cube2powerT Int
2) TermT var
t)
    t2 :: TermT var
t2 = forall var. TermT var -> TermT var -> TermT var
secondT forall var. TermT var
cube2T (forall var. TermT var -> TermT var -> TermT var
firstT (forall var. Int -> TermT var
cube2powerT Int
2) TermT var
t)
    t3 :: TermT var
t3 = forall var. TermT var -> TermT var -> TermT var
secondT forall var. TermT var
cube2T TermT var
t
subTopes2 Int
dim TermT var
_ = forall a. HasCallStack => String -> a
error (forall a. Show a => a -> String
show Int
dim 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 = forall var. Int -> TermT var -> [([String], TermT var)]
subTopes2 Int
3 (forall (t :: * -> * -> *) a. a -> FS t a
Pure forall var. Inc var
Z)

limitLength :: Int -> String -> String
limitLength :: Int -> String -> String
limitLength Int
n String
s
  | forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s forall a. Ord a => a -> a -> Bool
> Int
n = forall a. Int -> [a] -> [a]
take (Int
n forall a. Num a => a -> a -> a
- Int
1) String
s 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ do
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall var. Int -> TermT var -> [([String], TermT var)]
subTopes2 Int
dim TermT var
t) forall a b. (a -> b) -> a -> b
$ \([String]
shapeId, TermT var
tope) -> do
    forall var. Eq var => TermT var -> TypeCheck var Bool
checkTopeEntails TermT var
tope forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      Bool
True -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
term forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        UniverseTopeT{} -> forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope TermT var
term forall a b. (a -> b) -> a -> b
$ forall var. Eq var => TermT var -> TypeCheck var Bool
checkTopeEntails TermT var
tope forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
          Bool
True -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall var. Context var -> [(var, Maybe VarIdent)]
varOrigs
          TermT var
term' <- forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope TermT var
tope forall a b. (a -> b) -> a -> b
$ 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
"_") <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup var
z [(var, Maybe VarIdent)]
origs -> forall (m :: * -> *) a. Monad m => a -> m a
return String
""
                | forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall a. Eq a => [a] -> [a]
nub (forall a. Term a -> [a]
freeVars (forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT var
arg)) forall a. Eq a => [a] -> [a] -> [a]
\\ forall a. Eq a => [a] -> [a]
nub (forall a. Term a -> [a]
freeVars (forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT var
t))) ->
                    forall var. Eq var => TermT var -> TypeCheck var String
ppTermInContext (forall (t :: * -> * -> *) a. a -> FS t a
Pure var
z)
              TermT var
_ -> forall var. Eq var => TermT var -> TypeCheck var String
ppTermInContext TermT var
term'
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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
"_") <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup var
x [(var, Maybe VarIdent)]
origs -> String
mainColor
                    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall a. Eq a => [a] -> [a]
nub (forall a. Term a -> [a]
freeVars (forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT var
arg)) forall a. Eq a => [a] -> [a] -> [a]
\\ forall a. Eq a => [a] -> [a]
nub (forall a. Term a -> [a]
freeVars (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 = forall var. TermT var -> TermT var -> TermT var
topeEQT TermT var
t TermT var
s
componentWiseEQT Int
2 TermT var
t TermT var
s = forall var. TermT var -> TermT var -> TermT var
topeAndT
  (forall var. Int -> TermT var -> TermT var -> TermT var
componentWiseEQT Int
1 (forall var. TermT var -> TermT var -> TermT var
firstT  forall var. TermT var
cube2T TermT var
t) (forall var. TermT var -> TermT var -> TermT var
firstT  forall var. TermT var
cube2T TermT var
s))
  (forall var. Int -> TermT var -> TermT var -> TermT var
componentWiseEQT Int
1 (forall var. TermT var -> TermT var -> TermT var
secondT forall var. TermT var
cube2T TermT var
t) (forall var. TermT var -> TermT var -> TermT var
secondT forall var. TermT var
cube2T TermT var
s))
componentWiseEQT Int
3 TermT var
t TermT var
s = forall var. TermT var -> TermT var -> TermT var
topeAndT
  (forall var. Int -> TermT var -> TermT var -> TermT var
componentWiseEQT Int
2 (forall var. TermT var -> TermT var -> TermT var
firstT  (forall var. Int -> TermT var
cube2powerT Int
2) TermT var
t) (forall var. TermT var -> TermT var -> TermT var
firstT (forall var. Int -> TermT var
cube2powerT Int
2) TermT var
s))
  (forall var. Int -> TermT var -> TermT var -> TermT var
componentWiseEQT Int
1 (forall var. TermT var -> TermT var -> TermT var
secondT forall var. TermT var
cube2T TermT var
t) (forall var. TermT var -> TermT var -> TermT var
secondT forall var. TermT var
cube2T TermT var
s))
componentWiseEQT Int
dim TermT var
_ TermT var
_ = forall a. HasCallStack => String -> a
error (String
"cannot work with " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
dim 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ do
  let reduceContext :: [TermT var] -> TermT var
reduceContext
        = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall var. TermT var -> TermT var -> TermT var
topeOrT forall var. TermT var
topeBottomT
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall var. TermT var -> TermT var -> TermT var
topeAndT forall var. TermT var
topeTopT)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. (a -> Bool) -> [a] -> [a]
filter (\TermT var
tope -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` TermT var
tope) [var]
sub))
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall var. Eq var => [TermT var] -> [TermT var] -> [TermT var]
saturateTopes [])
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall var. Eq var => [TermT var] -> [[TermT var]]
simplifyLHSwithDisjunctions
  TermT var
contextTopes  <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ([TermT var] -> TermT var
reduceContext forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall var. Context var -> [TermT var]
localTopesNF)
  TermT var
contextTopes' <- forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope (forall var. Int -> TermT var -> TermT var -> TermT var
componentWiseEQT Int
dim (forall (t :: * -> * -> *) a. a -> FS t a
Pure var
super) TermT var
x) forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ([TermT var] -> TermT var
reduceContext forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall var. Context var -> [TermT var]
localTopesNF)
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall var. Int -> TermT var -> [([String], TermT var)]
subTopes2 Int
dim (forall (t :: * -> * -> *) a. a -> FS t a
Pure var
super)) forall a b. (a -> b) -> a -> b
$ \([String]
shapeId, TermT var
tope) -> do
    forall var. Eq var => TermT var -> TermT var -> TypeCheck var Bool
checkEntails TermT var
tope TermT var
contextTopes forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      Bool
True -> do
        [(var, Maybe VarIdent)]
origs <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall var. Context var -> [(var, Maybe VarIdent)]
varOrigs
        TermT var
term <- forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope TermT var
tope (forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT (forall var. TermT var -> TermT var -> TermT var -> TermT var
appT TermT var
retType TermT var
f (forall (t :: * -> * -> *) a. a -> FS t a
Pure var
super)))
        String
label <- forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
term forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          UniverseTopeT{} -> 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
"_") <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup var
z [(var, Maybe VarIdent)]
origs -> forall (m :: * -> *) a. Monad m => a -> m a
return String
""
                | forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall a. Eq a => [a] -> [a]
nub (forall a. Term a -> [a]
freeVars (forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT var
arg)) forall a. Eq a => [a] -> [a] -> [a]
\\ [var
super]) -> forall var. Eq var => TermT var -> TypeCheck var String
ppTermInContext (forall (t :: * -> * -> *) a. a -> FS t a
Pure var
z)
              TermT var
_ -> forall var. Eq var => TermT var -> TypeCheck var String
ppTermInContext TermT var
term
        String
color <- forall var. Eq var => TermT var -> TermT var -> TypeCheck var Bool
checkEntails TermT var
tope TermT var
contextTopes' forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Bool
True -> do
            case TermT var
term of
              Pure{} -> forall (m :: * -> *) a. Monad m => a -> m a
return String
"purple"
              AppT TypeInfo (TermT var)
_ (Pure var
z) TermT var
arg
                | Just (Just VarIdent
"_") <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup var
z [(var, Maybe VarIdent)]
origs -> forall (m :: * -> *) a. Monad m => a -> m a
return String
mainColor
                | forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall a. Eq a => [a] -> [a]
nub (forall a. Term a -> [a]
freeVars (forall (ann :: * -> *) (term :: * -> * -> *) a.
(Functor ann, Bifunctor term) =>
FS (AnnF ann term) a -> FS term a
untyped TermT var
arg)) forall a. Eq a => [a] -> [a] -> [a]
\\ [var
super]) -> forall (m :: * -> *) a. Monad m => a -> m a
return String
"purple"
              TermT var
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return String
mainColor
          Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return String
"gray"
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 <- 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' = forall a b. (a -> b) -> [a] -> [b]
map forall {b}. ([String], b) -> (String, b)
mk [([String], RenderObjectData)]
objects
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a.
(Floating a, Show a) =>
Camera a -> a -> (String -> Maybe RenderObjectData) -> String
renderCube forall a. Floating a => Camera a
defaultCamera (if Int
dim forall a. Ord a => a -> a -> Bool
> Int
2 then (forall a. Floating a => a
piforall a. Fractional a => a -> a -> a
/Double
7) else Double
0) forall a b. (a -> b) -> a -> b
$ \String
obj ->
    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) = (forall a. [a] -> [[a]] -> [a]
intercalate String
"-" (forall a b. (a -> b) -> [a] -> [b]
map String -> String
fill [String]
shapeId), b
renderData)
    fill :: String -> String
fill String
xs = String
xs forall a. Semigroup a => a -> a -> a
<> forall a. Int -> a -> [a]
replicate (Int
3 forall a. Num a => a -> a -> a
- 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 <- 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' = forall a b. (a -> b) -> [a] -> [b]
map forall {b}. ([String], b) -> (String, b)
mk [([String], RenderObjectData)]
objects
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a.
(Floating a, Show a) =>
Camera a -> a -> (String -> Maybe RenderObjectData) -> String
renderCube forall a. Floating a => Camera a
defaultCamera (if Int
dim forall a. Ord a => a -> a -> Bool
> Int
2 then (forall a. Floating a => a
piforall a. Fractional a => a -> a -> a
/Double
7) else Double
0) forall a b. (a -> b) -> a -> b
$ \String
obj ->
    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) = (forall a. [a] -> [[a]] -> [a]
intercalate String
"-" (forall a b. (a -> b) -> [a] -> [b]
map String -> String
fill [String]
shapeId), b
renderData)
    fill :: String -> String
fill String
xs = String
xs forall a. Semigroup a => a -> a -> a
<> forall a. Int -> a -> [a]
replicate (Int
3 forall a. Num a => a -> a -> a
- 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' <- forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
t
  TermT var
ty <- 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 -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
f 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 <- forall {ann :: * -> *} {a}. FS (AnnF ann TermF) a -> Maybe Int
dimOf TermT var
fArg, Int
dim forall a. Ord a => a -> a -> Bool
<= Int
maxDim -> do
        forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
fOrig TermT var
fArg forall a b. (a -> b) -> a -> b
$ do
          forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtopeArg forall a b. (a -> b) -> a -> b
$ do
            forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall var.
Eq var =>
String
-> Int
-> [var]
-> var
-> TermT var
-> TermT var
-> TermT var
-> TypeCheck var String
renderForSubShapeSVG String
mainColor Int
dim (forall a b. (a -> b) -> [a] -> [b]
map forall var. var -> Inc var
S [var]
xs) forall var. Inc var
Z Scope (FS (AnnF TypeInfo TermF)) var
ret (forall var. var -> Inc var
S forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
f) (forall var. var -> Inc var
S 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
_ -> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(TermT var
p', TermT var
_) -> 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{} | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [var]
xs -> forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope (forall a. a -> Maybe a
Just VarIdent
"_") TermT var
t' forall a b. (a -> b) -> a -> b
$ do
      forall var.
Eq var =>
String
-> Int
-> (Maybe (TermT var, TermT var), [var])
-> TermT var
-> TypeCheck var (Maybe String)
renderTermSVGFor String
"blue" Int
0 (forall a. Maybe a
Nothing, []) (forall (t :: * -> * -> *) a. a -> FS t a
Pure 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 -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
f 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 <- forall {ann :: * -> *} {a}. FS (AnnF ann TermF) a -> Maybe Int
dimOf TermT var
fArg, Int
dim forall a. Ord a => a -> a -> Bool
<= Int
maxDim -> do
          forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
fOrig TermT var
fArg forall a b. (a -> b) -> a -> b
$ do
            forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtopeArg forall a b. (a -> b) -> a -> b
$ do
              forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall var.
Eq var =>
String
-> Int
-> [var]
-> var
-> TermT var
-> TermT var
-> TermT var
-> TypeCheck var String
renderForSubShapeSVG String
mainColor Int
dim (forall a b. (a -> b) -> [a] -> [b]
map forall var. var -> Inc var
S [var]
xs) forall var. Inc var
Z Scope (FS (AnnF TypeInfo TermF)) var
ret (forall var. var -> Inc var
S forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
f) (forall var. var -> Inc var
S 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
_ -> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(TermT var
p', TermT var
_) -> 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{} | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [var]
xs -> forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope (forall a. a -> Maybe a
Just VarIdent
"_") TermT var
t' forall a b. (a -> b) -> a -> b
$ do
        forall var.
Eq var =>
String
-> Int
-> (Maybe (TermT var, TermT var), [var])
-> TermT var
-> TypeCheck var (Maybe String)
renderTermSVGFor String
"blue" Int
0 (forall a. Maybe a
Nothing, []) (forall (t :: * -> * -> *) a. a -> FS t a
Pure 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 <- forall {ann :: * -> *} {a}. FS (AnnF ann TermF) a -> Maybe Int
dimOf TermT var
arg, Int
accDim forall a. Num a => a -> a -> a
+ Int
dim forall a. Ord a => a -> a -> Bool
<= Int
maxDim -> forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig TermT var
arg forall a b. (a -> b) -> a -> b
$ do
              forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope forall a b. (a -> b) -> a -> b
$
                forall var.
Eq var =>
String
-> Int
-> (Maybe (TermT var, TermT var), [var])
-> TermT var
-> TypeCheck var (Maybe String)
renderTermSVGFor String
mainColor (Int
accDim forall a. Num a => a -> a -> a
+ Int
dim)
                  (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' (forall {t} {b}. (t -> b) -> (t, t) -> (b, b)
both (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall var. var -> Inc var
S) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (TermT var, TermT var)
mp) (forall var. var -> Inc var
S forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
arg) (forall (t :: * -> * -> *) a. a -> FS t a
Pure forall var. Inc var
Z), forall var. Inc var
Z forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall var. var -> Inc var
S [var]
xs) 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
_                          -> forall var. TermT var -> TermT var -> TermT var -> TermT var
appT Scope (FS (AnnF TypeInfo TermF)) var
ret (forall var. var -> Inc var
S forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
t') (forall (t :: * -> * -> *) a. a -> FS t a
Pure forall var. Inc var
Z)
          | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [var]
xs -> forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig TermT var
arg forall a b. (a -> b) -> a -> b
$ do
              forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope forall a b. (a -> b) -> a -> b
$
                forall var.
Eq var =>
String
-> Int
-> (Maybe (TermT var, TermT var), [var])
-> TermT var
-> TypeCheck var (Maybe String)
renderTermSVGFor String
mainColor Int
accDim
                  (forall {t} {b}. (t -> b) -> (t, t) -> (b, b)
both (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall var. var -> Inc var
S) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (TermT var, TermT var)
mp, forall a b. (a -> b) -> [a] -> [b]
map forall var. var -> Inc var
S [var]
xs) 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
_                          -> forall var. TermT var -> TermT var -> TermT var -> TermT var
appT Scope (FS (AnnF TypeInfo TermF)) var
ret (forall var. var -> Inc var
S forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT var
t') (forall (t :: * -> * -> *) a. a -> FS t a
Pure forall var. Inc var
Z)
        TermT var
_ -> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(TermT var
p', TermT var
_) -> 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 = forall a. a -> Maybe a
Just (FS (AnnF TypeInfo TermF) var
x, 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 = 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' = forall var. TermT var -> TermT var -> TermT var
cubeProductT FS (AnnF TypeInfo TermF) var
pt forall var. TermT var
cube2T
        p' :: FS (AnnF TypeInfo TermF) var
p' = 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 (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 (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
_ = forall a. Maybe a
Nothing -- FIXME: error?

    dimOf :: FS (AnnF ann TermF) a -> Maybe Int
dimOf = \case
      Cube2T{}           -> 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 -> forall a. Num a => a -> a -> a
(+) 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 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
_                  -> 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 = forall var.
Eq var =>
String
-> Int
-> (Maybe (TermT var, TermT var), [var])
-> TermT var
-> TypeCheck var (Maybe String)
renderTermSVGFor String
"red" Int
0 (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 = forall var. Eq var => TermT var -> TypeCheck var (TermT var)
whnfT TermT var
t forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TermT var
t' -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf TermT var
t 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 -> forall var b.
Maybe VarIdent
-> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b
enterScope Maybe VarIdent
orig TermT var
arg forall a b. (a -> b) -> a -> b
$ do
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope Maybe (Scope (FS (AnnF TypeInfo TermF)) var)
mtope 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) ->
        forall var. Eq var => TermT var -> TypeCheck var (TermT var)
typeOf Scope (FS (AnnF TypeInfo TermF)) var
f 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 <- forall {ann :: * -> *} {a}. FS (AnnF ann TermF) a -> Maybe Int
dimOf Scope (FS (AnnF TypeInfo TermF)) var
fArg -> do
            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 forall a b. (a -> b) -> a -> b
$ do
              forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall var a.
Eq var =>
TermT var -> TypeCheck var a -> TypeCheck var a
localTope Maybe (Scope (FS (AnnF TypeInfo TermF)) (Inc var))
mtope2 forall a b. (a -> b) -> a -> b
$ do
                forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall var.
Eq var =>
String
-> Int
-> [var]
-> var
-> TermT var
-> TermT var
-> TermT var
-> TypeCheck var String
renderForSubShapeSVG String
"red" Int
dim [forall var. var -> Inc var
S forall var. Inc var
Z] forall var. Inc var
Z (forall var. var -> Inc var
S forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scope (FS (AnnF TypeInfo TermF)) var
ret) (forall var. var -> Inc var
S forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scope (FS (AnnF TypeInfo TermF)) var
f) (forall var. var -> Inc var
S 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
_ -> 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
_ -> 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' -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
  where
    dimOf :: FS (AnnF ann TermF) a -> Maybe Int
dimOf = \case
      Cube2T{}           -> 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 -> forall a. Num a => a -> a -> a
(+) 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 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
_                  -> 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 forall {ann :: * -> *} {a}. FS (AnnF ann TermF) a -> Maybe Int
dimOf FS (AnnF ann TermF) a
arg of
        Just Int
dim | Int
dim forall a. Ord a => a -> a -> Bool
<= Int
3 ->
          forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall var.
Eq var =>
String -> Int -> TermT var -> TermT var -> TypeCheck var String
renderForSVG String
"red" Int
dim (forall (t :: * -> * -> *) a. a -> FS t a
Pure forall var. Inc var
Z) (forall var. TermT var -> TermT var -> TermT var -> TermT var
appT TermT (Inc var)
ret (forall var. var -> Inc var
S forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FS (AnnF TypeInfo TermF) var
t') (forall (t :: * -> * -> *) a. a -> FS t a
Pure forall var. Inc var
Z))
        Maybe Int
_ -> forall var. Eq var => TermT var -> TypeCheck var (Maybe String)
renderTermSVG' (forall var. TermT var -> TermT var -> TermT var -> TermT var
appT TermT (Inc var)
ret (forall var. var -> Inc var
S forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FS (AnnF TypeInfo TermF) var
t') (forall (t :: * -> * -> *) a. a -> FS t a
Pure 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 = forall a. a -> a -> a -> a -> a -> a -> a -> a -> a -> Matrix3D a
Matrix3D
  a
1 a
0 a
0
  a
0 (forall a. Floating a => a -> a
cos a
theta) (- forall a. Floating a => a -> a
sin a
theta)
  a
0 (forall a. Floating a => a -> a
sin a
theta) (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 = forall a. a -> a -> a -> a -> a -> a -> a -> a -> a -> Matrix3D a
Matrix3D
  (forall a. Floating a => a -> a
cos a
theta) a
0 (forall a. Floating a => a -> a
sin a
theta)
  a
0 a
1 a
0
  (- forall a. Floating a => a -> a
sin a
theta) a
0 (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 = forall a. a -> a -> a -> a -> a -> a -> a -> a -> a -> Matrix3D a
Matrix3D
  (forall a. Floating a => a -> a
cos a
theta) (- forall a. Floating a => a -> a
sin a
theta) a
0
  (forall a. Floating a => a -> a
sin a
theta) (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
cameraAngleX :: a
cameraAngleY :: a
cameraAspectRatio :: a
cameraFoV :: a
cameraPos :: Point3D a
cameraAngleX :: forall a. Camera a -> a
cameraAngleY :: forall a. Camera a -> a
cameraAspectRatio :: forall a. Camera a -> a
cameraFoV :: forall a. Camera a -> a
cameraPos :: forall a. Camera a -> Point3D a
..} = forall a. Num a => Matrix3D a -> Matrix4D a
matrix3Dto4D (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
cameraAngleX :: a
cameraAngleY :: a
cameraAspectRatio :: a
cameraFoV :: a
cameraPos :: Point3D a
cameraAngleX :: forall a. Camera a -> a
cameraAngleY :: forall a. Camera a -> a
cameraAspectRatio :: forall a. Camera a -> a
cameraFoV :: forall a. Camera a -> a
cameraPos :: forall a. Camera a -> Point3D a
..} = forall a. Num a => Matrix3D a -> Matrix4D a
matrix3Dto4D (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
cameraAngleX :: a
cameraAngleY :: a
cameraAspectRatio :: a
cameraFoV :: a
cameraPos :: Point3D a
cameraAngleX :: forall a. Camera a -> a
cameraAngleY :: forall a. Camera a -> a
cameraAspectRatio :: forall a. Camera a -> a
cameraFoV :: forall a. Camera a -> a
cameraPos :: forall a. Camera a -> Point3D 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
cameraAngleX :: a
cameraAngleY :: a
cameraAspectRatio :: a
cameraFoV :: a
cameraPos :: Point3D a
cameraAngleX :: forall a. Camera a -> a
cameraAngleY :: forall a. Camera a -> a
cameraAspectRatio :: forall a. Camera a -> a
cameraFoV :: forall a. Camera a -> a
cameraPos :: forall a. Camera a -> Point3D a
..} = forall a.
a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> Matrix4D a
Matrix4D
  (a
2 forall a. Num a => a -> a -> a
* a
n forall a. Fractional a => a -> a -> a
/ (a
r forall a. Num a => a -> a -> a
- a
l)) a
0 ((a
r forall a. Num a => a -> a -> a
+ a
l) forall a. Fractional a => a -> a -> a
/ (a
r forall a. Num a => a -> a -> a
- a
l)) a
0
  a
0 (a
2 forall a. Num a => a -> a -> a
* a
n forall a. Fractional a => a -> a -> a
/ (a
t forall a. Num a => a -> a -> a
- a
b)) ((a
t forall a. Num a => a -> a -> a
+ a
b) forall a. Fractional a => a -> a -> a
/ (a
t forall a. Num a => a -> a -> a
- a
b)) a
0
  a
0 a
0 (- (a
f forall a. Num a => a -> a -> a
+ a
n) forall a. Fractional a => a -> a -> a
/ (a
f forall a. Num a => a -> a -> a
- a
n)) (- a
2 forall a. Num a => a -> a -> a
* a
f forall a. Num a => a -> a -> a
* a
n forall a. Fractional a => a -> a -> a
/ (a
f 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 forall a. Num a => a -> a -> a
* forall a. Floating a => a -> a
tan (a
cameraFoV forall a. Fractional a => a -> a -> a
/ a
2)
    l :: a
l = -a
r
    t :: a
t = a
r 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)
    = forall a. a -> a -> a -> a -> Vector4D a
Vector4D a
a' a
b' a
c' a
d'
  where
    a' :: a
a' = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith 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' = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith 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' = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith 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' = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith 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) = 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 forall a. Fractional a => a -> a -> a
/ a
d
    y :: a
y = a
b forall a. Fractional a => a -> a -> a
/ a
d
    zIndex :: a
zIndex = a
c 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) = forall a. Fractional a => Vector4D a -> (Point2D a, a)
fromAffine forall a b. (a -> b) -> a -> b
$
  forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a. Num a => Matrix4D a -> Vector4D a -> Vector4D a
matrixVectorMult4D (forall a. a -> a -> a -> a -> Vector4D a
Vector4D a
x a
y a
z a
1) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse
    [ forall a. Num a => Matrix3D a -> Matrix4D a
matrix3Dto4D (forall a. Floating a => a -> Matrix3D a
rotateY a
rotY)
    , forall a. Num a => Camera a -> Matrix4D a
viewTranslate Camera a
camera
    , forall a. Floating a => Camera a -> Matrix4D a
viewRotateY Camera a
camera
    , forall a. Floating a => Camera a -> Matrix4D a
viewRotateX Camera a
camera
    , 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 forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null)
  [ String
"<svg class=\"rzk-render\" viewBox=\"-175 -200 350 375\" width=\"150\" height=\"150\">"
  , forall a. [a] -> [[a]] -> [a]
intercalate String
"\n"
      [ String
"  <path d=\"M " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
x1 forall a. Semigroup a => a -> a -> a
<> String
" " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
y1
                forall a. Semigroup a => a -> a -> a
<> String
" L " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
x2 forall a. Semigroup a => a -> a -> a
<> String
" " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
y2
                forall a. Semigroup a => a -> a -> a
<> String
" L " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
x3 forall a. Semigroup a => a -> a -> a
<> String
" " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
y3
                forall a. Semigroup a => a -> a -> a
<> String
" Z\" style=\"fill: " forall a. Semigroup a => a -> a -> a
<> String
renderObjectDataColor forall a. Semigroup a => a -> a -> a
<> String
"; opacity: 0.2\"><title>" forall a. Semigroup a => a -> a -> a
<> String
renderObjectDataFullLabel forall a. Semigroup a => a -> a -> a
<> String
"</title></path>" forall a. Semigroup a => a -> a -> a
<> String
"\n" forall a. Semigroup a => a -> a -> a
<>
        String
"  <text x=\"" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
x forall a. Semigroup a => a -> a -> a
<> String
"\" y=\"" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
y forall a. Semigroup a => a -> a -> a
<> String
"\" fill=\"" forall a. Semigroup a => a -> a -> a
<> String
renderObjectDataColor forall a. Semigroup a => a -> a -> a
<> String
"\">" forall a. Semigroup a => a -> a -> a
<> String
renderObjectDataLabel 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 :: String
renderObjectDataFullLabel :: String
renderObjectDataColor :: String
renderObjectDataColor :: RenderObjectData -> String
renderObjectDataFullLabel :: RenderObjectData -> String
renderObjectDataLabel :: RenderObjectData -> String
..} <- [String -> Maybe RenderObjectData
renderDataOf String
faceId]
      , let x :: a
x = (a
x1 forall a. Num a => a -> a -> a
+ a
x2 forall a. Num a => a -> a -> a
+ a
x3) forall a. Fractional a => a -> a -> a
/ a
3
      , let y :: a
y = (a
y1 forall a. Num a => a -> a -> a
+ a
y2 forall a. Num a => a -> a -> a
+ a
y3) forall a. Fractional a => a -> a -> a
/ a
3 ]
  , forall a. [a] -> [[a]] -> [a]
intercalate String
"\n"
      [ String
"  <polyline points=\"" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
x1 forall a. Semigroup a => a -> a -> a
<> String
"," forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
y1 forall a. Semigroup a => a -> a -> a
<> String
" " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
x2 forall a. Semigroup a => a -> a -> a
<> String
"," forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
y2
        forall a. Semigroup a => a -> a -> a
<> String
"\" stroke=\"" forall a. Semigroup a => a -> a -> a
<> String
renderObjectDataColor forall a. Semigroup a => a -> a -> a
<> String
"\" stroke-width=\"3\" marker-end=\"url(#arrow)\"><title>" forall a. Semigroup a => a -> a -> a
<> String
renderObjectDataFullLabel forall a. Semigroup a => a -> a -> a
<> String
"</title></polyline>" forall a. Semigroup a => a -> a -> a
<> String
"\n" forall a. Semigroup a => a -> a -> a
<>
        String
"  <text x=\"" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
x forall a. Semigroup a => a -> a -> a
<> String
"\" y=\"" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
y forall a. Semigroup a => a -> a -> a
<> String
"\" fill=\"" forall a. Semigroup a => a -> a -> a
<> String
renderObjectDataColor forall a. Semigroup a => a -> a -> a
<> String
"\" stroke=\"white\" stroke-width=\"10\" stroke-opacity=\".8\" paint-order=\"stroke\">" forall a. Semigroup a => a -> a -> a
<> String
renderObjectDataLabel 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 :: String
renderObjectDataFullLabel :: String
renderObjectDataColor :: String
renderObjectDataColor :: RenderObjectData -> String
renderObjectDataFullLabel :: RenderObjectData -> String
renderObjectDataLabel :: RenderObjectData -> String
..} <- [String -> Maybe RenderObjectData
renderDataOf String
edge]
      , let x :: a
x = (a
x1 forall a. Num a => a -> a -> a
+ a
x2) forall a. Fractional a => a -> a -> a
/ a
2
      , let y :: a
y = (a
y1 forall a. Num a => a -> a -> a
+ a
y2) forall a. Fractional a => a -> a -> a
/ a
2 ]
  , forall a. [a] -> [[a]] -> [a]
intercalate String
"\n"
      [ String
"  <text x=\"" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
x forall a. Semigroup a => a -> a -> a
<> String
"\" y=\"" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
y forall a. Semigroup a => a -> a -> a
<> String
"\" fill=\"" forall a. Semigroup a => a -> a -> a
<> String
renderObjectDataColor forall a. Semigroup a => a -> a -> a
<> String
"\">" forall a. Semigroup a => a -> a -> a
<> String
renderObjectDataLabel forall a. Semigroup a => a -> a -> a
<> String
"</text>"
      | (String
v, ((a
x, a
y), a
_)) <- [(String, ((a, a), a))]
vertices
      , Just RenderObjectData{String
renderObjectDataFullLabel :: String
renderObjectDataLabel :: String
renderObjectDataColor :: String
renderObjectDataColor :: RenderObjectData -> String
renderObjectDataFullLabel :: RenderObjectData -> String
renderObjectDataLabel :: RenderObjectData -> 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 -> forall a. Maybe a
Nothing
        Just RenderObjectData{String
renderObjectDataColor :: String
renderObjectDataFullLabel :: String
renderObjectDataLabel :: String
renderObjectDataColor :: RenderObjectData -> String
renderObjectDataFullLabel :: RenderObjectData -> String
renderObjectDataLabel :: RenderObjectData -> String
..} -> forall a. a -> Maybe a
Just RenderObjectData
          -- FIXME: move constants to configurable parameters
          { renderObjectDataLabel :: String
renderObjectDataLabel = 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
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
s Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
s forall a. Ord a => a -> a -> Bool
> Int
n = if Char
'-' 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 =
      [ (forall a. Show a => a -> String
show Integer
x forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Integer
y forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Integer
z, ((a
500 forall a. Num a => a -> a -> a
* a
x'', a
500 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 forall a. Num a => a -> a -> a
* forall a. Num a => Integer -> a
fromInteger Integer
c forall a. Num a => a -> a -> a
- a
1
      , let x' :: a
x' = forall a. Num a => Integer -> a
f Integer
x
      , let y' :: a
y' = forall a. Num a => Integer -> a
f (Integer
1forall a. Num a => a -> a -> a
-Integer
y)
      , let z' :: a
z' = forall a. Num a => Integer -> a
f Integer
z
      , let ((a
x'', a
y''), a
zIndex) = 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 forall a. Num a => a -> a -> a
+ b
dx, b
y1 forall a. Num a => a -> a -> a
+ b
dy), ((b
x2 forall a. Num a => a -> a -> a
- b
dx), (b
y2 forall a. Num a => a -> a -> a
- b
dy)))
      where
        d :: b
d = forall a. Floating a => a -> a
sqrt ((b
x2 forall a. Num a => a -> a -> a
- b
x1)forall a b. (Num a, Integral b) => a -> b -> a
^Integer
2 forall a. Num a => a -> a -> a
+ (b
y2 forall a. Num a => a -> a -> a
- b
y1)forall a b. (Num a, Integral b) => a -> b -> a
^Integer
2)
        dx :: b
dx = b
r forall a. Num a => a -> a -> a
* (b
x2 forall a. Num a => a -> a -> a
- b
x1) forall a. Fractional a => a -> a -> a
/ b
d
        dy :: b
dy = b
r forall a. Num a => a -> a -> a
* (b
y2 forall a. Num a => a -> a -> a
- b
y1) 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 forall a. Num a => a -> a -> a
+ b
s forall a. Num a => a -> a -> a
* (b
x forall a. Num a => a -> a -> a
- b
cx), b
cy forall a. Num a => a -> a -> a
+ b
s forall a. Num a => a -> a -> a
* (b
y 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 forall a. Num a => a -> a -> a
+ a
x2 forall a. Num a => a -> a -> a
+ a
x3) forall a. Fractional a => a -> a -> a
/ a
3
        cy :: a
cy = (a
y1 forall a. Num a => a -> a -> a
+ a
y2 forall a. Num a => a -> a -> a
+ a
y3) forall a. Fractional a => a -> a -> a
/ a
3
        p1 :: (a, a)
p1 = 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 = 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 = 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 =
      [ (forall a. [a] -> [[a]] -> [a]
intercalate String
"-" [String
fromName, String
toName], (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 <- forall a. [a] -> [[a]]
tails [(String, ((a, a), a))]
vertices
      , (String
toName, ((a, a)
to, a
_)) <- [(String, ((a, a), a))]
vs
      , forall (t :: * -> *). Foldable t => t Bool -> Bool
and (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Ord a => a -> a -> Bool
(<=) String
fromName String
toName)
      ]

    faces :: [(String, (((a, a), (a, a), (a, a)), Integer))]
faces =
      [ (forall a. [a] -> [[a]] -> [a]
intercalate String
"-" [String
name1, String
name2, String
name3], (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 <- forall a. [a] -> [[a]]
tails [(String, ((a, a), a))]
vertices
      , (String
name2, ((a, a)
v2, a
_)) : [(String, ((a, a), a))]
vs' <- forall a. [a] -> [[a]]
tails [(String, ((a, a), a))]
vs
      , forall (t :: * -> *). Foldable t => t Bool -> Bool
and (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Ord a => a -> a -> Bool
(<=) String
name1 String
name2)
      , (String
name3, ((a, a)
v3, a
_)) <- [(String, ((a, a), a))]
vs'
      , forall (t :: * -> *). Foldable t => t Bool -> Bool
and (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith 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 = forall a. Floating a => a
pi
  , cameraAngleX :: a
cameraAngleX = forall a. Floating a => a
piforall a. Fractional a => a -> a -> a
/a
5
  , cameraFoV :: a
cameraFoV = forall a. Floating a => a
piforall a. Fractional a => a -> a -> a
/a
15
  , cameraAspectRatio :: a
cameraAspectRatio = a
1
  }