{-# OPTIONS_GHC -fno-warn-type-defaults #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
module Rzk.TypeCheck where
import Control.Applicative ((<|>))
import Control.Monad.Except
import Control.Monad.Reader
import Data.List (intercalate, intersect, nub, tails,
(\\))
import Data.Maybe (catMaybes, fromMaybe, isNothing,
mapMaybe)
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
defaultTypeCheck
:: TypeCheck Rzk.VarIdent a
-> Either (TypeErrorInScopedContext Rzk.VarIdent) a
defaultTypeCheck :: forall a.
TypeCheck VarIdent a
-> Either (TypeErrorInScopedContext VarIdent) a
defaultTypeCheck TypeCheck VarIdent 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 VarIdent a
tc forall var. Context var
emptyContext)
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 Rzk.VarIdent
typecheckModulesWithLocation :: [(FilePath, Rzk.Module)] -> TypeCheck Rzk.VarIdent ()
typecheckModulesWithLocation :: [(String, Module)] -> TypeCheck VarIdent ()
typecheckModulesWithLocation = \case
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
(String, Module)
m : [(String, Module)]
ms -> do
[Decl VarIdent]
decls <- (String, Module) -> TypeCheck VarIdent [Decl VarIdent]
typecheckModuleWithLocation (String, Module)
m
forall a.
[Decl VarIdent] -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclsPrepared [Decl VarIdent]
decls forall a b. (a -> b) -> a -> b
$
[(String, Module)] -> TypeCheck VarIdent ()
typecheckModulesWithLocation [(String, Module)]
ms
typecheckModules :: [Rzk.Module] -> TypeCheck Rzk.VarIdent ()
typecheckModules :: [Module] -> TypeCheck VarIdent ()
typecheckModules = \case
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Module
m : [Module]
ms -> do
[Decl VarIdent]
decls <- Module -> TypeCheck VarIdent [Decl VarIdent]
typecheckModule Module
m
forall a.
[Decl VarIdent] -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclsPrepared [Decl VarIdent]
decls forall a b. (a -> b) -> a -> b
$
[Module] -> TypeCheck VarIdent ()
typecheckModules [Module]
ms
typecheckModuleWithLocation :: (FilePath, Rzk.Module) -> TypeCheck Rzk.VarIdent [Decl']
typecheckModuleWithLocation :: (String, Module) -> TypeCheck VarIdent [Decl 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
$
Module -> TypeCheck VarIdent [Decl VarIdent]
typecheckModule Module
module_
countCommands :: Integral a => [Rzk.Command] -> a
countCommands :: forall a. Integral a => [Command] -> a
countCommands [] = a
0
countCommands (Rzk.CommandSection BNFC'Position
_loc SectionName
_name [Command]
sectionCommands SectionName
_name2 : [Command]
commands) =
forall a. Integral a => [Command] -> a
countCommands [Command]
sectionCommands forall a. Num a => a -> a -> a
+ forall a. Integral a => [Command] -> a
countCommands [Command]
commands
countCommands (Command
_ : [Command]
commands) = a
1 forall a. Num a => a -> a -> a
+ forall a. Integral a => [Command] -> a
countCommands [Command]
commands
typecheckModule :: Rzk.Module -> TypeCheck Rzk.VarIdent [Decl']
typecheckModule :: Module -> TypeCheck VarIdent [Decl VarIdent]
typecheckModule (Rzk.Module BNFC'Position
_moduleLoc LanguageDecl' BNFC'Position
_lang [Command]
commands) =
Maybe SectionName
-> TypeCheck VarIdent [Decl VarIdent]
-> TypeCheck VarIdent [Decl VarIdent]
-> TypeCheck VarIdent [Decl VarIdent]
withSection forall a. Maybe a
Nothing (Integer -> [Command] -> TypeCheck VarIdent [Decl VarIdent]
go Integer
1 [Command]
commands) forall a b. (a -> b) -> a -> b
$
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 Rzk.VarIdent [Decl']
go :: Integer -> [Command] -> TypeCheck VarIdent [Decl 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
forall var a. Command -> TypeCheck var a -> TypeCheck var a
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 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
forall var a. Command -> TypeCheck var a -> TypeCheck var a
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 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
name (Rzk.DeclUsedVars BNFC'Position
_ [VarIdent]
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. Show a => a -> String
show (forall (t :: * -> * -> *) a. a -> FS t a
Pure VarIdent
name :: Term') ) forall a b. (a -> b) -> a -> b
$ do
forall var a. Command -> TypeCheck var a -> TypeCheck var a
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 [VarIdent]
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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall var. TermT var -> TermT var
termIsWHNF
let decl :: Decl VarIdent
decl = forall var.
var -> TermT var -> Maybe (TermT var) -> Bool -> [var] -> Decl var
Decl VarIdent
name TermT VarIdent
ty' (forall a. a -> Maybe a
Just TermT VarIdent
term') Bool
False [VarIdent]
vars
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Decl VarIdent
decl forall a. a -> [a] -> [a]
:) forall a b. (a -> b) -> a -> b
$
forall a.
Decl VarIdent -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclPrepared Decl VarIdent
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 VarIdent
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 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
name (Rzk.DeclUsedVars BNFC'Position
_ [VarIdent]
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. Show a => a -> String
show (forall (t :: * -> * -> *) a. a -> FS t a
Pure VarIdent
name :: Term') ) forall a b. (a -> b) -> a -> b
$ do
forall var a. Command -> TypeCheck var a -> TypeCheck var a
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 [VarIdent]
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 VarIdent
decl = forall var.
var -> TermT var -> Maybe (TermT var) -> Bool -> [var] -> Decl var
Decl VarIdent
name TermT VarIdent
ty' forall a. Maybe a
Nothing Bool
False [VarIdent]
vars
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Decl VarIdent
decl forall a. a -> [a] -> [a]
:) forall a b. (a -> b) -> a -> b
$
forall a.
Decl VarIdent -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclPrepared Decl VarIdent
decl forall a b. (a -> b) -> a -> b
$
Integer -> [Command] -> TypeCheck VarIdent [Decl 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
forall var a. Command -> TypeCheck var a -> TypeCheck var a
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 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 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
forall var a. Command -> TypeCheck var a -> TypeCheck var a
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 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
forall var a. Command -> TypeCheck var a -> TypeCheck var a
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 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]
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. Show a => a -> String
show (forall (t :: * -> * -> *) a. a -> FS t a
Pure VarIdent
name :: Term') | VarIdent
name <- [VarIdent]
names ] ) forall a b. (a -> b) -> a -> b
$ do
forall var a. Command -> TypeCheck var a -> TypeCheck var a
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 VarIdent]
decls = [ forall var.
var -> TermT var -> Maybe (TermT var) -> Bool -> [var] -> Decl var
Decl VarIdent
name TermT VarIdent
ty' forall a. Maybe a
Nothing Bool
True [] | VarIdent
name <- [VarIdent]
names ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Decl VarIdent]
decls forall a. Semigroup a => a -> a -> a
<>) forall a b. (a -> b) -> a -> b
$
forall a.
[Decl VarIdent] -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclsPrepared [Decl VarIdent]
decls forall a b. (a -> b) -> a -> b
$
Integer -> [Command] -> TypeCheck VarIdent [Decl 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]
sectionCommands SectionName
endName) : [Command]
moreCommands) = do
forall var a. Command -> TypeCheck var a -> TypeCheck var a
withCommand Command
command forall a b. (a -> b) -> a -> b
$ 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
Maybe SectionName
-> TypeCheck VarIdent [Decl VarIdent]
-> TypeCheck VarIdent [Decl VarIdent]
-> TypeCheck VarIdent [Decl VarIdent]
withSection (forall a. a -> Maybe a
Just SectionName
name) (Integer -> [Command] -> TypeCheck VarIdent [Decl VarIdent]
go Integer
i [Command]
sectionCommands) forall a b. (a -> b) -> a -> b
$ do
Integer -> [Command] -> TypeCheck VarIdent [Decl VarIdent]
go (Integer
i forall a. Num a => a -> a -> a
+ forall a. Integral a => [Command] -> a
countCommands [Command]
sectionCommands) [Command]
moreCommands
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.ParamPatternShape 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 -> Pattern' a -> Term' a -> Term' a -> ParamDecl' a
Rzk.ParamVarShape BNFC'Position
loc Pattern' BNFC'Position
pat Term' BNFC'Position
cube Term' BNFC'Position
tope]
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 b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\Pattern' BNFC'Position
pat -> forall a. a -> Pattern' a -> Term' a -> ParamDecl' a
Rzk.ParamVarType BNFC'Position
loc Pattern' BNFC'Position
pat Term' BNFC'Position
ty) [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 Rzk.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 Rzk.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 Rzk.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 -> [String] -> String
unlines
[ 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 -> [String] -> String
unlines
[ 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 -> [String] -> String
unlines
[ 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 -> [String] -> String
unlines
[ 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 -> [String] -> String
unlines
[ 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 -> [String] -> String
unlines
[ 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 -> [String] -> String
unlines
[ 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 -> [String] -> String
unlines
[ 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 -> [String] -> String
unlines
[ 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 -> [String] -> String
unlines
[ 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 -> [String] -> String
unlines
[ 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))))]
TypeErrorTopesNotEquivalent TermT VarIdent
expected TermT VarIdent
actual -> [String] -> String
unlines
[ 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 -> [String] -> String
unlines
[ 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
name -> [String] -> String
unlines
[ String
"duplicate top-level definition"
, String
" " forall a. Semigroup a => a -> a -> a
<> forall a. Print a => a -> String
Rzk.printTree VarIdent
name
]
TypeErrorUnusedVariable VarIdent
name TermT VarIdent
type_ -> [String] -> String
unlines
[ String
"unused variable"
, String
" " forall a. Semigroup a => a -> a -> a
<> forall a. Print a => a -> String
Rzk.printTree 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 -> [String] -> String
unlines
[ 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 [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
name
]
TypeErrorImplicitAssumption (VarIdent
a, TermT VarIdent
aType) VarIdent
name -> [String] -> String
unlines
[ String
"implicit assumption"
, String
" " forall a. Semigroup a => a -> a -> a
<> forall a. Print a => a -> String
Rzk.printTree 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
name
]
ppTypeErrorInContext :: TypeErrorInContext Rzk.VarIdent -> String
ppTypeErrorInContext :: TypeErrorInContext VarIdent -> String
ppTypeErrorInContext 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
..} = forall a. [a] -> [[a]] -> [a]
intercalate String
"\n"
[ Context VarIdent -> String
ppContext' Context VarIdent
typeErrorContext
, TypeError VarIdent -> String
ppTypeError' TypeError VarIdent
typeErrorError
]
ppTypeErrorInScopedContextWith'
:: [Rzk.VarIdent]
-> [Rzk.VarIdent]
-> TypeErrorInScopedContext Rzk.VarIdent
-> String
ppTypeErrorInScopedContextWith' :: [VarIdent]
-> [VarIdent] -> TypeErrorInScopedContext VarIdent -> String
ppTypeErrorInScopedContextWith' [VarIdent]
used [VarIdent]
vars = \case
PlainTypeError TypeErrorInContext VarIdent
err -> TypeErrorInContext VarIdent -> String
ppTypeErrorInContext 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) ->
[VarIdent]
-> [VarIdent] -> TypeErrorInScopedContext VarIdent -> String
ppTypeErrorInScopedContextWith' (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)
where
z' :: VarIdent
z' = [VarIdent] -> VarIdent -> VarIdent
refreshVar [VarIdent]
used VarIdent
z
ppTypeErrorInScopedContext' :: TypeErrorInScopedContext Rzk.VarIdent -> String
ppTypeErrorInScopedContext' :: TypeErrorInScopedContext VarIdent -> String
ppTypeErrorInScopedContext' TypeErrorInScopedContext VarIdent
err = [VarIdent]
-> [VarIdent] -> TypeErrorInScopedContext VarIdent -> String
ppTypeErrorInScopedContextWith' [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/fizruk/rzk/issues"
]
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 Rzk.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 (String -> VarIdent
Rzk.VarIdent String
"_") 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 Rzk.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 (String -> VarIdent
Rzk.VarIdent String
"_") 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
| Contravariant
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 Rzk.VarIdent
, forall var. VarInfo var -> Bool
varIsAssumption :: Bool
, 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 Rzk.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
withSection
:: Maybe Rzk.SectionName
-> TypeCheck Rzk.VarIdent [Decl Rzk.VarIdent]
-> TypeCheck Rzk.VarIdent [Decl Rzk.VarIdent]
-> TypeCheck Rzk.VarIdent [Decl Rzk.VarIdent]
withSection :: Maybe SectionName
-> TypeCheck VarIdent [Decl VarIdent]
-> TypeCheck VarIdent [Decl VarIdent]
-> TypeCheck VarIdent [Decl VarIdent]
withSection Maybe SectionName
name TypeCheck VarIdent [Decl VarIdent]
sectionBody TypeCheck VarIdent [Decl VarIdent]
next = do
[Decl VarIdent]
sectionDecls <- forall a.
Maybe SectionName -> TypeCheck VarIdent a -> TypeCheck VarIdent a
startSection Maybe SectionName
name forall a b. (a -> b) -> a -> b
$ do
[Decl VarIdent]
decls <- TypeCheck VarIdent [Decl VarIdent]
sectionBody
forall a.
[Decl VarIdent] -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclsPrepared [Decl VarIdent]
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
TypeCheck VarIdent [Decl VarIdent]
endSection
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Decl VarIdent]
sectionDecls forall a. Semigroup a => a -> a -> a
<>) forall a b. (a -> b) -> a -> b
$
forall a.
[Decl VarIdent] -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclsPrepared [Decl VarIdent]
sectionDecls forall a b. (a -> b) -> a -> b
$
TypeCheck VarIdent [Decl VarIdent]
next
startSection :: Maybe Rzk.SectionName -> TypeCheck Rzk.VarIdent a -> TypeCheck Rzk.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 :: TypeCheck Rzk.VarIdent [Decl Rzk.VarIdent]
endSection :: TypeCheck VarIdent [Decl VarIdent]
endSection = forall var. TypeCheck var (ScopeInfo var)
askCurrentScope forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall var. Eq var => ScopeInfo var -> TypeCheck var [Decl var]
scopeToDecls
scopeToDecls :: Eq var => ScopeInfo var -> TypeCheck var [Decl var]
scopeToDecls :: forall var. Eq var => ScopeInfo var -> TypeCheck var [Decl var]
scopeToDecls 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 =>
[(var, VarInfo var)]
-> [(var, VarInfo var)] -> TypeCheck var [Decl var]
collectScopeDecls [] [(var, VarInfo var)]
scopeVars
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 , [])
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 , (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 => [(var, VarInfo var)] -> [(var, VarInfo var)] -> TypeCheck var [Decl var]
collectScopeDecls :: forall var.
Eq var =>
[(var, VarInfo var)]
-> [(var, VarInfo var)] -> TypeCheck var [Decl var]
collectScopeDecls [(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
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 =>
[(var, VarInfo var)]
-> [(var, VarInfo var)] -> TypeCheck var [Decl var]
collectScopeDecls [(var, VarInfo var)]
recentVars' [(var, VarInfo var)]
vars
| Bool
otherwise = do
forall var.
Eq var =>
[(var, VarInfo var)]
-> [(var, VarInfo var)] -> TypeCheck var [Decl var]
collectScopeDecls ((var, VarInfo var)
decl forall a. a -> [a] -> [a]
: [(var, VarInfo var)]
recentVars) [(var, VarInfo var)]
vars
collectScopeDecls [(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)
ppContext' :: Context Rzk.VarIdent -> String
ppContext' :: Context VarIdent -> String
ppContext' 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]
..} = [String] -> String
unlines
[ String
"Definitions in context:"
, [String] -> String
unlines
[ 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) ]
, forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" (forall a b. (a -> b) -> [a] -> [b]
map ((String
"when " forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Action VarIdent -> String
ppAction Int
0) (forall a. [a] -> [a]
reverse [Action VarIdent]
actionStack))
, String
"Local tope 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]
localTopes)
, case Maybe LocationInfo
location of
Just (LocationInfo (Just String
path) Maybe Int
_) -> String
"\n" forall a. Semigroup a => a -> a -> a
<> 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
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. Show a => a -> String
show (forall (t :: * -> * -> *) a. a -> FS t a
Pure VarIdent
name :: Term')
Just (Rzk.CommandPostulate BNFC'Position
_loc VarIdent
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. Show a => a -> String
show (forall (t :: * -> * -> *) a. a -> FS t a
Pure VarIdent
name :: Term')
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 [Command]
_commands SectionName
_endName) ->
String
" Error occurred when checking\n #section " forall a. Semigroup a => a -> a -> a
<> forall a. Print a => a -> String
Rzk.printTree SectionName
name
Maybe Command
Nothing -> String
" Error occurred"
]
doesShadowName :: Rzk.VarIdent -> TypeCheck var Bool
doesShadowName :: forall var. VarIdent -> TypeCheck var Bool
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 ->
VarIdent
name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` 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 :: Rzk.VarIdent -> TypeCheck var ()
checkTopLevelDuplicate :: forall var. VarIdent -> TypeCheck var ()
checkTopLevelDuplicate VarIdent
name = do
forall var. VarIdent -> TypeCheck var Bool
doesShadowName VarIdent
name forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> forall var a. TypeError var -> TypeCheck var a
issueTypeError (forall var. VarIdent -> TypeError var
TypeErrorDuplicateTopLevel VarIdent
name)
Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkNameShadowing :: Rzk.VarIdent -> TypeCheck var ()
checkNameShadowing :: forall var. VarIdent -> TypeCheck var ()
checkNameShadowing VarIdent
name = do
forall var. VarIdent -> TypeCheck var Bool
doesShadowName VarIdent
name forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> forall var. String -> TypeCheck var ()
issueWarning forall a b. (a -> b) -> a -> b
$
forall a. Print a => a -> String
Rzk.printTree VarIdent
name forall a. Semigroup a => a -> a -> a
<> String
" shadows an existing definition"
Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
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 var a -> TypeCheck var a
withCommand :: forall var a. Command -> TypeCheck var a -> TypeCheck var a
withCommand Command
command = 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 { currentCommand :: Maybe Command
currentCommand = forall a. a -> Maybe a
Just Command
command, Bool
[[TermT var]]
[TermT var]
[ScopeInfo var]
[Action var]
Maybe RenderBackend
Maybe LocationInfo
Covariance
Verbosity
renderBackend :: Maybe RenderBackend
covariance :: Covariance
verbosity :: Verbosity
location :: Maybe LocationInfo
actionStack :: [Action var]
localTopesEntailBottom :: Bool
localTopesNFUnion :: [[TermT var]]
localTopesNF :: [TermT var]
localTopes :: [TermT var]
localScopes :: [ScopeInfo var]
renderBackend :: Maybe RenderBackend
covariance :: Covariance
verbosity :: Verbosity
location :: Maybe LocationInfo
actionStack :: [Action var]
localTopesEntailBottom :: Bool
localTopesNFUnion :: [[TermT var]]
localTopesNF :: [TermT var]
localTopes :: [TermT var]
localScopes :: [ScopeInfo var]
.. }
localDecls :: [Decl Rzk.VarIdent] -> TypeCheck Rzk.VarIdent a -> TypeCheck Rzk.VarIdent a
localDecls :: forall a.
[Decl VarIdent] -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDecls [] = forall a. a -> a
id
localDecls (Decl VarIdent
decl : [Decl VarIdent]
decls) = forall a.
Decl VarIdent -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDecl Decl VarIdent
decl forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
[Decl VarIdent] -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDecls [Decl VarIdent]
decls
localDeclsPrepared :: [Decl Rzk.VarIdent] -> TypeCheck Rzk.VarIdent a -> TypeCheck Rzk.VarIdent a
localDeclsPrepared :: forall a.
[Decl VarIdent] -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclsPrepared [] = forall a. a -> a
id
localDeclsPrepared (Decl VarIdent
decl : [Decl VarIdent]
decls) = forall a.
Decl VarIdent -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclPrepared Decl VarIdent
decl forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
[Decl VarIdent] -> TypeCheck VarIdent a -> TypeCheck VarIdent a
localDeclsPrepared [Decl VarIdent]
decls
localDecl :: Decl Rzk.VarIdent -> TypeCheck Rzk.VarIdent a -> TypeCheck Rzk.VarIdent a
localDecl :: forall a.
Decl VarIdent -> 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 VarIdent -> 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 Rzk.VarIdent -> TypeCheck Rzk.VarIdent a -> TypeCheck Rzk.VarIdent a
localDeclPrepared :: forall a.
Decl VarIdent -> 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]]
simplifyLHS [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))
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
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]
| Bool
otherwise = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[
[ 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 ]
, [ 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' ]
, [ 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' ]
, [ 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' ]
, [ 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' ]
, [ 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' ]
, [ 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' ]
, [ 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' ]
, [ 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' ]
, [ 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' ]
, [ 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 ]
, [ 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 [TermT var]
points, TermT var
y <- [TermT var]
points'
, TermT var
x forall a. Eq a => a -> a -> Bool
/= TermT var
y
, TermT var
x 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
y forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [forall var. TermT var
cube2_0T, forall var. TermT var
cube2_1T] ]
]
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
_ -> []
simplifyLHS :: Eq var => [TermT var] -> [[TermT var]]
simplifyLHS :: forall var. Eq var => [TermT var] -> [[TermT var]]
simplifyLHS [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]]
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')
TopeOrT 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]
topes') forall a. Semigroup a => a -> a -> a
<> forall var. Eq var => [TermT var] -> [[TermT var]]
simplifyLHS (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]]
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' -> forall a b. (a -> b) -> [a] -> [b]
map (TermT var
tforall a. a -> [a] -> [a]
:) (forall var. Eq var => [TermT var] -> [[TermT var]]
simplifyLHS [TermT var]
topes')
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 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
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
forall (m :: * -> *) a. Monad m => a -> m a
return ([TermT var]
topes' forall var. Eq var => [TermT var] -> TermT var -> Bool
`entail` 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
forall (m :: * -> *) a. Monad m => a -> m a
return ([TermT var
restrictionTope] forall var. Eq var => [TermT var] -> TermT var -> Bool
`entail` 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
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
forall (m :: * -> *) a. Monad m => a -> m a
return ([TermT var
l'] forall var. Eq var => [TermT var] -> TermT var -> Bool
`entail` 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
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([TermT var
restrictionTope] forall var. Eq var => [TermT var] -> TermT var -> Bool
`entail` TermT var
contextTopesRHS) 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
restrictionTope] TermT var
contextTopesRHS
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
forall (m :: * -> *) a. Monad m => a -> m a
return ([TermT var
expected'] forall var. Eq var => [TermT var] -> TermT var -> Bool
`entail` TermT var
actual' Bool -> Bool -> Bool
&& [TermT var
actual'] forall var. Eq var => [TermT var] -> TermT var -> Bool
`entail` 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
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([TermT var]
contextTopes forall var. Eq var => [TermT var] -> TermT var -> Bool
`entail` TermT var
recTopesRHS) 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]
contextTopes TermT var
recTopesRHS
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([TermT var]
recTopes forall var. Eq var => [TermT var] -> TermT var -> Bool
`entail` TermT var
contextTopesRHS) 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]
recTopes TermT var
contextTopesRHS
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 Rzk.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 Rzk.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
$
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
etaMatch :: Eq var => Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var (TermT var, TermT var)
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
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
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
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
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
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
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
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'
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
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
TermT var
_ -> do
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
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)
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
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_
[(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 (f :: * -> *) a. Applicative f => a -> f a
pure TermT var
tt
Just TermT var
term -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
term
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'
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
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
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
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 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
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"
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
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
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
CubeProductT{} -> forall var. Eq var => TermT var -> TypeCheck var (TermT var)
nfTope TermT var
tt
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
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
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
TermT var
_ -> do
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
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
let equiv :: Bool
equiv = forall (t :: * -> *). Foldable t => t Bool -> Bool
and
[ [TermT var
l] forall var. Eq var => [TermT var] -> TermT var -> Bool
`entail` TermT var
r
, [TermT var
r] forall var. Eq var => [TermT var] -> TermT var -> Bool
`entail` 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
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 (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
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
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
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'
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 ()
RecOrT TypeInfo (TermT var)
_ty [(TermT var, TermT var)]
rs ->
case TermT var
actual' of
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
$
forall var. Eq var => TermT var -> TermT var -> TypeCheck var ()
unifyTerms TermT var
cube TermT var
cube'
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
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
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
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'))
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
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
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
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
| 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]]
simplifyLHS [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 }
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 Rzk.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 Rzk.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 Rzk.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'
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
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)
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
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
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
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
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
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
UniverseT{} ->
case TermT var
a' of
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')
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')
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)
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
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')
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
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
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
case FS (AnnF TypeInfo TermF) (Inc var)
b of
UniverseTopeT{} -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
FS (AnnF TypeInfo TermF) (Inc var)
_ -> 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
forall (m :: * -> *) a. Monad m => a -> m a
return (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')
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
UniverseT{} ->
case TermT var
ty' of
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
UniverseCubeT{} -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
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)
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
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
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 e a. Except e a -> Either e a
runExcept (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall var. Eq var => Term var -> TypeCheck var (TermT var)
infer Term var
term) forall var. Context var
emptyContext)
unsafeInferStandalone' :: Term' -> TermT'
unsafeInferStandalone' :: Term VarIdent -> TermT VarIdent
unsafeInferStandalone' Term VarIdent
t =
case forall var.
Eq var =>
Term var -> Either (TypeErrorInScopedContext var) (TermT var)
inferStandalone Term VarIdent
t of
Left TypeErrorInScopedContext VarIdent
err -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate String
"\n"
[ String
"Type Error:"
, TypeErrorInScopedContext VarIdent -> String
ppTypeErrorInScopedContext' TypeErrorInScopedContext VarIdent
err
]
Right TermT VarIdent
tt -> TermT VarIdent
tt
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)]
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) ]
subTopes2 Int
2 TermT var
ts =
[ (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)
, (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)
, (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
subTopes2 Int
3 TermT var
t =
[ (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)
, (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)
, (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)
, (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)
, (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)
, (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)
, (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"
})
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]]
simplifyLHS
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
-> Int
-> (Maybe (TermT var, TermT var), [var])
-> TermT var
-> 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
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)
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)
TermT var
_ -> case TermT var
t' of
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)
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)
TermT var
_ -> case TermT var
ty of
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
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, [])
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
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=\"zoom\" style=\"float: right\" 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
{ 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
}